Merge pull request #674 from angsch/scal

Update scaling routines to return immediately when scaling with one

Author: langou

BLAS/SRC/cscal.f

@@ -93,7 +93,11 @@ SUBROUTINE CSCAL(N,CA,CX,INCX)
 *     .. Local Scalars ..
       INTEGER I,NINCX
 *     ..
-      IF (N.LE.0 .OR. INCX.LE.0) RETURN
+*     .. Parameters ..
+      COMPLEX ONE
+      PARAMETER (ONE= (1.0E+0,0.0E+0))
+*     ..
+      IF (N.LE.0 .OR. INCX.LE.0 .OR. CA.EQ.ONE) RETURN
       IF (INCX.EQ.1) THEN
 *
 *        code for increment equal to 1

BLAS/SRC/csscal.f

@@ -93,10 +93,14 @@ SUBROUTINE CSSCAL(N,SA,CX,INCX)
 *     .. Local Scalars ..
       INTEGER I,NINCX
 *     ..
+*     .. Parameters ..
+      REAL ONE
+      PARAMETER (ONE=1.0E+0)
+*     ..
 *     .. Intrinsic Functions ..
       INTRINSIC AIMAG,CMPLX,REAL
 *     ..
-      IF (N.LE.0 .OR. INCX.LE.0) RETURN
+      IF (N.LE.0 .OR. INCX.LE.0 .OR. SA.EQ.ONE) RETURN
       IF (INCX.EQ.1) THEN
 *
 *        code for increment equal to 1

BLAS/SRC/dscal.f

@@ -93,11 +93,14 @@ SUBROUTINE DSCAL(N,DA,DX,INCX)
 *
 *     .. Local Scalars ..
       INTEGER I,M,MP1,NINCX
+*     .. Parameters ..
+      DOUBLE PRECISION ONE
+      PARAMETER (ONE=1.0D+0)
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC MOD
 *     ..
-      IF (N.LE.0 .OR. INCX.LE.0) RETURN
+      IF (N.LE.0 .OR. INCX.LE.0 .OR. DA.EQ.ONE) RETURN
       IF (INCX.EQ.1) THEN
 *
 *        code for increment equal to 1

BLAS/SRC/sscal.f

@@ -94,10 +94,14 @@ SUBROUTINE SSCAL(N,SA,SX,INCX)
 *     .. Local Scalars ..
       INTEGER I,M,MP1,NINCX
 *     ..
+*     .. Parameters ..
+      REAL ONE
+      PARAMETER (ONE=1.0E+0)
+*     ..
 *     .. Intrinsic Functions ..
       INTRINSIC MOD
 *     ..
-      IF (N.LE.0 .OR. INCX.LE.0) RETURN
+      IF (N.LE.0 .OR. INCX.LE.0 .OR. SA.EQ.ONE) RETURN
       IF (INCX.EQ.1) THEN
 *
 *        code for increment equal to 1

BLAS/SRC/zdscal.f

@@ -92,25 +92,28 @@ SUBROUTINE ZDSCAL(N,DA,ZX,INCX)
 *
 *     .. Local Scalars ..
       INTEGER I,NINCX
+*     .. Parameters ..
+      DOUBLE PRECISION ONE
+      PARAMETER (ONE=1.0D+0)
 *     ..
 *     .. Intrinsic Functions ..
-      INTRINSIC DCMPLX
+      INTRINSIC DBLE, DCMPLX, DIMAG
 *     ..
-      IF (N.LE.0 .OR. INCX.LE.0) RETURN
+      IF (N.LE.0 .OR. INCX.LE.0 .OR. DA.EQ.ONE) RETURN
       IF (INCX.EQ.1) THEN
 *
 *        code for increment equal to 1
 *
          DO I = 1,N
-            ZX(I) = DCMPLX(DA,0.0d0)*ZX(I)
+            ZX(I) = DCMPLX(DA*DBLE(ZX(I)),DA*DIMAG(ZX(I)))
          END DO
       ELSE
 *
 *        code for increment not equal to 1
 *
          NINCX = N*INCX
          DO I = 1,NINCX,INCX
-            ZX(I) = DCMPLX(DA,0.0d0)*ZX(I)
+            ZX(I) = DCMPLX(DA*DBLE(ZX(I)),DA*DIMAG(ZX(I)))
          END DO
       END IF
       RETURN

BLAS/SRC/zscal.f

@@ -93,7 +93,11 @@ SUBROUTINE ZSCAL(N,ZA,ZX,INCX)
 *     .. Local Scalars ..
       INTEGER I,NINCX
 *     ..
-      IF (N.LE.0 .OR. INCX.LE.0) RETURN
+*     .. Parameters ..
+      COMPLEX*16 ONE
+      PARAMETER (ONE= (1.0D+0,0.0D+0))
+*     ..
+      IF (N.LE.0 .OR. INCX.LE.0 .OR. ZA.EQ.ONE) RETURN
       IF (INCX.EQ.1) THEN
 *
 *        code for increment equal to 1

SRC/clascl.f

@@ -272,6 +272,8 @@ SUBROUTINE CLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
          ELSE
             MUL = CTOC / CFROMC
             DONE = .TRUE.
+            IF (MUL .EQ. ONE)
+     $         RETURN
          END IF
       END IF
 *

SRC/dlascl.f

@@ -272,6 +272,8 @@ SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
          ELSE
             MUL = CTOC / CFROMC
             DONE = .TRUE.
+            IF (MUL .EQ. ONE)
+     $         RETURN
          END IF
       END IF
 *

SRC/slascl.f

@@ -272,6 +272,8 @@ SUBROUTINE SLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
          ELSE
             MUL = CTOC / CFROMC
             DONE = .TRUE.
+            IF (MUL .EQ. ONE)
+     $         RETURN
          END IF
       END IF
 *

SRC/zlascl.f

@@ -272,6 +272,8 @@ SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
          ELSE
             MUL = CTOC / CFROMC
             DONE = .TRUE.
+            IF (MUL .EQ. ONE)
+     $         RETURN
          END IF
       END IF
 *