1 !vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv! 2 ! ! 3 ! Software: Netlib BLAS (Basic Linear Algebra Subprograms) ! 4 ! Version: 3.5.0 ! 5 ! Date: November 2013 ! 6 ! License: public domain ! 7 ! ! 8 ! Online html documentation available at http://www.netlib.org/blas ! 9 ! ! 10 ! This file is concatenated from the individual files in blas.tgz. ! 11 ! The source code is otherwise unmodified. ! 12 ! ! 13 !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^! 14 15 !> \brief \b CAXPY 16 ! 17 ! =========== DOCUMENTATION =========== 18 ! 19 ! Online html documentation available at 20 ! http://www.netlib.org/lapack/explore-html/ 21 ! 22 ! Definition: 23 ! =========== 24 ! 25 ! SUBROUTINE CAXPY(N,CA,CX,INCX,CY,INCY) 26 ! 27 ! .. Scalar Arguments .. 28 ! COMPLEX CA 29 ! INTEGER INCX,INCY,N 30 ! .. 31 ! .. Array Arguments .. 32 ! COMPLEX CX(*),CY(*) 33 ! .. 34 ! 35 ! 36 !> \par Purpose: 37 ! ============= 38 !> 39 !> \verbatim 40 !> 41 !> CAXPY constant times a vector plus a vector. 42 !> \endverbatim 43 ! 44 ! Authors: 45 ! ======== 46 ! 47 !> \author Univ. of Tennessee 48 !> \author Univ. of California Berkeley 49 !> \author Univ. of Colorado Denver 50 !> \author NAG Ltd. 51 ! 52 !> \date November 2011 53 ! 54 !> \ingroup complex_blas_level1 55 ! 56 !> \par Further Details: 57 ! ===================== 58 !> 59 !> \verbatim 60 !> 61 !> jack dongarra, linpack, 3/11/78. 62 !> modified 12/3/93, array(1) declarations changed to array(*) 63 !> \endverbatim 64 !> 65 ! ===================================================================== 66 SUBROUTINE CAXPY(N,CA,CX,INCX,CY,INCY) 67 ! 68 ! -- Reference BLAS level1 routine (version 3.4.0) -- 69 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 70 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 71 ! November 2011 72 ! 73 ! .. Scalar Arguments .. 74 COMPLEX CA 75 INTEGER INCX,INCY,N 76 ! .. 77 ! .. Array Arguments .. 78 COMPLEX CX(*),CY(*) 79 ! .. 80 ! 81 ! ===================================================================== 82 ! 83 ! .. Local Scalars .. 84 INTEGER I,IX,IY 85 ! .. 86 ! .. External Functions .. 87 REAL SCABS1 88 EXTERNAL SCABS1 89 ! .. 90 IF (N.LE.0) RETURN 91 IF (SCABS1(CA).EQ.0.0E+0) RETURN 92 IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN 93 ! 94 ! code for both increments equal to 1 95 ! 96 DO I = 1,N 97 CY(I) = CY(I) + CA*CX(I) 98 END DO 99 ELSE 100 ! 101 ! code for unequal increments or equal increments 102 ! not equal to 1 103 ! 104 IX = 1 105 IY = 1 106 IF (INCX.LT.0) IX = (-N+1)*INCX + 1 107 IF (INCY.LT.0) IY = (-N+1)*INCY + 1 108 DO I = 1,N 109 CY(IY) = CY(IY) + CA*CX(IX) 110 IX = IX + INCX 111 IY = IY + INCY 112 END DO 113 END IF 114 ! 115 RETURN 116 END 117 !> \brief \b CCOPY 118 ! 119 ! =========== DOCUMENTATION =========== 120 ! 121 ! Online html documentation available at 122 ! http://www.netlib.org/lapack/explore-html/ 123 ! 124 ! Definition: 125 ! =========== 126 ! 127 ! SUBROUTINE CCOPY(N,CX,INCX,CY,INCY) 128 ! 129 ! .. Scalar Arguments .. 130 ! INTEGER INCX,INCY,N 131 ! .. 132 ! .. Array Arguments .. 133 ! COMPLEX CX(*),CY(*) 134 ! .. 135 ! 136 ! 137 !> \par Purpose: 138 ! ============= 139 !> 140 !> \verbatim 141 !> 142 !> CCOPY copies a vector x to a vector y. 143 !> \endverbatim 144 ! 145 ! Authors: 146 ! ======== 147 ! 148 !> \author Univ. of Tennessee 149 !> \author Univ. of California Berkeley 150 !> \author Univ. of Colorado Denver 151 !> \author NAG Ltd. 152 ! 153 !> \date November 2011 154 ! 155 !> \ingroup complex_blas_level1 156 ! 157 !> \par Further Details: 158 ! ===================== 159 !> 160 !> \verbatim 161 !> 162 !> jack dongarra, linpack, 3/11/78. 163 !> modified 12/3/93, array(1) declarations changed to array(*) 164 !> \endverbatim 165 !> 166 ! ===================================================================== 167 SUBROUTINE CCOPY(N,CX,INCX,CY,INCY) 168 ! 169 ! -- Reference BLAS level1 routine (version 3.4.0) -- 170 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 171 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 172 ! November 2011 173 ! 174 ! .. Scalar Arguments .. 175 INTEGER INCX,INCY,N 176 ! .. 177 ! .. Array Arguments .. 178 COMPLEX CX(*),CY(*) 179 ! .. 180 ! 181 ! ===================================================================== 182 ! 183 ! .. Local Scalars .. 184 INTEGER I,IX,IY 185 ! .. 186 IF (N.LE.0) RETURN 187 IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN 188 ! 189 ! code for both increments equal to 1 190 ! 191 DO I = 1,N 192 CY(I) = CX(I) 193 END DO 194 ELSE 195 ! 196 ! code for unequal increments or equal increments 197 ! not equal to 1 198 ! 199 IX = 1 200 IY = 1 201 IF (INCX.LT.0) IX = (-N+1)*INCX + 1 202 IF (INCY.LT.0) IY = (-N+1)*INCY + 1 203 DO I = 1,N 204 CY(IY) = CX(IX) 205 IX = IX + INCX 206 IY = IY + INCY 207 END DO 208 END IF 209 RETURN 210 END 211 !> \brief \b CROTG 212 ! 213 ! =========== DOCUMENTATION =========== 214 ! 215 ! Online html documentation available at 216 ! http://www.netlib.org/lapack/explore-html/ 217 ! 218 ! Definition: 219 ! =========== 220 ! 221 ! SUBROUTINE CROTG(CA,CB,C,S) 222 ! 223 ! .. Scalar Arguments .. 224 ! COMPLEX CA,CB,S 225 ! REAL C 226 ! .. 227 ! 228 ! 229 !> \par Purpose: 230 ! ============= 231 !> 232 !> \verbatim 233 !> 234 !> CROTG determines a complex Givens rotation. 235 !> \endverbatim 236 ! 237 ! Authors: 238 ! ======== 239 ! 240 !> \author Univ. of Tennessee 241 !> \author Univ. of California Berkeley 242 !> \author Univ. of Colorado Denver 243 !> \author NAG Ltd. 244 ! 245 !> \date November 2011 246 ! 247 !> \ingroup complex_blas_level1 248 ! 249 ! ===================================================================== 250 SUBROUTINE CROTG(CA,CB,C,S) 251 ! 252 ! -- Reference BLAS level1 routine (version 3.4.0) -- 253 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 254 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 255 ! November 2011 256 ! 257 ! .. Scalar Arguments .. 258 COMPLEX CA,CB,S 259 REAL C 260 ! .. 261 ! 262 ! ===================================================================== 263 ! 264 ! .. Local Scalars .. 265 COMPLEX ALPHA 266 REAL NORM,SCALE 267 ! .. 268 ! .. Intrinsic Functions .. 269 INTRINSIC CABS,CONJG,SQRT 270 ! .. 271 IF (CABS(CA).EQ.0.) THEN 272 C = 0. 273 S = (1.,0.) 274 CA = CB 275 ELSE 276 SCALE = CABS(CA) + CABS(CB) 277 NORM = SCALE*SQRT((CABS(CA/SCALE))**2+ (CABS(CB/SCALE))**2) 278 ALPHA = CA/CABS(CA) 279 C = CABS(CA)/NORM 280 S = ALPHA*CONJG(CB)/NORM 281 CA = ALPHA*NORM 282 END IF 283 RETURN 284 END 285 !> \brief \b CSCAL 286 ! 287 ! =========== DOCUMENTATION =========== 288 ! 289 ! Online html documentation available at 290 ! http://www.netlib.org/lapack/explore-html/ 291 ! 292 ! Definition: 293 ! =========== 294 ! 295 ! SUBROUTINE CSCAL(N,CA,CX,INCX) 296 ! 297 ! .. Scalar Arguments .. 298 ! COMPLEX CA 299 ! INTEGER INCX,N 300 ! .. 301 ! .. Array Arguments .. 302 ! COMPLEX CX(*) 303 ! .. 304 ! 305 ! 306 !> \par Purpose: 307 ! ============= 308 !> 309 !> \verbatim 310 !> 311 !> CSCAL scales a vector by a constant. 312 !> \endverbatim 313 ! 314 ! Authors: 315 ! ======== 316 ! 317 !> \author Univ. of Tennessee 318 !> \author Univ. of California Berkeley 319 !> \author Univ. of Colorado Denver 320 !> \author NAG Ltd. 321 ! 322 !> \date November 2011 323 ! 324 !> \ingroup complex_blas_level1 325 ! 326 !> \par Further Details: 327 ! ===================== 328 !> 329 !> \verbatim 330 !> 331 !> jack dongarra, linpack, 3/11/78. 332 !> modified 3/93 to return if incx .le. 0. 333 !> modified 12/3/93, array(1) declarations changed to array(*) 334 !> \endverbatim 335 !> 336 ! ===================================================================== 337 SUBROUTINE CSCAL(N,CA,CX,INCX) 338 ! 339 ! -- Reference BLAS level1 routine (version 3.4.0) -- 340 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 341 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 342 ! November 2011 343 ! 344 ! .. Scalar Arguments .. 345 COMPLEX CA 346 INTEGER INCX,N 347 ! .. 348 ! .. Array Arguments .. 349 COMPLEX CX(*) 350 ! .. 351 ! 352 ! ===================================================================== 353 ! 354 ! .. Local Scalars .. 355 INTEGER I,NINCX 356 ! .. 357 IF (N.LE.0 .OR. INCX.LE.0) RETURN 358 IF (INCX.EQ.1) THEN 359 ! 360 ! code for increment equal to 1 361 ! 362 DO I = 1,N 363 CX(I) = CA*CX(I) 364 END DO 365 ELSE 366 ! 367 ! code for increment not equal to 1 368 ! 369 NINCX = N*INCX 370 DO I = 1,NINCX,INCX 371 CX(I) = CA*CX(I) 372 END DO 373 END IF 374 RETURN 375 END 376 !> \brief \b CSSCAL 377 ! 378 ! =========== DOCUMENTATION =========== 379 ! 380 ! Online html documentation available at 381 ! http://www.netlib.org/lapack/explore-html/ 382 ! 383 ! Definition: 384 ! =========== 385 ! 386 ! SUBROUTINE CSSCAL(N,SA,CX,INCX) 387 ! 388 ! .. Scalar Arguments .. 389 ! REAL SA 390 ! INTEGER INCX,N 391 ! .. 392 ! .. Array Arguments .. 393 ! COMPLEX CX(*) 394 ! .. 395 ! 396 ! 397 !> \par Purpose: 398 ! ============= 399 !> 400 !> \verbatim 401 !> 402 !> CSSCAL scales a complex vector by a real constant. 403 !> \endverbatim 404 ! 405 ! Authors: 406 ! ======== 407 ! 408 !> \author Univ. of Tennessee 409 !> \author Univ. of California Berkeley 410 !> \author Univ. of Colorado Denver 411 !> \author NAG Ltd. 412 ! 413 !> \date November 2011 414 ! 415 !> \ingroup complex_blas_level1 416 ! 417 !> \par Further Details: 418 ! ===================== 419 !> 420 !> \verbatim 421 !> 422 !> jack dongarra, linpack, 3/11/78. 423 !> modified 3/93 to return if incx .le. 0. 424 !> modified 12/3/93, array(1) declarations changed to array(*) 425 !> \endverbatim 426 !> 427 ! ===================================================================== 428 SUBROUTINE CSSCAL(N,SA,CX,INCX) 429 ! 430 ! -- Reference BLAS level1 routine (version 3.4.0) -- 431 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 432 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 433 ! November 2011 434 ! 435 ! .. Scalar Arguments .. 436 REAL SA 437 INTEGER INCX,N 438 ! .. 439 ! .. Array Arguments .. 440 COMPLEX CX(*) 441 ! .. 442 ! 443 ! ===================================================================== 444 ! 445 ! .. Local Scalars .. 446 INTEGER I,NINCX 447 ! .. 448 ! .. Intrinsic Functions .. 449 INTRINSIC AIMAG,CMPLX,REAL 450 ! .. 451 IF (N.LE.0 .OR. INCX.LE.0) RETURN 452 IF (INCX.EQ.1) THEN 453 ! 454 ! code for increment equal to 1 455 ! 456 DO I = 1,N 457 CX(I) = CMPLX(SA*REAL(CX(I)),SA*AIMAG(CX(I))) 458 END DO 459 ELSE 460 ! 461 ! code for increment not equal to 1 462 ! 463 NINCX = N*INCX 464 DO I = 1,NINCX,INCX 465 CX(I) = CMPLX(SA*REAL(CX(I)),SA*AIMAG(CX(I))) 466 END DO 467 END IF 468 RETURN 469 END 470 !> \brief \b CSWAP 471 ! 472 ! =========== DOCUMENTATION =========== 473 ! 474 ! Online html documentation available at 475 ! http://www.netlib.org/lapack/explore-html/ 476 ! 477 ! Definition: 478 ! =========== 479 ! 480 ! SUBROUTINE CSWAP(N,CX,INCX,CY,INCY) 481 ! 482 ! .. Scalar Arguments .. 483 ! INTEGER INCX,INCY,N 484 ! .. 485 ! .. Array Arguments .. 486 ! COMPLEX CX(*),CY(*) 487 ! .. 488 ! 489 ! 490 !> \par Purpose: 491 ! ============= 492 !> 493 !> \verbatim 494 !> 495 !> CSWAP interchanges two vectors. 496 !> \endverbatim 497 ! 498 ! Authors: 499 ! ======== 500 ! 501 !> \author Univ. of Tennessee 502 !> \author Univ. of California Berkeley 503 !> \author Univ. of Colorado Denver 504 !> \author NAG Ltd. 505 ! 506 !> \date November 2011 507 ! 508 !> \ingroup complex_blas_level1 509 ! 510 !> \par Further Details: 511 ! ===================== 512 !> 513 !> \verbatim 514 !> 515 !> jack dongarra, linpack, 3/11/78. 516 !> modified 12/3/93, array(1) declarations changed to array(*) 517 !> \endverbatim 518 !> 519 ! ===================================================================== 520 SUBROUTINE CSWAP(N,CX,INCX,CY,INCY) 521 ! 522 ! -- Reference BLAS level1 routine (version 3.4.0) -- 523 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 524 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 525 ! November 2011 526 ! 527 ! .. Scalar Arguments .. 528 INTEGER INCX,INCY,N 529 ! .. 530 ! .. Array Arguments .. 531 COMPLEX CX(*),CY(*) 532 ! .. 533 ! 534 ! ===================================================================== 535 ! 536 ! .. Local Scalars .. 537 COMPLEX CTEMP 538 INTEGER I,IX,IY 539 ! .. 540 IF (N.LE.0) RETURN 541 IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN 542 ! 543 ! code for both increments equal to 1 544 DO I = 1,N 545 CTEMP = CX(I) 546 CX(I) = CY(I) 547 CY(I) = CTEMP 548 END DO 549 ELSE 550 ! 551 ! code for unequal increments or equal increments not equal 552 ! to 1 553 ! 554 IX = 1 555 IY = 1 556 IF (INCX.LT.0) IX = (-N+1)*INCX + 1 557 IF (INCY.LT.0) IY = (-N+1)*INCY + 1 558 DO I = 1,N 559 CTEMP = CX(IX) 560 CX(IX) = CY(IY) 561 CY(IY) = CTEMP 562 IX = IX + INCX 563 IY = IY + INCY 564 END DO 565 END IF 566 RETURN 567 END 568 !> \brief \b DAXPY 569 ! 570 ! =========== DOCUMENTATION =========== 571 ! 572 ! Online html documentation available at 573 ! http://www.netlib.org/lapack/explore-html/ 574 ! 575 ! Definition: 576 ! =========== 577 ! 578 ! SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) 579 ! 580 ! .. Scalar Arguments .. 581 ! DOUBLE PRECISION DA 582 ! INTEGER INCX,INCY,N 583 ! .. 584 ! .. Array Arguments .. 585 ! DOUBLE PRECISION DX(*),DY(*) 586 ! .. 587 ! 588 ! 589 !> \par Purpose: 590 ! ============= 591 !> 592 !> \verbatim 593 !> 594 !> DAXPY constant times a vector plus a vector. 595 !> uses unrolled loops for increments equal to one. 596 !> \endverbatim 597 ! 598 ! Authors: 599 ! ======== 600 ! 601 !> \author Univ. of Tennessee 602 !> \author Univ. of California Berkeley 603 !> \author Univ. of Colorado Denver 604 !> \author NAG Ltd. 605 ! 606 !> \date November 2011 607 ! 608 !> \ingroup double_blas_level1 609 ! 610 !> \par Further Details: 611 ! ===================== 612 !> 613 !> \verbatim 614 !> 615 !> jack dongarra, linpack, 3/11/78. 616 !> modified 12/3/93, array(1) declarations changed to array(*) 617 !> \endverbatim 618 !> 619 ! ===================================================================== 620 SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) 621 ! 622 ! -- Reference BLAS level1 routine (version 3.4.0) -- 623 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 624 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 625 ! November 2011 626 ! 627 ! .. Scalar Arguments .. 628 DOUBLE PRECISION DA 629 INTEGER INCX,INCY,N 630 ! .. 631 ! .. Array Arguments .. 632 DOUBLE PRECISION DX(*),DY(*) 633 ! .. 634 ! 635 ! ===================================================================== 636 ! 637 ! .. Local Scalars .. 638 INTEGER I,IX,IY,M,MP1 639 ! .. 640 ! .. Intrinsic Functions .. 641 INTRINSIC MOD 642 ! .. 643 IF (N.LE.0) RETURN 644 IF (DA.EQ.0.0d0) RETURN 645 IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN 646 ! 647 ! code for both increments equal to 1 648 ! 649 ! 650 ! clean-up loop 651 ! 652 M = MOD(N,4) 653 IF (M.NE.0) THEN 654 DO I = 1,M 655 DY(I) = DY(I) + DA*DX(I) 656 END DO 657 END IF 658 IF (N.LT.4) RETURN 659 MP1 = M + 1 660 DO I = MP1,N,4 661 DY(I) = DY(I) + DA*DX(I) 662 DY(I+1) = DY(I+1) + DA*DX(I+1) 663 DY(I+2) = DY(I+2) + DA*DX(I+2) 664 DY(I+3) = DY(I+3) + DA*DX(I+3) 665 END DO 666 ELSE 667 ! 668 ! code for unequal increments or equal increments 669 ! not equal to 1 670 ! 671 IX = 1 672 IY = 1 673 IF (INCX.LT.0) IX = (-N+1)*INCX + 1 674 IF (INCY.LT.0) IY = (-N+1)*INCY + 1 675 DO I = 1,N 676 DY(IY) = DY(IY) + DA*DX(IX) 677 IX = IX + INCX 678 IY = IY + INCY 679 END DO 680 END IF 681 RETURN 682 END 683 !> \brief \b DCOPY 684 ! 685 ! =========== DOCUMENTATION =========== 686 ! 687 ! Online html documentation available at 688 ! http://www.netlib.org/lapack/explore-html/ 689 ! 690 ! Definition: 691 ! =========== 692 ! 693 ! SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) 694 ! 695 ! .. Scalar Arguments .. 696 ! INTEGER INCX,INCY,N 697 ! .. 698 ! .. Array Arguments .. 699 ! DOUBLE PRECISION DX(*),DY(*) 700 ! .. 701 ! 702 ! 703 !> \par Purpose: 704 ! ============= 705 !> 706 !> \verbatim 707 !> 708 !> DCOPY copies a vector, x, to a vector, y. 709 !> uses unrolled loops for increments equal to one. 710 !> \endverbatim 711 ! 712 ! Authors: 713 ! ======== 714 ! 715 !> \author Univ. of Tennessee 716 !> \author Univ. of California Berkeley 717 !> \author Univ. of Colorado Denver 718 !> \author NAG Ltd. 719 ! 720 !> \date November 2011 721 ! 722 !> \ingroup double_blas_level1 723 ! 724 !> \par Further Details: 725 ! ===================== 726 !> 727 !> \verbatim 728 !> 729 !> jack dongarra, linpack, 3/11/78. 730 !> modified 12/3/93, array(1) declarations changed to array(*) 731 !> \endverbatim 732 !> 733 ! ===================================================================== 734 SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) 735 ! 736 ! -- Reference BLAS level1 routine (version 3.4.0) -- 737 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 738 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 739 ! November 2011 740 ! 741 ! .. Scalar Arguments .. 742 INTEGER INCX,INCY,N 743 ! .. 744 ! .. Array Arguments .. 745 DOUBLE PRECISION DX(*),DY(*) 746 ! .. 747 ! 748 ! ===================================================================== 749 ! 750 ! .. Local Scalars .. 751 INTEGER I,IX,IY,M,MP1 752 ! .. 753 ! .. Intrinsic Functions .. 754 INTRINSIC MOD 755 ! .. 756 IF (N.LE.0) RETURN 757 IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN 758 ! 759 ! code for both increments equal to 1 760 ! 761 ! 762 ! clean-up loop 763 ! 764 M = MOD(N,7) 765 IF (M.NE.0) THEN 766 DO I = 1,M 767 DY(I) = DX(I) 768 END DO 769 IF (N.LT.7) RETURN 770 END IF 771 MP1 = M + 1 772 DO I = MP1,N,7 773 DY(I) = DX(I) 774 DY(I+1) = DX(I+1) 775 DY(I+2) = DX(I+2) 776 DY(I+3) = DX(I+3) 777 DY(I+4) = DX(I+4) 778 DY(I+5) = DX(I+5) 779 DY(I+6) = DX(I+6) 780 END DO 781 ELSE 782 ! 783 ! code for unequal increments or equal increments 784 ! not equal to 1 785 ! 786 IX = 1 787 IY = 1 788 IF (INCX.LT.0) IX = (-N+1)*INCX + 1 789 IF (INCY.LT.0) IY = (-N+1)*INCY + 1 790 DO I = 1,N 791 DY(IY) = DX(IX) 792 IX = IX + INCX 793 IY = IY + INCY 794 END DO 795 END IF 796 RETURN 797 END 798 !> \brief \b DROT 799 ! 800 ! =========== DOCUMENTATION =========== 801 ! 802 ! Online html documentation available at 803 ! http://www.netlib.org/lapack/explore-html/ 804 ! 805 ! Definition: 806 ! =========== 807 ! 808 ! SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S) 809 ! 810 ! .. Scalar Arguments .. 811 ! DOUBLE PRECISION C,S 812 ! INTEGER INCX,INCY,N 813 ! .. 814 ! .. Array Arguments .. 815 ! DOUBLE PRECISION DX(*),DY(*) 816 ! .. 817 ! 818 ! 819 !> \par Purpose: 820 ! ============= 821 !> 822 !> \verbatim 823 !> 824 !> DROT applies a plane rotation. 825 !> \endverbatim 826 ! 827 ! Authors: 828 ! ======== 829 ! 830 !> \author Univ. of Tennessee 831 !> \author Univ. of California Berkeley 832 !> \author Univ. of Colorado Denver 833 !> \author NAG Ltd. 834 ! 835 !> \date November 2011 836 ! 837 !> \ingroup double_blas_level1 838 ! 839 !> \par Further Details: 840 ! ===================== 841 !> 842 !> \verbatim 843 !> 844 !> jack dongarra, linpack, 3/11/78. 845 !> modified 12/3/93, array(1) declarations changed to array(*) 846 !> \endverbatim 847 !> 848 ! ===================================================================== 849 SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S) 850 ! 851 ! -- Reference BLAS level1 routine (version 3.4.0) -- 852 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 853 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 854 ! November 2011 855 ! 856 ! .. Scalar Arguments .. 857 DOUBLE PRECISION C,S 858 INTEGER INCX,INCY,N 859 ! .. 860 ! .. Array Arguments .. 861 DOUBLE PRECISION DX(*),DY(*) 862 ! .. 863 ! 864 ! ===================================================================== 865 ! 866 ! .. Local Scalars .. 867 DOUBLE PRECISION DTEMP 868 INTEGER I,IX,IY 869 ! .. 870 IF (N.LE.0) RETURN 871 IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN 872 ! 873 ! code for both increments equal to 1 874 ! 875 DO I = 1,N 876 DTEMP = C*DX(I) + S*DY(I) 877 DY(I) = C*DY(I) - S*DX(I) 878 DX(I) = DTEMP 879 END DO 880 ELSE 881 ! 882 ! code for unequal increments or equal increments not equal 883 ! to 1 884 ! 885 IX = 1 886 IY = 1 887 IF (INCX.LT.0) IX = (-N+1)*INCX + 1 888 IF (INCY.LT.0) IY = (-N+1)*INCY + 1 889 DO I = 1,N 890 DTEMP = C*DX(IX) + S*DY(IY) 891 DY(IY) = C*DY(IY) - S*DX(IX) 892 DX(IX) = DTEMP 893 IX = IX + INCX 894 IY = IY + INCY 895 END DO 896 END IF 897 RETURN 898 END 899 !> \brief \b DROTG 900 ! 901 ! =========== DOCUMENTATION =========== 902 ! 903 ! Online html documentation available at 904 ! http://www.netlib.org/lapack/explore-html/ 905 ! 906 ! Definition: 907 ! =========== 908 ! 909 ! SUBROUTINE DROTG(DA,DB,C,S) 910 ! 911 ! .. Scalar Arguments .. 912 ! DOUBLE PRECISION C,DA,DB,S 913 ! .. 914 ! 915 ! 916 !> \par Purpose: 917 ! ============= 918 !> 919 !> \verbatim 920 !> 921 !> DROTG construct givens plane rotation. 922 !> \endverbatim 923 ! 924 ! Authors: 925 ! ======== 926 ! 927 !> \author Univ. of Tennessee 928 !> \author Univ. of California Berkeley 929 !> \author Univ. of Colorado Denver 930 !> \author NAG Ltd. 931 ! 932 !> \date November 2011 933 ! 934 !> \ingroup double_blas_level1 935 ! 936 !> \par Further Details: 937 ! ===================== 938 !> 939 !> \verbatim 940 !> 941 !> jack dongarra, linpack, 3/11/78. 942 !> \endverbatim 943 !> 944 ! ===================================================================== 945 SUBROUTINE DROTG(DA,DB,C,S) 946 ! 947 ! -- Reference BLAS level1 routine (version 3.4.0) -- 948 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 949 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 950 ! November 2011 951 ! 952 ! .. Scalar Arguments .. 953 DOUBLE PRECISION C,DA,DB,S 954 ! .. 955 ! 956 ! ===================================================================== 957 ! 958 ! .. Local Scalars .. 959 DOUBLE PRECISION R,ROE,SCALE,Z 960 ! .. 961 ! .. Intrinsic Functions .. 962 INTRINSIC DABS,DSIGN,DSQRT 963 ! .. 964 ROE = DB 965 IF (DABS(DA).GT.DABS(DB)) ROE = DA 966 SCALE = DABS(DA) + DABS(DB) 967 IF (SCALE.EQ.0.0d0) THEN 968 C = 1.0d0 969 S = 0.0d0 970 R = 0.0d0 971 Z = 0.0d0 972 ELSE 973 R = SCALE*DSQRT((DA/SCALE)**2+ (DB/SCALE)**2) 974 R = DSIGN(1.0d0,ROE)*R 975 C = DA/R 976 S = DB/R 977 Z = 1.0d0 978 IF (DABS(DA).GT.DABS(DB)) Z = S 979 IF (DABS(DB).GE.DABS(DA) .AND. C.NE.0.0d0) Z = 1.0d0/C 980 END IF 981 DA = R 982 DB = Z 983 RETURN 984 END 985 !> \brief \b DSCAL 986 ! 987 ! =========== DOCUMENTATION =========== 988 ! 989 ! Online html documentation available at 990 ! http://www.netlib.org/lapack/explore-html/ 991 ! 992 ! Definition: 993 ! =========== 994 ! 995 ! SUBROUTINE DSCAL(N,DA,DX,INCX) 996 ! 997 ! .. Scalar Arguments .. 998 ! DOUBLE PRECISION DA 999 ! INTEGER INCX,N 1000 ! .. 1001 ! .. Array Arguments .. 1002 ! DOUBLE PRECISION DX(*) 1003 ! .. 1004 ! 1005 ! 1006 !> \par Purpose: 1007 ! ============= 1008 !> 1009 !> \verbatim 1010 !> 1011 !> DSCAL scales a vector by a constant. 1012 !> uses unrolled loops for increment equal to one. 1013 !> \endverbatim 1014 ! 1015 ! Authors: 1016 ! ======== 1017 ! 1018 !> \author Univ. of Tennessee 1019 !> \author Univ. of California Berkeley 1020 !> \author Univ. of Colorado Denver 1021 !> \author NAG Ltd. 1022 ! 1023 !> \date November 2011 1024 ! 1025 !> \ingroup double_blas_level1 1026 ! 1027 !> \par Further Details: 1028 ! ===================== 1029 !> 1030 !> \verbatim 1031 !> 1032 !> jack dongarra, linpack, 3/11/78. 1033 !> modified 3/93 to return if incx .le. 0. 1034 !> modified 12/3/93, array(1) declarations changed to array(*) 1035 !> \endverbatim 1036 !> 1037 ! ===================================================================== 1038 SUBROUTINE DSCAL(N,DA,DX,INCX) 1039 ! 1040 ! -- Reference BLAS level1 routine (version 3.4.0) -- 1041 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 1042 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 1043 ! November 2011 1044 ! 1045 ! .. Scalar Arguments .. 1046 DOUBLE PRECISION DA 1047 INTEGER INCX,N 1048 ! .. 1049 ! .. Array Arguments .. 1050 DOUBLE PRECISION DX(*) 1051 ! .. 1052 ! 1053 ! ===================================================================== 1054 ! 1055 ! .. Local Scalars .. 1056 INTEGER I,M,MP1,NINCX 1057 ! .. 1058 ! .. Intrinsic Functions .. 1059 INTRINSIC MOD 1060 ! .. 1061 IF (N.LE.0 .OR. INCX.LE.0) RETURN 1062 IF (INCX.EQ.1) THEN 1063 ! 1064 ! code for increment equal to 1 1065 ! 1066 ! 1067 ! clean-up loop 1068 ! 1069 M = MOD(N,5) 1070 IF (M.NE.0) THEN 1071 DO I = 1,M 1072 DX(I) = DA*DX(I) 1073 END DO 1074 IF (N.LT.5) RETURN 1075 END IF 1076 MP1 = M + 1 1077 DO I = MP1,N,5 1078 DX(I) = DA*DX(I) 1079 DX(I+1) = DA*DX(I+1) 1080 DX(I+2) = DA*DX(I+2) 1081 DX(I+3) = DA*DX(I+3) 1082 DX(I+4) = DA*DX(I+4) 1083 END DO 1084 ELSE 1085 ! 1086 ! code for increment not equal to 1 1087 ! 1088 NINCX = N*INCX 1089 DO I = 1,NINCX,INCX 1090 DX(I) = DA*DX(I) 1091 END DO 1092 END IF 1093 RETURN 1094 END 1095 !> \brief \b DSWAP 1096 ! 1097 ! =========== DOCUMENTATION =========== 1098 ! 1099 ! Online html documentation available at 1100 ! http://www.netlib.org/lapack/explore-html/ 1101 ! 1102 ! Definition: 1103 ! =========== 1104 ! 1105 ! SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) 1106 ! 1107 ! .. Scalar Arguments .. 1108 ! INTEGER INCX,INCY,N 1109 ! .. 1110 ! .. Array Arguments .. 1111 ! DOUBLE PRECISION DX(*),DY(*) 1112 ! .. 1113 ! 1114 ! 1115 !> \par Purpose: 1116 ! ============= 1117 !> 1118 !> \verbatim 1119 !> 1120 !> interchanges two vectors. 1121 !> uses unrolled loops for increments equal one. 1122 !> \endverbatim 1123 ! 1124 ! Authors: 1125 ! ======== 1126 ! 1127 !> \author Univ. of Tennessee 1128 !> \author Univ. of California Berkeley 1129 !> \author Univ. of Colorado Denver 1130 !> \author NAG Ltd. 1131 ! 1132 !> \date November 2011 1133 ! 1134 !> \ingroup double_blas_level1 1135 ! 1136 !> \par Further Details: 1137 ! ===================== 1138 !> 1139 !> \verbatim 1140 !> 1141 !> jack dongarra, linpack, 3/11/78. 1142 !> modified 12/3/93, array(1) declarations changed to array(*) 1143 !> \endverbatim 1144 !> 1145 ! ===================================================================== 1146 SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) 1147 ! 1148 ! -- Reference BLAS level1 routine (version 3.4.0) -- 1149 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 1150 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 1151 ! November 2011 1152 ! 1153 ! .. Scalar Arguments .. 1154 INTEGER INCX,INCY,N 1155 ! .. 1156 ! .. Array Arguments .. 1157 DOUBLE PRECISION DX(*),DY(*) 1158 ! .. 1159 ! 1160 ! ===================================================================== 1161 ! 1162 ! .. Local Scalars .. 1163 DOUBLE PRECISION DTEMP 1164 INTEGER I,IX,IY,M,MP1 1165 ! .. 1166 ! .. Intrinsic Functions .. 1167 INTRINSIC MOD 1168 ! .. 1169 IF (N.LE.0) RETURN 1170 IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN 1171 ! 1172 ! code for both increments equal to 1 1173 ! 1174 ! 1175 ! clean-up loop 1176 ! 1177 M = MOD(N,3) 1178 IF (M.NE.0) THEN 1179 DO I = 1,M 1180 DTEMP = DX(I) 1181 DX(I) = DY(I) 1182 DY(I) = DTEMP 1183 END DO 1184 IF (N.LT.3) RETURN 1185 END IF 1186 MP1 = M + 1 1187 DO I = MP1,N,3 1188 DTEMP = DX(I) 1189 DX(I) = DY(I) 1190 DY(I) = DTEMP 1191 DTEMP = DX(I+1) 1192 DX(I+1) = DY(I+1) 1193 DY(I+1) = DTEMP 1194 DTEMP = DX(I+2) 1195 DX(I+2) = DY(I+2) 1196 DY(I+2) = DTEMP 1197 END DO 1198 ELSE 1199 ! 1200 ! code for unequal increments or equal increments not equal 1201 ! to 1 1202 ! 1203 IX = 1 1204 IY = 1 1205 IF (INCX.LT.0) IX = (-N+1)*INCX + 1 1206 IF (INCY.LT.0) IY = (-N+1)*INCY + 1 1207 DO I = 1,N 1208 DTEMP = DX(IX) 1209 DX(IX) = DY(IY) 1210 DY(IY) = DTEMP 1211 IX = IX + INCX 1212 IY = IY + INCY 1213 END DO 1214 END IF 1215 RETURN 1216 END 1217 !> \brief \b SAXPY 1218 ! 1219 ! =========== DOCUMENTATION =========== 1220 ! 1221 ! Online html documentation available at 1222 ! http://www.netlib.org/lapack/explore-html/ 1223 ! 1224 ! Definition: 1225 ! =========== 1226 ! 1227 ! SUBROUTINE SAXPY(N,SA,SX,INCX,SY,INCY) 1228 ! 1229 ! .. Scalar Arguments .. 1230 ! REAL SA 1231 ! INTEGER INCX,INCY,N 1232 ! .. 1233 ! .. Array Arguments .. 1234 ! REAL SX(*),SY(*) 1235 ! .. 1236 ! 1237 ! 1238 !> \par Purpose: 1239 ! ============= 1240 !> 1241 !> \verbatim 1242 !> 1243 !> SAXPY constant times a vector plus a vector. 1244 !> uses unrolled loops for increments equal to one. 1245 !> \endverbatim 1246 ! 1247 ! Authors: 1248 ! ======== 1249 ! 1250 !> \author Univ. of Tennessee 1251 !> \author Univ. of California Berkeley 1252 !> \author Univ. of Colorado Denver 1253 !> \author NAG Ltd. 1254 ! 1255 !> \date November 2011 1256 ! 1257 !> \ingroup single_blas_level1 1258 ! 1259 !> \par Further Details: 1260 ! ===================== 1261 !> 1262 !> \verbatim 1263 !> 1264 !> jack dongarra, linpack, 3/11/78. 1265 !> modified 12/3/93, array(1) declarations changed to array(*) 1266 !> \endverbatim 1267 !> 1268 ! ===================================================================== 1269 SUBROUTINE SAXPY(N,SA,SX,INCX,SY,INCY) 1270 ! 1271 ! -- Reference BLAS level1 routine (version 3.4.0) -- 1272 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 1273 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 1274 ! November 2011 1275 ! 1276 ! .. Scalar Arguments .. 1277 REAL SA 1278 INTEGER INCX,INCY,N 1279 ! .. 1280 ! .. Array Arguments .. 1281 REAL SX(*),SY(*) 1282 ! .. 1283 ! 1284 ! ===================================================================== 1285 ! 1286 ! .. Local Scalars .. 1287 INTEGER I,IX,IY,M,MP1 1288 ! .. 1289 ! .. Intrinsic Functions .. 1290 INTRINSIC MOD 1291 ! .. 1292 IF (N.LE.0) RETURN 1293 IF (SA.EQ.0.0) RETURN 1294 IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN 1295 ! 1296 ! code for both increments equal to 1 1297 ! 1298 ! 1299 ! clean-up loop 1300 ! 1301 M = MOD(N,4) 1302 IF (M.NE.0) THEN 1303 DO I = 1,M 1304 SY(I) = SY(I) + SA*SX(I) 1305 END DO 1306 END IF 1307 IF (N.LT.4) RETURN 1308 MP1 = M + 1 1309 DO I = MP1,N,4 1310 SY(I) = SY(I) + SA*SX(I) 1311 SY(I+1) = SY(I+1) + SA*SX(I+1) 1312 SY(I+2) = SY(I+2) + SA*SX(I+2) 1313 SY(I+3) = SY(I+3) + SA*SX(I+3) 1314 END DO 1315 ELSE 1316 ! 1317 ! code for unequal increments or equal increments 1318 ! not equal to 1 1319 ! 1320 IX = 1 1321 IY = 1 1322 IF (INCX.LT.0) IX = (-N+1)*INCX + 1 1323 IF (INCY.LT.0) IY = (-N+1)*INCY + 1 1324 DO I = 1,N 1325 SY(IY) = SY(IY) + SA*SX(IX) 1326 IX = IX + INCX 1327 IY = IY + INCY 1328 END DO 1329 END IF 1330 RETURN 1331 END 1332 !> \brief \b SCOPY 1333 ! 1334 ! =========== DOCUMENTATION =========== 1335 ! 1336 ! Online html documentation available at 1337 ! http://www.netlib.org/lapack/explore-html/ 1338 ! 1339 ! Definition: 1340 ! =========== 1341 ! 1342 ! SUBROUTINE SCOPY(N,SX,INCX,SY,INCY) 1343 ! 1344 ! .. Scalar Arguments .. 1345 ! INTEGER INCX,INCY,N 1346 ! .. 1347 ! .. Array Arguments .. 1348 ! REAL SX(*),SY(*) 1349 ! .. 1350 ! 1351 ! 1352 !> \par Purpose: 1353 ! ============= 1354 !> 1355 !> \verbatim 1356 !> 1357 !> SCOPY copies a vector, x, to a vector, y. 1358 !> uses unrolled loops for increments equal to 1. 1359 !> \endverbatim 1360 ! 1361 ! Authors: 1362 ! ======== 1363 ! 1364 !> \author Univ. of Tennessee 1365 !> \author Univ. of California Berkeley 1366 !> \author Univ. of Colorado Denver 1367 !> \author NAG Ltd. 1368 ! 1369 !> \date November 2011 1370 ! 1371 !> \ingroup single_blas_level1 1372 ! 1373 !> \par Further Details: 1374 ! ===================== 1375 !> 1376 !> \verbatim 1377 !> 1378 !> jack dongarra, linpack, 3/11/78. 1379 !> modified 12/3/93, array(1) declarations changed to array(*) 1380 !> \endverbatim 1381 !> 1382 ! ===================================================================== 1383 SUBROUTINE SCOPY(N,SX,INCX,SY,INCY) 1384 ! 1385 ! -- Reference BLAS level1 routine (version 3.4.0) -- 1386 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 1387 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 1388 ! November 2011 1389 ! 1390 ! .. Scalar Arguments .. 1391 INTEGER INCX,INCY,N 1392 ! .. 1393 ! .. Array Arguments .. 1394 REAL SX(*),SY(*) 1395 ! .. 1396 ! 1397 ! ===================================================================== 1398 ! 1399 ! .. Local Scalars .. 1400 INTEGER I,IX,IY,M,MP1 1401 ! .. 1402 ! .. Intrinsic Functions .. 1403 INTRINSIC MOD 1404 ! .. 1405 IF (N.LE.0) RETURN 1406 IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN 1407 ! 1408 ! code for both increments equal to 1 1409 ! 1410 ! 1411 ! clean-up loop 1412 ! 1413 M = MOD(N,7) 1414 IF (M.NE.0) THEN 1415 DO I = 1,M 1416 SY(I) = SX(I) 1417 END DO 1418 IF (N.LT.7) RETURN 1419 END IF 1420 MP1 = M + 1 1421 DO I = MP1,N,7 1422 SY(I) = SX(I) 1423 SY(I+1) = SX(I+1) 1424 SY(I+2) = SX(I+2) 1425 SY(I+3) = SX(I+3) 1426 SY(I+4) = SX(I+4) 1427 SY(I+5) = SX(I+5) 1428 SY(I+6) = SX(I+6) 1429 END DO 1430 ELSE 1431 ! 1432 ! code for unequal increments or equal increments 1433 ! not equal to 1 1434 ! 1435 IX = 1 1436 IY = 1 1437 IF (INCX.LT.0) IX = (-N+1)*INCX + 1 1438 IF (INCY.LT.0) IY = (-N+1)*INCY + 1 1439 DO I = 1,N 1440 SY(IY) = SX(IX) 1441 IX = IX + INCX 1442 IY = IY + INCY 1443 END DO 1444 END IF 1445 RETURN 1446 END 1447 !> \brief \b SROT 1448 ! 1449 ! =========== DOCUMENTATION =========== 1450 ! 1451 ! Online html documentation available at 1452 ! http://www.netlib.org/lapack/explore-html/ 1453 ! 1454 ! Definition: 1455 ! =========== 1456 ! 1457 ! SUBROUTINE SROT(N,SX,INCX,SY,INCY,C,S) 1458 ! 1459 ! .. Scalar Arguments .. 1460 ! REAL C,S 1461 ! INTEGER INCX,INCY,N 1462 ! .. 1463 ! .. Array Arguments .. 1464 ! REAL SX(*),SY(*) 1465 ! .. 1466 ! 1467 ! 1468 !> \par Purpose: 1469 ! ============= 1470 !> 1471 !> \verbatim 1472 !> 1473 !> applies a plane rotation. 1474 !> \endverbatim 1475 ! 1476 ! Authors: 1477 ! ======== 1478 ! 1479 !> \author Univ. of Tennessee 1480 !> \author Univ. of California Berkeley 1481 !> \author Univ. of Colorado Denver 1482 !> \author NAG Ltd. 1483 ! 1484 !> \date November 2011 1485 ! 1486 !> \ingroup single_blas_level1 1487 ! 1488 !> \par Further Details: 1489 ! ===================== 1490 !> 1491 !> \verbatim 1492 !> 1493 !> jack dongarra, linpack, 3/11/78. 1494 !> modified 12/3/93, array(1) declarations changed to array(*) 1495 !> \endverbatim 1496 !> 1497 ! ===================================================================== 1498 SUBROUTINE SROT(N,SX,INCX,SY,INCY,C,S) 1499 ! 1500 ! -- Reference BLAS level1 routine (version 3.4.0) -- 1501 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 1502 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 1503 ! November 2011 1504 ! 1505 ! .. Scalar Arguments .. 1506 REAL C,S 1507 INTEGER INCX,INCY,N 1508 ! .. 1509 ! .. Array Arguments .. 1510 REAL SX(*),SY(*) 1511 ! .. 1512 ! 1513 ! ===================================================================== 1514 ! 1515 ! .. Local Scalars .. 1516 REAL STEMP 1517 INTEGER I,IX,IY 1518 ! .. 1519 IF (N.LE.0) RETURN 1520 IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN 1521 ! 1522 ! code for both increments equal to 1 1523 ! 1524 DO I = 1,N 1525 STEMP = C*SX(I) + S*SY(I) 1526 SY(I) = C*SY(I) - S*SX(I) 1527 SX(I) = STEMP 1528 END DO 1529 ELSE 1530 ! 1531 ! code for unequal increments or equal increments not equal 1532 ! to 1 1533 ! 1534 IX = 1 1535 IY = 1 1536 IF (INCX.LT.0) IX = (-N+1)*INCX + 1 1537 IF (INCY.LT.0) IY = (-N+1)*INCY + 1 1538 DO I = 1,N 1539 STEMP = C*SX(IX) + S*SY(IY) 1540 SY(IY) = C*SY(IY) - S*SX(IX) 1541 SX(IX) = STEMP 1542 IX = IX + INCX 1543 IY = IY + INCY 1544 END DO 1545 END IF 1546 RETURN 1547 END 1548 !> \brief \b SROTG 1549 ! 1550 ! =========== DOCUMENTATION =========== 1551 ! 1552 ! Online html documentation available at 1553 ! http://www.netlib.org/lapack/explore-html/ 1554 ! 1555 ! Definition: 1556 ! =========== 1557 ! 1558 ! SUBROUTINE SROTG(SA,SB,C,S) 1559 ! 1560 ! .. Scalar Arguments .. 1561 ! REAL C,S,SA,SB 1562 ! .. 1563 ! 1564 ! 1565 !> \par Purpose: 1566 ! ============= 1567 !> 1568 !> \verbatim 1569 !> 1570 !> SROTG construct givens plane rotation. 1571 !> \endverbatim 1572 ! 1573 ! Authors: 1574 ! ======== 1575 ! 1576 !> \author Univ. of Tennessee 1577 !> \author Univ. of California Berkeley 1578 !> \author Univ. of Colorado Denver 1579 !> \author NAG Ltd. 1580 ! 1581 !> \date November 2011 1582 ! 1583 !> \ingroup single_blas_level1 1584 ! 1585 !> \par Further Details: 1586 ! ===================== 1587 !> 1588 !> \verbatim 1589 !> 1590 !> jack dongarra, linpack, 3/11/78. 1591 !> \endverbatim 1592 !> 1593 ! ===================================================================== 1594 SUBROUTINE SROTG(SA,SB,C,S) 1595 ! 1596 ! -- Reference BLAS level1 routine (version 3.4.0) -- 1597 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 1598 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 1599 ! November 2011 1600 ! 1601 ! .. Scalar Arguments .. 1602 REAL C,S,SA,SB 1603 ! .. 1604 ! 1605 ! ===================================================================== 1606 ! 1607 ! .. Local Scalars .. 1608 REAL R,ROE,SCALE,Z 1609 ! .. 1610 ! .. Intrinsic Functions .. 1611 INTRINSIC ABS,SIGN,SQRT 1612 ! .. 1613 ROE = SB 1614 IF (ABS(SA).GT.ABS(SB)) ROE = SA 1615 SCALE = ABS(SA) + ABS(SB) 1616 IF (SCALE.EQ.0.0) THEN 1617 C = 1.0 1618 S = 0.0 1619 R = 0.0 1620 Z = 0.0 1621 ELSE 1622 R = SCALE*SQRT((SA/SCALE)**2+ (SB/SCALE)**2) 1623 R = SIGN(1.0,ROE)*R 1624 C = SA/R 1625 S = SB/R 1626 Z = 1.0 1627 IF (ABS(SA).GT.ABS(SB)) Z = S 1628 IF (ABS(SB).GE.ABS(SA) .AND. C.NE.0.0) Z = 1.0/C 1629 END IF 1630 SA = R 1631 SB = Z 1632 RETURN 1633 END 1634 !> \brief \b SSCAL 1635 ! 1636 ! =========== DOCUMENTATION =========== 1637 ! 1638 ! Online html documentation available at 1639 ! http://www.netlib.org/lapack/explore-html/ 1640 ! 1641 ! Definition: 1642 ! =========== 1643 ! 1644 ! SUBROUTINE SSCAL(N,SA,SX,INCX) 1645 ! 1646 ! .. Scalar Arguments .. 1647 ! REAL SA 1648 ! INTEGER INCX,N 1649 ! .. 1650 ! .. Array Arguments .. 1651 ! REAL SX(*) 1652 ! .. 1653 ! 1654 ! 1655 !> \par Purpose: 1656 ! ============= 1657 !> 1658 !> \verbatim 1659 !> 1660 !> scales a vector by a constant. 1661 !> uses unrolled loops for increment equal to 1. 1662 !> \endverbatim 1663 ! 1664 ! Authors: 1665 ! ======== 1666 ! 1667 !> \author Univ. of Tennessee 1668 !> \author Univ. of California Berkeley 1669 !> \author Univ. of Colorado Denver 1670 !> \author NAG Ltd. 1671 ! 1672 !> \date November 2011 1673 ! 1674 !> \ingroup single_blas_level1 1675 ! 1676 !> \par Further Details: 1677 ! ===================== 1678 !> 1679 !> \verbatim 1680 !> 1681 !> jack dongarra, linpack, 3/11/78. 1682 !> modified 3/93 to return if incx .le. 0. 1683 !> modified 12/3/93, array(1) declarations changed to array(*) 1684 !> \endverbatim 1685 !> 1686 ! ===================================================================== 1687 SUBROUTINE SSCAL(N,SA,SX,INCX) 1688 ! 1689 ! -- Reference BLAS level1 routine (version 3.4.0) -- 1690 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 1691 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 1692 ! November 2011 1693 ! 1694 ! .. Scalar Arguments .. 1695 REAL SA 1696 INTEGER INCX,N 1697 ! .. 1698 ! .. Array Arguments .. 1699 REAL SX(*) 1700 ! .. 1701 ! 1702 ! ===================================================================== 1703 ! 1704 ! .. Local Scalars .. 1705 INTEGER I,M,MP1,NINCX 1706 ! .. 1707 ! .. Intrinsic Functions .. 1708 INTRINSIC MOD 1709 ! .. 1710 IF (N.LE.0 .OR. INCX.LE.0) RETURN 1711 IF (INCX.EQ.1) THEN 1712 ! 1713 ! code for increment equal to 1 1714 ! 1715 ! 1716 ! clean-up loop 1717 ! 1718 M = MOD(N,5) 1719 IF (M.NE.0) THEN 1720 DO I = 1,M 1721 SX(I) = SA*SX(I) 1722 END DO 1723 IF (N.LT.5) RETURN 1724 END IF 1725 MP1 = M + 1 1726 DO I = MP1,N,5 1727 SX(I) = SA*SX(I) 1728 SX(I+1) = SA*SX(I+1) 1729 SX(I+2) = SA*SX(I+2) 1730 SX(I+3) = SA*SX(I+3) 1731 SX(I+4) = SA*SX(I+4) 1732 END DO 1733 ELSE 1734 ! 1735 ! code for increment not equal to 1 1736 ! 1737 NINCX = N*INCX 1738 DO I = 1,NINCX,INCX 1739 SX(I) = SA*SX(I) 1740 END DO 1741 END IF 1742 RETURN 1743 END 1744 !> \brief \b SSWAP 1745 ! 1746 ! =========== DOCUMENTATION =========== 1747 ! 1748 ! Online html documentation available at 1749 ! http://www.netlib.org/lapack/explore-html/ 1750 ! 1751 ! Definition: 1752 ! =========== 1753 ! 1754 ! SUBROUTINE SSWAP(N,SX,INCX,SY,INCY) 1755 ! 1756 ! .. Scalar Arguments .. 1757 ! INTEGER INCX,INCY,N 1758 ! .. 1759 ! .. Array Arguments .. 1760 ! REAL SX(*),SY(*) 1761 ! .. 1762 ! 1763 ! 1764 !> \par Purpose: 1765 ! ============= 1766 !> 1767 !> \verbatim 1768 !> 1769 !> interchanges two vectors. 1770 !> uses unrolled loops for increments equal to 1. 1771 !> \endverbatim 1772 ! 1773 ! Authors: 1774 ! ======== 1775 ! 1776 !> \author Univ. of Tennessee 1777 !> \author Univ. of California Berkeley 1778 !> \author Univ. of Colorado Denver 1779 !> \author NAG Ltd. 1780 ! 1781 !> \date November 2011 1782 ! 1783 !> \ingroup single_blas_level1 1784 ! 1785 !> \par Further Details: 1786 ! ===================== 1787 !> 1788 !> \verbatim 1789 !> 1790 !> jack dongarra, linpack, 3/11/78. 1791 !> modified 12/3/93, array(1) declarations changed to array(*) 1792 !> \endverbatim 1793 !> 1794 ! ===================================================================== 1795 SUBROUTINE SSWAP(N,SX,INCX,SY,INCY) 1796 ! 1797 ! -- Reference BLAS level1 routine (version 3.4.0) -- 1798 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 1799 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 1800 ! November 2011 1801 ! 1802 ! .. Scalar Arguments .. 1803 INTEGER INCX,INCY,N 1804 ! .. 1805 ! .. Array Arguments .. 1806 REAL SX(*),SY(*) 1807 ! .. 1808 ! 1809 ! ===================================================================== 1810 ! 1811 ! .. Local Scalars .. 1812 REAL STEMP 1813 INTEGER I,IX,IY,M,MP1 1814 ! .. 1815 ! .. Intrinsic Functions .. 1816 INTRINSIC MOD 1817 ! .. 1818 IF (N.LE.0) RETURN 1819 IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN 1820 ! 1821 ! code for both increments equal to 1 1822 ! 1823 ! 1824 ! clean-up loop 1825 ! 1826 M = MOD(N,3) 1827 IF (M.NE.0) THEN 1828 DO I = 1,M 1829 STEMP = SX(I) 1830 SX(I) = SY(I) 1831 SY(I) = STEMP 1832 END DO 1833 IF (N.LT.3) RETURN 1834 END IF 1835 MP1 = M + 1 1836 DO I = MP1,N,3 1837 STEMP = SX(I) 1838 SX(I) = SY(I) 1839 SY(I) = STEMP 1840 STEMP = SX(I+1) 1841 SX(I+1) = SY(I+1) 1842 SY(I+1) = STEMP 1843 STEMP = SX(I+2) 1844 SX(I+2) = SY(I+2) 1845 SY(I+2) = STEMP 1846 END DO 1847 ELSE 1848 ! 1849 ! code for unequal increments or equal increments not equal 1850 ! to 1 1851 ! 1852 IX = 1 1853 IY = 1 1854 IF (INCX.LT.0) IX = (-N+1)*INCX + 1 1855 IF (INCY.LT.0) IY = (-N+1)*INCY + 1 1856 DO I = 1,N 1857 STEMP = SX(IX) 1858 SX(IX) = SY(IY) 1859 SY(IY) = STEMP 1860 IX = IX + INCX 1861 IY = IY + INCY 1862 END DO 1863 END IF 1864 RETURN 1865 END 1866 !> \brief \b CDOTC 1867 ! 1868 ! =========== DOCUMENTATION =========== 1869 ! 1870 ! Online html documentation available at 1871 ! http://www.netlib.org/lapack/explore-html/ 1872 ! 1873 ! Definition: 1874 ! =========== 1875 ! 1876 ! COMPLEX FUNCTION CDOTC(N,CX,INCX,CY,INCY) 1877 ! 1878 ! .. Scalar Arguments .. 1879 ! INTEGER INCX,INCY,N 1880 ! .. 1881 ! .. Array Arguments .. 1882 ! COMPLEX CX(*),CY(*) 1883 ! .. 1884 ! 1885 ! 1886 !> \par Purpose: 1887 ! ============= 1888 !> 1889 !> \verbatim 1890 !> 1891 !> forms the dot product of two vectors, conjugating the first 1892 !> vector. 1893 !> \endverbatim 1894 ! 1895 ! Authors: 1896 ! ======== 1897 ! 1898 !> \author Univ. of Tennessee 1899 !> \author Univ. of California Berkeley 1900 !> \author Univ. of Colorado Denver 1901 !> \author NAG Ltd. 1902 ! 1903 !> \date November 2011 1904 ! 1905 !> \ingroup complex_blas_level1 1906 ! 1907 !> \par Further Details: 1908 ! ===================== 1909 !> 1910 !> \verbatim 1911 !> 1912 !> jack dongarra, linpack, 3/11/78. 1913 !> modified 12/3/93, array(1) declarations changed to array(*) 1914 !> \endverbatim 1915 !> 1916 ! ===================================================================== 1917 COMPLEX FUNCTION CDOTC(N,CX,INCX,CY,INCY) 1918 ! 1919 ! -- Reference BLAS level1 routine (version 3.4.0) -- 1920 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 1921 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 1922 ! November 2011 1923 ! 1924 ! .. Scalar Arguments .. 1925 INTEGER INCX,INCY,N 1926 ! .. 1927 ! .. Array Arguments .. 1928 COMPLEX CX(*),CY(*) 1929 ! .. 1930 ! 1931 ! ===================================================================== 1932 ! 1933 ! .. Local Scalars .. 1934 COMPLEX CTEMP 1935 INTEGER I,IX,IY 1936 ! .. 1937 ! .. Intrinsic Functions .. 1938 INTRINSIC CONJG 1939 ! .. 1940 CTEMP = (0.0,0.0) 1941 CDOTC = (0.0,0.0) 1942 IF (N.LE.0) RETURN 1943 IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN 1944 ! 1945 ! code for both increments equal to 1 1946 ! 1947 DO I = 1,N 1948 CTEMP = CTEMP + CONJG(CX(I))*CY(I) 1949 END DO 1950 ELSE 1951 ! 1952 ! code for unequal increments or equal increments 1953 ! not equal to 1 1954 ! 1955 IX = 1 1956 IY = 1 1957 IF (INCX.LT.0) IX = (-N+1)*INCX + 1 1958 IF (INCY.LT.0) IY = (-N+1)*INCY + 1 1959 DO I = 1,N 1960 CTEMP = CTEMP + CONJG(CX(IX))*CY(IY) 1961 IX = IX + INCX 1962 IY = IY + INCY 1963 END DO 1964 END IF 1965 CDOTC = CTEMP 1966 RETURN 1967 END 1968 !> \brief \b CDOTU 1969 ! 1970 ! =========== DOCUMENTATION =========== 1971 ! 1972 ! Online html documentation available at 1973 ! http://www.netlib.org/lapack/explore-html/ 1974 ! 1975 ! Definition: 1976 ! =========== 1977 ! 1978 ! COMPLEX FUNCTION CDOTU(N,CX,INCX,CY,INCY) 1979 ! 1980 ! .. Scalar Arguments .. 1981 ! INTEGER INCX,INCY,N 1982 ! .. 1983 ! .. Array Arguments .. 1984 ! COMPLEX CX(*),CY(*) 1985 ! .. 1986 ! 1987 ! 1988 !> \par Purpose: 1989 ! ============= 1990 !> 1991 !> \verbatim 1992 !> 1993 !> CDOTU forms the dot product of two vectors. 1994 !> \endverbatim 1995 ! 1996 ! Authors: 1997 ! ======== 1998 ! 1999 !> \author Univ. of Tennessee 2000 !> \author Univ. of California Berkeley 2001 !> \author Univ. of Colorado Denver 2002 !> \author NAG Ltd. 2003 ! 2004 !> \date November 2011 2005 ! 2006 !> \ingroup complex_blas_level1 2007 ! 2008 !> \par Further Details: 2009 ! ===================== 2010 !> 2011 !> \verbatim 2012 !> 2013 !> jack dongarra, linpack, 3/11/78. 2014 !> modified 12/3/93, array(1) declarations changed to array(*) 2015 !> \endverbatim 2016 !> 2017 ! ===================================================================== 2018 COMPLEX FUNCTION CDOTU(N,CX,INCX,CY,INCY) 2019 ! 2020 ! -- Reference BLAS level1 routine (version 3.4.0) -- 2021 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 2022 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 2023 ! November 2011 2024 ! 2025 ! .. Scalar Arguments .. 2026 INTEGER INCX,INCY,N 2027 ! .. 2028 ! .. Array Arguments .. 2029 COMPLEX CX(*),CY(*) 2030 ! .. 2031 ! 2032 ! ===================================================================== 2033 ! 2034 ! .. Local Scalars .. 2035 COMPLEX CTEMP 2036 INTEGER I,IX,IY 2037 ! .. 2038 CTEMP = (0.0,0.0) 2039 CDOTU = (0.0,0.0) 2040 IF (N.LE.0) RETURN 2041 IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN 2042 ! 2043 ! code for both increments equal to 1 2044 ! 2045 DO I = 1,N 2046 CTEMP = CTEMP + CX(I)*CY(I) 2047 END DO 2048 ELSE 2049 ! 2050 ! code for unequal increments or equal increments 2051 ! not equal to 1 2052 ! 2053 IX = 1 2054 IY = 1 2055 IF (INCX.LT.0) IX = (-N+1)*INCX + 1 2056 IF (INCY.LT.0) IY = (-N+1)*INCY + 1 2057 DO I = 1,N 2058 CTEMP = CTEMP + CX(IX)*CY(IY) 2059 IX = IX + INCX 2060 IY = IY + INCY 2061 END DO 2062 END IF 2063 CDOTU = CTEMP 2064 RETURN 2065 END 2066 !> \brief \b DASUM 2067 ! 2068 ! =========== DOCUMENTATION =========== 2069 ! 2070 ! Online html documentation available at 2071 ! http://www.netlib.org/lapack/explore-html/ 2072 ! 2073 ! Definition: 2074 ! =========== 2075 ! 2076 ! DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) 2077 ! 2078 ! .. Scalar Arguments .. 2079 ! INTEGER INCX,N 2080 ! .. 2081 ! .. Array Arguments .. 2082 ! DOUBLE PRECISION DX(*) 2083 ! .. 2084 ! 2085 ! 2086 !> \par Purpose: 2087 ! ============= 2088 !> 2089 !> \verbatim 2090 !> 2091 !> DASUM takes the sum of the absolute values. 2092 !> \endverbatim 2093 ! 2094 ! Authors: 2095 ! ======== 2096 ! 2097 !> \author Univ. of Tennessee 2098 !> \author Univ. of California Berkeley 2099 !> \author Univ. of Colorado Denver 2100 !> \author NAG Ltd. 2101 ! 2102 !> \date November 2011 2103 ! 2104 !> \ingroup double_blas_level1 2105 ! 2106 !> \par Further Details: 2107 ! ===================== 2108 !> 2109 !> \verbatim 2110 !> 2111 !> jack dongarra, linpack, 3/11/78. 2112 !> modified 3/93 to return if incx .le. 0. 2113 !> modified 12/3/93, array(1) declarations changed to array(*) 2114 !> \endverbatim 2115 !> 2116 ! ===================================================================== 2117 DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) 2118 ! 2119 ! -- Reference BLAS level1 routine (version 3.4.0) -- 2120 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 2121 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 2122 ! November 2011 2123 ! 2124 ! .. Scalar Arguments .. 2125 INTEGER INCX,N 2126 ! .. 2127 ! .. Array Arguments .. 2128 DOUBLE PRECISION DX(*) 2129 ! .. 2130 ! 2131 ! ===================================================================== 2132 ! 2133 ! .. Local Scalars .. 2134 DOUBLE PRECISION DTEMP 2135 INTEGER I,M,MP1,NINCX 2136 ! .. 2137 ! .. Intrinsic Functions .. 2138 INTRINSIC DABS,MOD 2139 ! .. 2140 DASUM = 0.0d0 2141 DTEMP = 0.0d0 2142 IF (N.LE.0 .OR. INCX.LE.0) RETURN 2143 IF (INCX.EQ.1) THEN 2144 ! code for increment equal to 1 2145 ! 2146 ! 2147 ! clean-up loop 2148 ! 2149 M = MOD(N,6) 2150 IF (M.NE.0) THEN 2151 DO I = 1,M 2152 DTEMP = DTEMP + DABS(DX(I)) 2153 END DO 2154 IF (N.LT.6) THEN 2155 DASUM = DTEMP 2156 RETURN 2157 END IF 2158 END IF 2159 MP1 = M + 1 2160 DO I = MP1,N,6 2161 DTEMP = DTEMP + DABS(DX(I)) + DABS(DX(I+1)) + & 2162 DABS(DX(I+2)) + DABS(DX(I+3)) + & 2163 DABS(DX(I+4)) + DABS(DX(I+5)) 2164 END DO 2165 ELSE 2166 ! 2167 ! code for increment not equal to 1 2168 ! 2169 NINCX = N*INCX 2170 DO I = 1,NINCX,INCX 2171 DTEMP = DTEMP + DABS(DX(I)) 2172 END DO 2173 END IF 2174 DASUM = DTEMP 2175 RETURN 2176 END 2177 !> \brief \b DDOT 2178 ! 2179 ! =========== DOCUMENTATION =========== 2180 ! 2181 ! Online html documentation available at 2182 ! http://www.netlib.org/lapack/explore-html/ 2183 ! 2184 ! Definition: 2185 ! =========== 2186 ! 2187 ! DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) 2188 ! 2189 ! .. Scalar Arguments .. 2190 ! INTEGER INCX,INCY,N 2191 ! .. 2192 ! .. Array Arguments .. 2193 ! DOUBLE PRECISION DX(*),DY(*) 2194 ! .. 2195 ! 2196 ! 2197 !> \par Purpose: 2198 ! ============= 2199 !> 2200 !> \verbatim 2201 !> 2202 !> DDOT forms the dot product of two vectors. 2203 !> uses unrolled loops for increments equal to one. 2204 !> \endverbatim 2205 ! 2206 ! Authors: 2207 ! ======== 2208 ! 2209 !> \author Univ. of Tennessee 2210 !> \author Univ. of California Berkeley 2211 !> \author Univ. of Colorado Denver 2212 !> \author NAG Ltd. 2213 ! 2214 !> \date November 2011 2215 ! 2216 !> \ingroup double_blas_level1 2217 ! 2218 !> \par Further Details: 2219 ! ===================== 2220 !> 2221 !> \verbatim 2222 !> 2223 !> jack dongarra, linpack, 3/11/78. 2224 !> modified 12/3/93, array(1) declarations changed to array(*) 2225 !> \endverbatim 2226 !> 2227 ! ===================================================================== 2228 DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) 2229 ! 2230 ! -- Reference BLAS level1 routine (version 3.4.0) -- 2231 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 2232 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 2233 ! November 2011 2234 ! 2235 ! .. Scalar Arguments .. 2236 INTEGER INCX,INCY,N 2237 ! .. 2238 ! .. Array Arguments .. 2239 DOUBLE PRECISION DX(*),DY(*) 2240 ! .. 2241 ! 2242 ! ===================================================================== 2243 ! 2244 ! .. Local Scalars .. 2245 DOUBLE PRECISION DTEMP 2246 INTEGER I,IX,IY,M,MP1 2247 ! .. 2248 ! .. Intrinsic Functions .. 2249 INTRINSIC MOD 2250 ! .. 2251 DDOT = 0.0d0 2252 DTEMP = 0.0d0 2253 IF (N.LE.0) RETURN 2254 IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN 2255 ! 2256 ! code for both increments equal to 1 2257 ! 2258 ! 2259 ! clean-up loop 2260 ! 2261 M = MOD(N,5) 2262 IF (M.NE.0) THEN 2263 DO I = 1,M 2264 DTEMP = DTEMP + DX(I)*DY(I) 2265 END DO 2266 IF (N.LT.5) THEN 2267 DDOT=DTEMP 2268 RETURN 2269 END IF 2270 END IF 2271 MP1 = M + 1 2272 DO I = MP1,N,5 2273 DTEMP = DTEMP + DX(I)*DY(I) + DX(I+1)*DY(I+1) + & 2274 DX(I+2)*DY(I+2) + DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4) 2275 END DO 2276 ELSE 2277 ! 2278 ! code for unequal increments or equal increments 2279 ! not equal to 1 2280 ! 2281 IX = 1 2282 IY = 1 2283 IF (INCX.LT.0) IX = (-N+1)*INCX + 1 2284 IF (INCY.LT.0) IY = (-N+1)*INCY + 1 2285 DO I = 1,N 2286 DTEMP = DTEMP + DX(IX)*DY(IY) 2287 IX = IX + INCX 2288 IY = IY + INCY 2289 END DO 2290 END IF 2291 DDOT = DTEMP 2292 RETURN 2293 END 2294 !> \brief \b DNRM2 2295 ! 2296 ! =========== DOCUMENTATION =========== 2297 ! 2298 ! Online html documentation available at 2299 ! http://www.netlib.org/lapack/explore-html/ 2300 ! 2301 ! Definition: 2302 ! =========== 2303 ! 2304 ! DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX) 2305 ! 2306 ! .. Scalar Arguments .. 2307 ! INTEGER INCX,N 2308 ! .. 2309 ! .. Array Arguments .. 2310 ! DOUBLE PRECISION X(*) 2311 ! .. 2312 ! 2313 ! 2314 !> \par Purpose: 2315 ! ============= 2316 !> 2317 !> \verbatim 2318 !> 2319 !> DNRM2 returns the euclidean norm of a vector via the function 2320 !> name, so that 2321 !> 2322 !> DNRM2 := sqrt( x'*x ) 2323 !> \endverbatim 2324 ! 2325 ! Authors: 2326 ! ======== 2327 ! 2328 !> \author Univ. of Tennessee 2329 !> \author Univ. of California Berkeley 2330 !> \author Univ. of Colorado Denver 2331 !> \author NAG Ltd. 2332 ! 2333 !> \date November 2011 2334 ! 2335 !> \ingroup double_blas_level1 2336 ! 2337 !> \par Further Details: 2338 ! ===================== 2339 !> 2340 !> \verbatim 2341 !> 2342 !> -- This version written on 25-October-1982. 2343 !> Modified on 14-October-1993 to inline the call to DLASSQ. 2344 !> Sven Hammarling, Nag Ltd. 2345 !> \endverbatim 2346 !> 2347 ! ===================================================================== 2348 DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX) 2349 ! 2350 ! -- Reference BLAS level1 routine (version 3.4.0) -- 2351 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 2352 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 2353 ! November 2011 2354 ! 2355 ! .. Scalar Arguments .. 2356 INTEGER INCX,N 2357 ! .. 2358 ! .. Array Arguments .. 2359 DOUBLE PRECISION X(*) 2360 ! .. 2361 ! 2362 ! ===================================================================== 2363 ! 2364 ! .. Parameters .. 2365 DOUBLE PRECISION ONE,ZERO 2366 PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) 2367 ! .. 2368 ! .. Local Scalars .. 2369 DOUBLE PRECISION ABSXI,NORM,SCALE,SSQ 2370 INTEGER IX 2371 ! .. 2372 ! .. Intrinsic Functions .. 2373 INTRINSIC ABS,SQRT 2374 ! .. 2375 IF (N.LT.1 .OR. INCX.LT.1) THEN 2376 NORM = ZERO 2377 ELSE IF (N.EQ.1) THEN 2378 NORM = ABS(X(1)) 2379 ELSE 2380 SCALE = ZERO 2381 SSQ = ONE 2382 ! The following loop is equivalent to this call to the LAPACK 2383 ! auxiliary routine: 2384 ! CALL DLASSQ( N, X, INCX, SCALE, SSQ ) 2385 ! 2386 DO 10 IX = 1,1 + (N-1)*INCX,INCX 2387 IF (X(IX).NE.ZERO) THEN 2388 ABSXI = ABS(X(IX)) 2389 IF (SCALE.LT.ABSXI) THEN 2390 SSQ = ONE + SSQ* (SCALE/ABSXI)**2 2391 SCALE = ABSXI 2392 ELSE 2393 SSQ = SSQ + (ABSXI/SCALE)**2 2394 END IF 2395 END IF 2396 10 CONTINUE 2397 NORM = SCALE*SQRT(SSQ) 2398 END IF 2399 ! 2400 DNRM2 = NORM 2401 RETURN 2402 ! 2403 ! End of DNRM2. 2404 ! 2405 END 2406 !> \brief \b ICAMAX 2407 ! 2408 ! =========== DOCUMENTATION =========== 2409 ! 2410 ! Online html documentation available at 2411 ! http://www.netlib.org/lapack/explore-html/ 2412 ! 2413 ! Definition: 2414 ! =========== 2415 ! 2416 ! INTEGER FUNCTION ICAMAX(N,CX,INCX) 2417 ! 2418 ! .. Scalar Arguments .. 2419 ! INTEGER INCX,N 2420 ! .. 2421 ! .. Array Arguments .. 2422 ! COMPLEX CX(*) 2423 ! .. 2424 ! 2425 ! 2426 !> \par Purpose: 2427 ! ============= 2428 !> 2429 !> \verbatim 2430 !> 2431 !> ICAMAX finds the index of element having max. absolute value. 2432 !> \endverbatim 2433 ! 2434 ! Authors: 2435 ! ======== 2436 ! 2437 !> \author Univ. of Tennessee 2438 !> \author Univ. of California Berkeley 2439 !> \author Univ. of Colorado Denver 2440 !> \author NAG Ltd. 2441 ! 2442 !> \date November 2011 2443 ! 2444 !> \ingroup aux_blas 2445 ! 2446 !> \par Further Details: 2447 ! ===================== 2448 !> 2449 !> \verbatim 2450 !> 2451 !> jack dongarra, linpack, 3/11/78. 2452 !> modified 3/93 to return if incx .le. 0. 2453 !> modified 12/3/93, array(1) declarations changed to array(*) 2454 !> \endverbatim 2455 !> 2456 ! ===================================================================== 2457 INTEGER FUNCTION ICAMAX(N,CX,INCX) 2458 ! 2459 ! -- Reference BLAS level1 routine (version 3.4.0) -- 2460 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 2461 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 2462 ! November 2011 2463 ! 2464 ! .. Scalar Arguments .. 2465 INTEGER INCX,N 2466 ! .. 2467 ! .. Array Arguments .. 2468 COMPLEX CX(*) 2469 ! .. 2470 ! 2471 ! ===================================================================== 2472 ! 2473 ! .. Local Scalars .. 2474 REAL SMAX 2475 INTEGER I,IX 2476 ! .. 2477 ! .. External Functions .. 2478 REAL SCABS1 2479 EXTERNAL SCABS1 2480 ! .. 2481 ICAMAX = 0 2482 IF (N.LT.1 .OR. INCX.LE.0) RETURN 2483 ICAMAX = 1 2484 IF (N.EQ.1) RETURN 2485 IF (INCX.EQ.1) THEN 2486 ! 2487 ! code for increment equal to 1 2488 ! 2489 SMAX = SCABS1(CX(1)) 2490 DO I = 2,N 2491 IF (SCABS1(CX(I)).GT.SMAX) THEN 2492 ICAMAX = I 2493 SMAX = SCABS1(CX(I)) 2494 END IF 2495 END DO 2496 ELSE 2497 ! 2498 ! code for increment not equal to 1 2499 ! 2500 IX = 1 2501 SMAX = SCABS1(CX(1)) 2502 IX = IX + INCX 2503 DO I = 2,N 2504 IF (SCABS1(CX(IX)).GT.SMAX) THEN 2505 ICAMAX = I 2506 SMAX = SCABS1(CX(IX)) 2507 END IF 2508 IX = IX + INCX 2509 END DO 2510 END IF 2511 RETURN 2512 END 2513 !> \brief \b IDAMAX 2514 ! 2515 ! =========== DOCUMENTATION =========== 2516 ! 2517 ! Online html documentation available at 2518 ! http://www.netlib.org/lapack/explore-html/ 2519 ! 2520 ! Definition: 2521 ! =========== 2522 ! 2523 ! INTEGER FUNCTION IDAMAX(N,DX,INCX) 2524 ! 2525 ! .. Scalar Arguments .. 2526 ! INTEGER INCX,N 2527 ! .. 2528 ! .. Array Arguments .. 2529 ! DOUBLE PRECISION DX(*) 2530 ! .. 2531 ! 2532 ! 2533 !> \par Purpose: 2534 ! ============= 2535 !> 2536 !> \verbatim 2537 !> 2538 !> IDAMAX finds the index of element having max. absolute value. 2539 !> \endverbatim 2540 ! 2541 ! Authors: 2542 ! ======== 2543 ! 2544 !> \author Univ. of Tennessee 2545 !> \author Univ. of California Berkeley 2546 !> \author Univ. of Colorado Denver 2547 !> \author NAG Ltd. 2548 ! 2549 !> \date November 2011 2550 ! 2551 !> \ingroup aux_blas 2552 ! 2553 !> \par Further Details: 2554 ! ===================== 2555 !> 2556 !> \verbatim 2557 !> 2558 !> jack dongarra, linpack, 3/11/78. 2559 !> modified 3/93 to return if incx .le. 0. 2560 !> modified 12/3/93, array(1) declarations changed to array(*) 2561 !> \endverbatim 2562 !> 2563 ! ===================================================================== 2564 INTEGER FUNCTION IDAMAX(N,DX,INCX) 2565 ! 2566 ! -- Reference BLAS level1 routine (version 3.4.0) -- 2567 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 2568 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 2569 ! November 2011 2570 ! 2571 ! .. Scalar Arguments .. 2572 INTEGER INCX,N 2573 ! .. 2574 ! .. Array Arguments .. 2575 DOUBLE PRECISION DX(*) 2576 ! .. 2577 ! 2578 ! ===================================================================== 2579 ! 2580 ! .. Local Scalars .. 2581 DOUBLE PRECISION DMAX 2582 INTEGER I,IX 2583 ! .. 2584 ! .. Intrinsic Functions .. 2585 INTRINSIC DABS 2586 ! .. 2587 IDAMAX = 0 2588 IF (N.LT.1 .OR. INCX.LE.0) RETURN 2589 IDAMAX = 1 2590 IF (N.EQ.1) RETURN 2591 IF (INCX.EQ.1) THEN 2592 ! 2593 ! code for increment equal to 1 2594 ! 2595 DMAX = DABS(DX(1)) 2596 DO I = 2,N 2597 IF (DABS(DX(I)).GT.DMAX) THEN 2598 IDAMAX = I 2599 DMAX = DABS(DX(I)) 2600 END IF 2601 END DO 2602 ELSE 2603 ! 2604 ! code for increment not equal to 1 2605 ! 2606 IX = 1 2607 DMAX = DABS(DX(1)) 2608 IX = IX + INCX 2609 DO I = 2,N 2610 IF (DABS(DX(IX)).GT.DMAX) THEN 2611 IDAMAX = I 2612 DMAX = DABS(DX(IX)) 2613 END IF 2614 IX = IX + INCX 2615 END DO 2616 END IF 2617 RETURN 2618 END 2619 !> \brief \b ISAMAX 2620 ! 2621 ! =========== DOCUMENTATION =========== 2622 ! 2623 ! Online html documentation available at 2624 ! http://www.netlib.org/lapack/explore-html/ 2625 ! 2626 ! Definition: 2627 ! =========== 2628 ! 2629 ! INTEGER FUNCTION ISAMAX(N,SX,INCX) 2630 ! 2631 ! .. Scalar Arguments .. 2632 ! INTEGER INCX,N 2633 ! .. 2634 ! .. Array Arguments .. 2635 ! REAL SX(*) 2636 ! .. 2637 ! 2638 ! 2639 !> \par Purpose: 2640 ! ============= 2641 !> 2642 !> \verbatim 2643 !> 2644 !> ISAMAX finds the index of element having max. absolute value. 2645 !> \endverbatim 2646 ! 2647 ! Authors: 2648 ! ======== 2649 ! 2650 !> \author Univ. of Tennessee 2651 !> \author Univ. of California Berkeley 2652 !> \author Univ. of Colorado Denver 2653 !> \author NAG Ltd. 2654 ! 2655 !> \date November 2011 2656 ! 2657 !> \ingroup aux_blas 2658 ! 2659 !> \par Further Details: 2660 ! ===================== 2661 !> 2662 !> \verbatim 2663 !> 2664 !> jack dongarra, linpack, 3/11/78. 2665 !> modified 3/93 to return if incx .le. 0. 2666 !> modified 12/3/93, array(1) declarations changed to array(*) 2667 !> \endverbatim 2668 !> 2669 ! ===================================================================== 2670 INTEGER FUNCTION ISAMAX(N,SX,INCX) 2671 ! 2672 ! -- Reference BLAS level1 routine (version 3.4.0) -- 2673 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 2674 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 2675 ! November 2011 2676 ! 2677 ! .. Scalar Arguments .. 2678 INTEGER INCX,N 2679 ! .. 2680 ! .. Array Arguments .. 2681 REAL SX(*) 2682 ! .. 2683 ! 2684 ! ===================================================================== 2685 ! 2686 ! .. Local Scalars .. 2687 REAL SMAX 2688 INTEGER I,IX 2689 ! .. 2690 ! .. Intrinsic Functions .. 2691 INTRINSIC ABS 2692 ! .. 2693 ISAMAX = 0 2694 IF (N.LT.1 .OR. INCX.LE.0) RETURN 2695 ISAMAX = 1 2696 IF (N.EQ.1) RETURN 2697 IF (INCX.EQ.1) THEN 2698 ! 2699 ! code for increment equal to 1 2700 ! 2701 SMAX = ABS(SX(1)) 2702 DO I = 2,N 2703 IF (ABS(SX(I)).GT.SMAX) THEN 2704 ISAMAX = I 2705 SMAX = ABS(SX(I)) 2706 END IF 2707 END DO 2708 ELSE 2709 ! 2710 ! code for increment not equal to 1 2711 ! 2712 IX = 1 2713 SMAX = ABS(SX(1)) 2714 IX = IX + INCX 2715 DO I = 2,N 2716 IF (ABS(SX(IX)).GT.SMAX) THEN 2717 ISAMAX = I 2718 SMAX = ABS(SX(IX)) 2719 END IF 2720 IX = IX + INCX 2721 END DO 2722 END IF 2723 RETURN 2724 END 2725 !> \brief \b SASUM 2726 ! 2727 ! =========== DOCUMENTATION =========== 2728 ! 2729 ! Online html documentation available at 2730 ! http://www.netlib.org/lapack/explore-html/ 2731 ! 2732 ! Definition: 2733 ! =========== 2734 ! 2735 ! REAL FUNCTION SASUM(N,SX,INCX) 2736 ! 2737 ! .. Scalar Arguments .. 2738 ! INTEGER INCX,N 2739 ! .. 2740 ! .. Array Arguments .. 2741 ! REAL SX(*) 2742 ! .. 2743 ! 2744 ! 2745 !> \par Purpose: 2746 ! ============= 2747 !> 2748 !> \verbatim 2749 !> 2750 !> SASUM takes the sum of the absolute values. 2751 !> uses unrolled loops for increment equal to one. 2752 !> \endverbatim 2753 ! 2754 ! Authors: 2755 ! ======== 2756 ! 2757 !> \author Univ. of Tennessee 2758 !> \author Univ. of California Berkeley 2759 !> \author Univ. of Colorado Denver 2760 !> \author NAG Ltd. 2761 ! 2762 !> \date November 2011 2763 ! 2764 !> \ingroup single_blas_level1 2765 ! 2766 !> \par Further Details: 2767 ! ===================== 2768 !> 2769 !> \verbatim 2770 !> 2771 !> jack dongarra, linpack, 3/11/78. 2772 !> modified 3/93 to return if incx .le. 0. 2773 !> modified 12/3/93, array(1) declarations changed to array(*) 2774 !> \endverbatim 2775 !> 2776 ! ===================================================================== 2777 REAL FUNCTION SASUM(N,SX,INCX) 2778 ! 2779 ! -- Reference BLAS level1 routine (version 3.4.0) -- 2780 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 2781 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 2782 ! November 2011 2783 ! 2784 ! .. Scalar Arguments .. 2785 INTEGER INCX,N 2786 ! .. 2787 ! .. Array Arguments .. 2788 REAL SX(*) 2789 ! .. 2790 ! 2791 ! ===================================================================== 2792 ! 2793 ! .. Local Scalars .. 2794 REAL STEMP 2795 INTEGER I,M,MP1,NINCX 2796 ! .. 2797 ! .. Intrinsic Functions .. 2798 INTRINSIC ABS,MOD 2799 ! .. 2800 SASUM = 0.0e0 2801 STEMP = 0.0e0 2802 IF (N.LE.0 .OR. INCX.LE.0) RETURN 2803 IF (INCX.EQ.1) THEN 2804 ! code for increment equal to 1 2805 ! 2806 ! 2807 ! clean-up loop 2808 ! 2809 M = MOD(N,6) 2810 IF (M.NE.0) THEN 2811 DO I = 1,M 2812 STEMP = STEMP + ABS(SX(I)) 2813 END DO 2814 IF (N.LT.6) THEN 2815 SASUM = STEMP 2816 RETURN 2817 END IF 2818 END IF 2819 MP1 = M + 1 2820 DO I = MP1,N,6 2821 STEMP = STEMP + ABS(SX(I)) + ABS(SX(I+1)) + & 2822 ABS(SX(I+2)) + ABS(SX(I+3)) + & 2823 ABS(SX(I+4)) + ABS(SX(I+5)) 2824 END DO 2825 ELSE 2826 ! 2827 ! code for increment not equal to 1 2828 ! 2829 NINCX = N*INCX 2830 DO I = 1,NINCX,INCX 2831 STEMP = STEMP + ABS(SX(I)) 2832 END DO 2833 END IF 2834 SASUM = STEMP 2835 RETURN 2836 END 2837 !> \brief \b SCASUM 2838 ! 2839 ! =========== DOCUMENTATION =========== 2840 ! 2841 ! Online html documentation available at 2842 ! http://www.netlib.org/lapack/explore-html/ 2843 ! 2844 ! Definition: 2845 ! =========== 2846 ! 2847 ! REAL FUNCTION SCASUM(N,CX,INCX) 2848 ! 2849 ! .. Scalar Arguments .. 2850 ! INTEGER INCX,N 2851 ! .. 2852 ! .. Array Arguments .. 2853 ! COMPLEX CX(*) 2854 ! .. 2855 ! 2856 ! 2857 !> \par Purpose: 2858 ! ============= 2859 !> 2860 !> \verbatim 2861 !> 2862 !> SCASUM takes the sum of the absolute values of a complex vector and 2863 !> returns a single precision result. 2864 !> \endverbatim 2865 ! 2866 ! Authors: 2867 ! ======== 2868 ! 2869 !> \author Univ. of Tennessee 2870 !> \author Univ. of California Berkeley 2871 !> \author Univ. of Colorado Denver 2872 !> \author NAG Ltd. 2873 ! 2874 !> \date November 2011 2875 ! 2876 !> \ingroup single_blas_level1 2877 ! 2878 !> \par Further Details: 2879 ! ===================== 2880 !> 2881 !> \verbatim 2882 !> 2883 !> jack dongarra, linpack, 3/11/78. 2884 !> modified 3/93 to return if incx .le. 0. 2885 !> modified 12/3/93, array(1) declarations changed to array(*) 2886 !> \endverbatim 2887 !> 2888 ! ===================================================================== 2889 REAL FUNCTION SCASUM(N,CX,INCX) 2890 ! 2891 ! -- Reference BLAS level1 routine (version 3.4.0) -- 2892 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 2893 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 2894 ! November 2011 2895 ! 2896 ! .. Scalar Arguments .. 2897 INTEGER INCX,N 2898 ! .. 2899 ! .. Array Arguments .. 2900 COMPLEX CX(*) 2901 ! .. 2902 ! 2903 ! ===================================================================== 2904 ! 2905 ! .. Local Scalars .. 2906 REAL STEMP 2907 INTEGER I,NINCX 2908 ! .. 2909 ! .. Intrinsic Functions .. 2910 INTRINSIC ABS,AIMAG,REAL 2911 ! .. 2912 SCASUM = 0.0e0 2913 STEMP = 0.0e0 2914 IF (N.LE.0 .OR. INCX.LE.0) RETURN 2915 IF (INCX.EQ.1) THEN 2916 ! 2917 ! code for increment equal to 1 2918 ! 2919 DO I = 1,N 2920 STEMP = STEMP + ABS(REAL(CX(I))) + ABS(AIMAG(CX(I))) 2921 END DO 2922 ELSE 2923 ! 2924 ! code for increment not equal to 1 2925 ! 2926 NINCX = N*INCX 2927 DO I = 1,NINCX,INCX 2928 STEMP = STEMP + ABS(REAL(CX(I))) + ABS(AIMAG(CX(I))) 2929 END DO 2930 END IF 2931 SCASUM = STEMP 2932 RETURN 2933 END 2934 !> \brief \b SCNRM2 2935 ! 2936 ! =========== DOCUMENTATION =========== 2937 ! 2938 ! Online html documentation available at 2939 ! http://www.netlib.org/lapack/explore-html/ 2940 ! 2941 ! Definition: 2942 ! =========== 2943 ! 2944 ! REAL FUNCTION SCNRM2(N,X,INCX) 2945 ! 2946 ! .. Scalar Arguments .. 2947 ! INTEGER INCX,N 2948 ! .. 2949 ! .. Array Arguments .. 2950 ! COMPLEX X(*) 2951 ! .. 2952 ! 2953 ! 2954 !> \par Purpose: 2955 ! ============= 2956 !> 2957 !> \verbatim 2958 !> 2959 !> SCNRM2 returns the euclidean norm of a vector via the function 2960 !> name, so that 2961 !> 2962 !> SCNRM2 := sqrt( x**H*x ) 2963 !> \endverbatim 2964 ! 2965 ! Authors: 2966 ! ======== 2967 ! 2968 !> \author Univ. of Tennessee 2969 !> \author Univ. of California Berkeley 2970 !> \author Univ. of Colorado Denver 2971 !> \author NAG Ltd. 2972 ! 2973 !> \date November 2011 2974 ! 2975 !> \ingroup single_blas_level1 2976 ! 2977 !> \par Further Details: 2978 ! ===================== 2979 !> 2980 !> \verbatim 2981 !> 2982 !> -- This version written on 25-October-1982. 2983 !> Modified on 14-October-1993 to inline the call to CLASSQ. 2984 !> Sven Hammarling, Nag Ltd. 2985 !> \endverbatim 2986 !> 2987 ! ===================================================================== 2988 REAL FUNCTION SCNRM2(N,X,INCX) 2989 ! 2990 ! -- Reference BLAS level1 routine (version 3.4.0) -- 2991 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 2992 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 2993 ! November 2011 2994 ! 2995 ! .. Scalar Arguments .. 2996 INTEGER INCX,N 2997 ! .. 2998 ! .. Array Arguments .. 2999 COMPLEX X(*) 3000 ! .. 3001 ! 3002 ! ===================================================================== 3003 ! 3004 ! .. Parameters .. 3005 REAL ONE,ZERO 3006 PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) 3007 ! .. 3008 ! .. Local Scalars .. 3009 REAL NORM,SCALE,SSQ,TEMP 3010 INTEGER IX 3011 ! .. 3012 ! .. Intrinsic Functions .. 3013 INTRINSIC ABS,AIMAG,REAL,SQRT 3014 ! .. 3015 IF (N.LT.1 .OR. INCX.LT.1) THEN 3016 NORM = ZERO 3017 ELSE 3018 SCALE = ZERO 3019 SSQ = ONE 3020 ! The following loop is equivalent to this call to the LAPACK 3021 ! auxiliary routine: 3022 ! CALL CLASSQ( N, X, INCX, SCALE, SSQ ) 3023 ! 3024 DO 10 IX = 1,1 + (N-1)*INCX,INCX 3025 IF (REAL(X(IX)).NE.ZERO) THEN 3026 TEMP = ABS(REAL(X(IX))) 3027 IF (SCALE.LT.TEMP) THEN 3028 SSQ = ONE + SSQ* (SCALE/TEMP)**2 3029 SCALE = TEMP 3030 ELSE 3031 SSQ = SSQ + (TEMP/SCALE)**2 3032 END IF 3033 END IF 3034 IF (AIMAG(X(IX)).NE.ZERO) THEN 3035 TEMP = ABS(AIMAG(X(IX))) 3036 IF (SCALE.LT.TEMP) THEN 3037 SSQ = ONE + SSQ* (SCALE/TEMP)**2 3038 SCALE = TEMP 3039 ELSE 3040 SSQ = SSQ + (TEMP/SCALE)**2 3041 END IF 3042 END IF 3043 10 CONTINUE 3044 NORM = SCALE*SQRT(SSQ) 3045 END IF 3046 ! 3047 SCNRM2 = NORM 3048 RETURN 3049 ! 3050 ! End of SCNRM2. 3051 ! 3052 END 3053 !> \brief \b SDSDOT 3054 ! 3055 ! =========== DOCUMENTATION =========== 3056 ! 3057 ! Online html documentation available at 3058 ! http://www.netlib.org/lapack/explore-html/ 3059 ! 3060 ! Definition: 3061 ! =========== 3062 ! 3063 ! REAL FUNCTION SDSDOT(N,SB,SX,INCX,SY,INCY) 3064 ! 3065 ! .. Scalar Arguments .. 3066 ! REAL SB 3067 ! INTEGER INCX,INCY,N 3068 ! .. 3069 ! .. Array Arguments .. 3070 ! REAL SX(*),SY(*) 3071 ! .. 3072 ! 3073 ! PURPOSE 3074 ! ======= 3075 ! 3076 ! Compute the inner product of two vectors with extended 3077 ! precision accumulation. 3078 ! 3079 ! Returns S.P. result with dot product accumulated in D.P. 3080 ! SDSDOT = SB + sum for I = 0 to N-1 of SX(LX+I*INCX)*SY(LY+I*INCY), 3081 ! where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is 3082 ! defined in a similar way using INCY. 3083 ! 3084 ! AUTHOR 3085 ! ====== 3086 ! Lawson, C. L., (JPL), Hanson, R. J., (SNLA), 3087 ! Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL) 3088 ! 3089 ! ARGUMENTS 3090 ! ========= 3091 ! 3092 ! N (input) INTEGER 3093 ! number of elements in input vector(s) 3094 ! 3095 ! SB (input) REAL 3096 ! single precision scalar to be added to inner product 3097 ! 3098 ! SX (input) REAL array, dimension (N) 3099 ! single precision vector with N elements 3100 ! 3101 ! INCX (input) INTEGER 3102 ! storage spacing between elements of SX 3103 ! 3104 ! SY (input) REAL array, dimension (N) 3105 ! single precision vector with N elements 3106 ! 3107 ! INCY (input) INTEGER 3108 ! storage spacing between elements of SY 3109 ! 3110 ! SDSDOT (output) REAL 3111 ! single precision dot product (SB if N .LE. 0) 3112 ! 3113 ! Further Details 3114 ! =============== 3115 ! 3116 ! REFERENCES 3117 ! 3118 ! C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. 3119 ! Krogh, Basic linear algebra subprograms for Fortran 3120 ! usage, Algorithm No. 539, Transactions on Mathematical 3121 ! Software 5, 3 (September 1979), pp. 308-323. 3122 ! 3123 ! REVISION HISTORY (YYMMDD) 3124 ! 3125 ! 791001 DATE WRITTEN 3126 ! 890531 Changed all specific intrinsics to generic. (WRB) 3127 ! 890831 Modified array declarations. (WRB) 3128 ! 890831 REVISION DATE from Version 3.2 3129 ! 891214 Prologue converted to Version 4.0 format. (BAB) 3130 ! 920310 Corrected definition of LX in DESCRIPTION. (WRB) 3131 ! 920501 Reformatted the REFERENCES section. (WRB) 3132 ! 070118 Reformat to LAPACK coding style 3133 ! 3134 ! ===================================================================== 3135 ! 3136 ! .. Local Scalars .. 3137 ! DOUBLE PRECISION DSDOT 3138 ! INTEGER I,KX,KY,NS 3139 ! .. 3140 ! .. Intrinsic Functions .. 3141 ! INTRINSIC DBLE 3142 ! .. 3143 ! DSDOT = SB 3144 ! IF (N.LE.0) THEN 3145 ! SDSDOT = DSDOT 3146 ! RETURN 3147 ! END IF 3148 ! IF (INCX.EQ.INCY .AND. INCX.GT.0) THEN 3149 ! 3150 ! Code for equal and positive increments. 3151 ! 3152 ! NS = N*INCX 3153 ! DO I = 1,NS,INCX 3154 ! DSDOT = DSDOT + DBLE(SX(I))*DBLE(SY(I)) 3155 ! END DO 3156 ! ELSE 3157 ! 3158 ! Code for unequal or nonpositive increments. 3159 ! 3160 ! KX = 1 3161 ! KY = 1 3162 ! IF (INCX.LT.0) KX = 1 + (1-N)*INCX 3163 ! IF (INCY.LT.0) KY = 1 + (1-N)*INCY 3164 ! DO I = 1,N 3165 ! DSDOT = DSDOT + DBLE(SX(KX))*DBLE(SY(KY)) 3166 ! KX = KX + INCX 3167 ! KY = KY + INCY 3168 ! END DO 3169 ! END IF 3170 ! SDSDOT = DSDOT 3171 ! RETURN 3172 ! END 3173 ! 3174 !> \par Purpose: 3175 ! ============= 3176 !> 3177 !> \verbatim 3178 !> \endverbatim 3179 ! 3180 ! Authors: 3181 ! ======== 3182 ! 3183 !> \author Univ. of Tennessee 3184 !> \author Univ. of California Berkeley 3185 !> \author Univ. of Colorado Denver 3186 !> \author NAG Ltd. 3187 ! 3188 !> \date November 2011 3189 ! 3190 !> \ingroup single_blas_level1 3191 ! 3192 ! ===================================================================== 3193 REAL FUNCTION SDSDOT(N,SB,SX,INCX,SY,INCY) 3194 ! 3195 ! -- Reference BLAS level1 routine (version 3.4.0) -- 3196 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 3197 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 3198 ! November 2011 3199 ! 3200 ! .. Scalar Arguments .. 3201 REAL SB 3202 INTEGER INCX,INCY,N 3203 ! .. 3204 ! .. Array Arguments .. 3205 REAL SX(*),SY(*) 3206 ! .. 3207 ! 3208 ! PURPOSE 3209 ! ======= 3210 ! 3211 ! Compute the inner product of two vectors with extended 3212 ! precision accumulation. 3213 ! 3214 ! Returns S.P. result with dot product accumulated in D.P. 3215 ! SDSDOT = SB + sum for I = 0 to N-1 of SX(LX+I*INCX)*SY(LY+I*INCY), 3216 ! where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is 3217 ! defined in a similar way using INCY. 3218 ! 3219 ! AUTHOR 3220 ! ====== 3221 ! Lawson, C. L., (JPL), Hanson, R. J., (SNLA), 3222 ! Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL) 3223 ! 3224 ! ARGUMENTS 3225 ! ========= 3226 ! 3227 ! N (input) INTEGER 3228 ! number of elements in input vector(s) 3229 ! 3230 ! SB (input) REAL 3231 ! single precision scalar to be added to inner product 3232 ! 3233 ! SX (input) REAL array, dimension (N) 3234 ! single precision vector with N elements 3235 ! 3236 ! INCX (input) INTEGER 3237 ! storage spacing between elements of SX 3238 ! 3239 ! SY (input) REAL array, dimension (N) 3240 ! single precision vector with N elements 3241 ! 3242 ! INCY (input) INTEGER 3243 ! storage spacing between elements of SY 3244 ! 3245 ! SDSDOT (output) REAL 3246 ! single precision dot product (SB if N .LE. 0) 3247 ! 3248 ! Further Details 3249 ! =============== 3250 ! 3251 ! REFERENCES 3252 ! 3253 ! C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. 3254 ! Krogh, Basic linear algebra subprograms for Fortran 3255 ! usage, Algorithm No. 539, Transactions on Mathematical 3256 ! Software 5, 3 (September 1979), pp. 308-323. 3257 ! 3258 ! REVISION HISTORY (YYMMDD) 3259 ! 3260 ! 791001 DATE WRITTEN 3261 ! 890531 Changed all specific intrinsics to generic. (WRB) 3262 ! 890831 Modified array declarations. (WRB) 3263 ! 890831 REVISION DATE from Version 3.2 3264 ! 891214 Prologue converted to Version 4.0 format. (BAB) 3265 ! 920310 Corrected definition of LX in DESCRIPTION. (WRB) 3266 ! 920501 Reformatted the REFERENCES section. (WRB) 3267 ! 070118 Reformat to LAPACK coding style 3268 ! 3269 ! ===================================================================== 3270 ! 3271 ! .. Local Scalars .. 3272 DOUBLE PRECISION DSDOT 3273 INTEGER I,KX,KY,NS 3274 ! .. 3275 ! .. Intrinsic Functions .. 3276 INTRINSIC DBLE 3277 ! .. 3278 DSDOT = SB 3279 IF (N.LE.0) THEN 3280 SDSDOT = DSDOT 3281 RETURN 3282 END IF 3283 IF (INCX.EQ.INCY .AND. INCX.GT.0) THEN 3284 ! 3285 ! Code for equal and positive increments. 3286 ! 3287 NS = N*INCX 3288 DO I = 1,NS,INCX 3289 DSDOT = DSDOT + DBLE(SX(I))*DBLE(SY(I)) 3290 END DO 3291 ELSE 3292 ! 3293 ! Code for unequal or nonpositive increments. 3294 ! 3295 KX = 1 3296 KY = 1 3297 IF (INCX.LT.0) KX = 1 + (1-N)*INCX 3298 IF (INCY.LT.0) KY = 1 + (1-N)*INCY 3299 DO I = 1,N 3300 DSDOT = DSDOT + DBLE(SX(KX))*DBLE(SY(KY)) 3301 KX = KX + INCX 3302 KY = KY + INCY 3303 END DO 3304 END IF 3305 SDSDOT = DSDOT 3306 RETURN 3307 END 3308 !> \brief \b SNRM2 3309 ! 3310 ! =========== DOCUMENTATION =========== 3311 ! 3312 ! Online html documentation available at 3313 ! http://www.netlib.org/lapack/explore-html/ 3314 ! 3315 ! Definition: 3316 ! =========== 3317 ! 3318 ! REAL FUNCTION SNRM2(N,X,INCX) 3319 ! 3320 ! .. Scalar Arguments .. 3321 ! INTEGER INCX,N 3322 ! .. 3323 ! .. Array Arguments .. 3324 ! REAL X(*) 3325 ! .. 3326 ! 3327 ! 3328 !> \par Purpose: 3329 ! ============= 3330 !> 3331 !> \verbatim 3332 !> 3333 !> SNRM2 returns the euclidean norm of a vector via the function 3334 !> name, so that 3335 !> 3336 !> SNRM2 := sqrt( x'*x ). 3337 !> \endverbatim 3338 ! 3339 ! Authors: 3340 ! ======== 3341 ! 3342 !> \author Univ. of Tennessee 3343 !> \author Univ. of California Berkeley 3344 !> \author Univ. of Colorado Denver 3345 !> \author NAG Ltd. 3346 ! 3347 !> \date November 2011 3348 ! 3349 !> \ingroup single_blas_level1 3350 ! 3351 !> \par Further Details: 3352 ! ===================== 3353 !> 3354 !> \verbatim 3355 !> 3356 !> -- This version written on 25-October-1982. 3357 !> Modified on 14-October-1993 to inline the call to SLASSQ. 3358 !> Sven Hammarling, Nag Ltd. 3359 !> \endverbatim 3360 !> 3361 ! ===================================================================== 3362 REAL FUNCTION SNRM2(N,X,INCX) 3363 ! 3364 ! -- Reference BLAS level1 routine (version 3.4.0) -- 3365 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 3366 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 3367 ! November 2011 3368 ! 3369 ! .. Scalar Arguments .. 3370 INTEGER INCX,N 3371 ! .. 3372 ! .. Array Arguments .. 3373 REAL X(*) 3374 ! .. 3375 ! 3376 ! ===================================================================== 3377 ! 3378 ! .. Parameters .. 3379 REAL ONE,ZERO 3380 PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) 3381 ! .. 3382 ! .. Local Scalars .. 3383 REAL ABSXI,NORM,SCALE,SSQ 3384 INTEGER IX 3385 ! .. 3386 ! .. Intrinsic Functions .. 3387 INTRINSIC ABS,SQRT 3388 ! .. 3389 IF (N.LT.1 .OR. INCX.LT.1) THEN 3390 NORM = ZERO 3391 ELSE IF (N.EQ.1) THEN 3392 NORM = ABS(X(1)) 3393 ELSE 3394 SCALE = ZERO 3395 SSQ = ONE 3396 ! The following loop is equivalent to this call to the LAPACK 3397 ! auxiliary routine: 3398 ! CALL SLASSQ( N, X, INCX, SCALE, SSQ ) 3399 ! 3400 DO 10 IX = 1,1 + (N-1)*INCX,INCX 3401 IF (X(IX).NE.ZERO) THEN 3402 ABSXI = ABS(X(IX)) 3403 IF (SCALE.LT.ABSXI) THEN 3404 SSQ = ONE + SSQ* (SCALE/ABSXI)**2 3405 SCALE = ABSXI 3406 ELSE 3407 SSQ = SSQ + (ABSXI/SCALE)**2 3408 END IF 3409 END IF 3410 10 CONTINUE 3411 NORM = SCALE*SQRT(SSQ) 3412 END IF 3413 ! 3414 SNRM2 = NORM 3415 RETURN 3416 ! 3417 ! End of SNRM2. 3418 ! 3419 END 3420 !> \brief \b SCABS1 3421 ! 3422 ! =========== DOCUMENTATION =========== 3423 ! 3424 ! Online html documentation available at 3425 ! http://www.netlib.org/lapack/explore-html/ 3426 ! 3427 ! Definition: 3428 ! =========== 3429 ! 3430 ! REAL FUNCTION SCABS1(Z) 3431 ! 3432 ! .. Scalar Arguments .. 3433 ! COMPLEX Z 3434 ! .. 3435 ! 3436 ! 3437 !> \par Purpose: 3438 ! ============= 3439 !> 3440 !> \verbatim 3441 !> 3442 !> SCABS1 computes absolute value of a complex number 3443 !> \endverbatim 3444 ! 3445 ! Authors: 3446 ! ======== 3447 ! 3448 !> \author Univ. of Tennessee 3449 !> \author Univ. of California Berkeley 3450 !> \author Univ. of Colorado Denver 3451 !> \author NAG Ltd. 3452 ! 3453 !> \date November 2011 3454 ! 3455 !> \ingroup single_blas_level1 3456 ! 3457 ! ===================================================================== 3458 REAL FUNCTION SCABS1(Z) 3459 ! 3460 ! -- Reference BLAS level1 routine (version 3.4.0) -- 3461 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 3462 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 3463 ! November 2011 3464 ! 3465 ! .. Scalar Arguments .. 3466 COMPLEX Z 3467 ! .. 3468 ! 3469 ! ===================================================================== 3470 ! 3471 ! .. Intrinsic Functions .. 3472 INTRINSIC ABS,AIMAG,REAL 3473 ! .. 3474 SCABS1 = ABS(REAL(Z)) + ABS(AIMAG(Z)) 3475 RETURN 3476 END 3477