Scaling routines do a quick return if scaling with one

* SCAL: Quick return if scaling factor is one * LASCL: If cto == cfrom and neither input is NaN or Inf, skip scaling
chrwarm · May 21, 2022 · d0ad95c · d0ad95c
1 parent 3b177e9
commit d0ad95c
Show file tree

Hide file tree

Showing 10 changed files with 39 additions and 9 deletions.
diff --git a/BLAS/SRC/cscal.f b/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

diff --git a/BLAS/SRC/csscal.f b/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

diff --git a/BLAS/SRC/dscal.f b/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

diff --git a/BLAS/SRC/sscal.f b/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

diff --git a/BLAS/SRC/zdscal.f b/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

diff --git a/BLAS/SRC/zscal.f b/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

diff --git a/SRC/clascl.f b/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
 *

diff --git a/SRC/dlascl.f b/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
 *

diff --git a/SRC/slascl.f b/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
 *

diff --git a/SRC/zlascl.f b/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
 *