From 4ea5c1e7c9525fcce84e711c2d73d92b72cadc1b Mon Sep 17 00:00:00 2001 From: "weslley.spereira" Date: Wed, 26 May 2021 11:52:57 -0300 Subject: [PATCH 1/4] Revert "Merge pull request #290 from mgates3/norms" This reverts commit 8d23489e6185ae6c322dbb0904dca6f467b55791, reversing changes made to c3b03d8f2742abde19ed6c165e1bef544afaffb4. --- SRC/CMakeLists.txt | 4 +- SRC/Makefile | 4 +- SRC/clangb.f | 23 +++-------- SRC/clange.f | 22 +++-------- SRC/clanhb.f | 48 +++++++---------------- SRC/clanhe.f | 45 ++++++---------------- SRC/clanhp.f | 46 ++++++---------------- SRC/clanhs.f | 23 +++-------- SRC/clansb.f | 42 +++++--------------- SRC/clansp.f | 54 ++++++++------------------ SRC/clansy.f | 40 +++++-------------- SRC/clantb.f | 55 +++++++++------------------ SRC/clantp.f | 53 ++++++++------------------ SRC/clantr.f | 54 ++++++++------------------ SRC/dcombssq.f | 95 ---------------------------------------------- SRC/dlangb.f | 26 ++++--------- SRC/dlange.f | 22 +++-------- SRC/dlanhs.f | 25 ++++-------- SRC/dlansb.f | 44 ++++++--------------- SRC/dlansp.f | 48 +++++++---------------- SRC/dlansy.f | 42 +++++--------------- SRC/dlantb.f | 57 ++++++++++------------------ SRC/dlantp.f | 55 ++++++++------------------- SRC/dlantr.f | 56 +++++++++------------------ SRC/scombssq.f | 95 ---------------------------------------------- SRC/slangb.f | 26 ++++--------- SRC/slange.f | 22 +++-------- SRC/slanhs.f | 25 ++++-------- SRC/slansb.f | 44 ++++++--------------- SRC/slansp.f | 48 +++++++---------------- SRC/slansy.f | 42 +++++--------------- SRC/slantb.f | 57 ++++++++++------------------ SRC/slantp.f | 55 ++++++++------------------- SRC/slantr.f | 56 +++++++++------------------ SRC/zlangb.f | 23 +++-------- SRC/zlange.f | 22 +++-------- SRC/zlanhb.f | 48 +++++++---------------- SRC/zlanhe.f | 45 ++++++---------------- SRC/zlanhp.f | 46 ++++++---------------- SRC/zlanhs.f | 23 +++-------- SRC/zlansb.f | 42 +++++--------------- SRC/zlansp.f | 54 ++++++++------------------ SRC/zlansy.f | 40 +++++-------------- SRC/zlantb.f | 55 +++++++++------------------ SRC/zlantp.f | 53 ++++++++------------------ SRC/zlantr.f | 54 ++++++++------------------ 46 files changed, 496 insertions(+), 1462 deletions(-) delete mode 100644 SRC/dcombssq.f delete mode 100644 SRC/scombssq.f diff --git a/SRC/CMakeLists.txt b/SRC/CMakeLists.txt index abd05731d7..236a3ac580 100644 --- a/SRC/CMakeLists.txt +++ b/SRC/CMakeLists.txt @@ -155,7 +155,7 @@ set(SLASRC ssytrd_2stage.f ssytrd_sy2sb.f ssytrd_sb2st.F ssb2st_kernels.f ssyevd_2stage.f ssyev_2stage.f ssyevx_2stage.f ssyevr_2stage.f ssbev_2stage.f ssbevx_2stage.f ssbevd_2stage.f ssygv_2stage.f - sgesvdq.f scombssq.f) + sgesvdq.f) set(DSLASRC spotrs.f sgetrs.f spotrf.f sgetrf.f) @@ -352,7 +352,7 @@ set(DLASRC dsytrd_2stage.f dsytrd_sy2sb.f dsytrd_sb2st.F dsb2st_kernels.f dsyevd_2stage.f dsyev_2stage.f dsyevx_2stage.f dsyevr_2stage.f dsbev_2stage.f dsbevx_2stage.f dsbevd_2stage.f dsygv_2stage.f - dgesvdq.f dcombssq.f) + dgesvdq.f) set(DXLASRC dgesvxx.f dgerfsx.f dla_gerfsx_extended.f dla_geamv.f dla_gercond.f dla_gerpvgrw.f dsysvxx.f dsyrfsx.f diff --git a/SRC/Makefile b/SRC/Makefile index 527fb086db..5142b428dd 100644 --- a/SRC/Makefile +++ b/SRC/Makefile @@ -191,7 +191,7 @@ SLASRC = \ ssytrd_2stage.o ssytrd_sy2sb.o ssytrd_sb2st.o ssb2st_kernels.o \ ssyevd_2stage.o ssyev_2stage.o ssyevx_2stage.o ssyevr_2stage.o \ ssbev_2stage.o ssbevx_2stage.o ssbevd_2stage.o ssygv_2stage.o \ - sgesvdq.o scombssq.o + sgesvdq.o DSLASRC = spotrs.o sgetrs.o spotrf.o sgetrf.o @@ -394,7 +394,7 @@ DLASRC = \ dsytrd_2stage.o dsytrd_sy2sb.o dsytrd_sb2st.o dsb2st_kernels.o \ dsyevd_2stage.o dsyev_2stage.o dsyevx_2stage.o dsyevr_2stage.o \ dsbev_2stage.o dsbevx_2stage.o dsbevd_2stage.o dsygv_2stage.o \ - dgesvdq.o dcombssq.o + dgesvdq.o ifdef USEXBLAS DXLASRC = dgesvxx.o dgerfsx.o dla_gerfsx_extended.o dla_geamv.o \ diff --git a/SRC/clangb.f b/SRC/clangb.f index 039396114c..09f36bbc45 100644 --- a/SRC/clangb.f +++ b/SRC/clangb.f @@ -127,7 +127,6 @@ REAL FUNCTION CLANGB( NORM, N, KL, KU, AB, LDAB, * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM INTEGER KL, KU, LDAB, N @@ -145,17 +144,14 @@ REAL FUNCTION CLANGB( NORM, N, KL, KU, AB, LDAB, * .. * .. Local Scalars .. INTEGER I, J, K, L - REAL SUM, VALUE, TEMP -* .. -* .. Local Arrays .. - REAL SSQ( 2 ), COLSSQ( 2 ) + REAL SCALE, SUM, VALUE, TEMP * .. * .. External Functions .. LOGICAL LSAME, SISNAN EXTERNAL LSAME, SISNAN * .. * .. External Subroutines .. - EXTERNAL CLASSQ, SCOMBSSQ + EXTERNAL CLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT @@ -208,22 +204,15 @@ REAL FUNCTION CLANGB( NORM, N, KL, KU, AB, LDAB, ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. * - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 90 J = 1, N L = MAX( 1, J-KU ) K = KU + 1 - J + L - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL CLASSQ( MIN( N, J+KL )-L+1, AB( K, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL CLASSQ( MIN( N, J+KL )-L+1, AB( K, J ), 1, SCALE, SUM ) 90 CONTINUE - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * CLANGB = VALUE diff --git a/SRC/clange.f b/SRC/clange.f index 5f009e1736..14d487b26f 100644 --- a/SRC/clange.f +++ b/SRC/clange.f @@ -117,7 +117,6 @@ REAL FUNCTION CLANGE( NORM, M, N, A, LDA, WORK ) * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM INTEGER LDA, M, N @@ -135,17 +134,14 @@ REAL FUNCTION CLANGE( NORM, M, N, A, LDA, WORK ) * .. * .. Local Scalars .. INTEGER I, J - REAL SUM, VALUE, TEMP -* .. -* .. Local Arrays .. - REAL SSQ( 2 ), COLSSQ( 2 ) + REAL SCALE, SUM, VALUE, TEMP * .. * .. External Functions .. LOGICAL LSAME, SISNAN EXTERNAL LSAME, SISNAN * .. * .. External Subroutines .. - EXTERNAL CLASSQ, SCOMBSSQ + EXTERNAL CLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MIN, SQRT @@ -197,19 +193,13 @@ REAL FUNCTION CLANGE( NORM, M, N, A, LDA, WORK ) ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. * - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 90 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL CLASSQ( M, A( 1, J ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL CLASSQ( M, A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * CLANGE = VALUE diff --git a/SRC/clanhb.f b/SRC/clanhb.f index e0a7f57fe9..1eae7fbe74 100644 --- a/SRC/clanhb.f +++ b/SRC/clanhb.f @@ -134,7 +134,6 @@ REAL FUNCTION CLANHB( NORM, UPLO, N, K, AB, LDAB, * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER K, LDAB, N @@ -152,17 +151,14 @@ REAL FUNCTION CLANHB( NORM, UPLO, N, K, AB, LDAB, * .. * .. Local Scalars .. INTEGER I, J, L - REAL ABSA, SUM, VALUE -* .. -* .. Local Arrays .. - REAL SSQ( 2 ), COLSSQ( 2 ) + REAL ABSA, SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME, SISNAN EXTERNAL LSAME, SISNAN * .. * .. External Subroutines .. - EXTERNAL CLASSQ, SCOMBSSQ + EXTERNAL CLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, REAL, SQRT @@ -234,57 +230,39 @@ REAL FUNCTION CLANHB( NORM, UPLO, N, K, AB, LDAB, ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. -* - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE -* -* Sum off-diagonals * + SCALE = ZERO + SUM = ONE IF( K.GT.0 ) THEN IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE CALL CLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ), - $ 1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + $ 1, SCALE, SUM ) 110 CONTINUE L = K + 1 ELSE DO 120 J = 1, N - 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL CLASSQ( MIN( N-J, K ), AB( 2, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL CLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE, + $ SUM ) 120 CONTINUE L = 1 END IF - SSQ( 2 ) = 2*SSQ( 2 ) + SUM = 2*SUM ELSE L = 1 END IF -* -* Sum diagonal -* - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE DO 130 J = 1, N IF( REAL( AB( L, J ) ).NE.ZERO ) THEN ABSA = ABS( REAL( AB( L, J ) ) ) - IF( COLSSQ( 1 ).LT.ABSA ) THEN - COLSSQ( 2 ) = ONE + COLSSQ(2)*( COLSSQ(1) / ABSA )**2 - COLSSQ( 1 ) = ABSA + IF( SCALE.LT.ABSA ) THEN + SUM = ONE + SUM*( SCALE / ABSA )**2 + SCALE = ABSA ELSE - COLSSQ( 2 ) = COLSSQ( 2 ) + ( ABSA / COLSSQ( 1 ) )**2 + SUM = SUM + ( ABSA / SCALE )**2 END IF END IF 130 CONTINUE - CALL SCOMBSSQ( SSQ, COLSSQ ) - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * CLANHB = VALUE diff --git a/SRC/clanhe.f b/SRC/clanhe.f index 571c263d00..8181b329ef 100644 --- a/SRC/clanhe.f +++ b/SRC/clanhe.f @@ -126,7 +126,6 @@ REAL FUNCTION CLANHE( NORM, UPLO, N, A, LDA, WORK ) * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER LDA, N @@ -144,17 +143,14 @@ REAL FUNCTION CLANHE( NORM, UPLO, N, A, LDA, WORK ) * .. * .. Local Scalars .. INTEGER I, J - REAL ABSA, SUM, VALUE -* .. -* .. Local Arrays .. - REAL SSQ( 2 ), COLSSQ( 2 ) + REAL ABSA, SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME, SISNAN EXTERNAL LSAME, SISNAN * .. * .. External Subroutines .. - EXTERNAL CLASSQ, SCOMBSSQ + EXTERNAL CLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, REAL, SQRT @@ -224,48 +220,31 @@ REAL FUNCTION CLANHE( NORM, UPLO, N, A, LDA, WORK ) ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. -* - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE -* -* Sum off-diagonals * + SCALE = ZERO + SUM = ONE IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL CLASSQ( J-1, A( 1, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL CLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) 110 CONTINUE ELSE DO 120 J = 1, N - 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL CLASSQ( N-J, A( J+1, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL CLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) 120 CONTINUE END IF - SSQ( 2 ) = 2*SSQ( 2 ) -* -* Sum diagonal -* + SUM = 2*SUM DO 130 I = 1, N IF( REAL( A( I, I ) ).NE.ZERO ) THEN ABSA = ABS( REAL( A( I, I ) ) ) - IF( SSQ( 1 ).LT.ABSA ) THEN - SSQ( 2 ) = ONE + SSQ( 2 )*( SSQ( 1 ) / ABSA )**2 - SSQ( 1 ) = ABSA + IF( SCALE.LT.ABSA ) THEN + SUM = ONE + SUM*( SCALE / ABSA )**2 + SCALE = ABSA ELSE - SSQ( 2 ) = SSQ( 2 ) + ( ABSA / SSQ( 1 ) )**2 + SUM = SUM + ( ABSA / SCALE )**2 END IF END IF 130 CONTINUE - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * CLANHE = VALUE diff --git a/SRC/clanhp.f b/SRC/clanhp.f index 6993bfdf98..ff99a73537 100644 --- a/SRC/clanhp.f +++ b/SRC/clanhp.f @@ -119,7 +119,6 @@ REAL FUNCTION CLANHP( NORM, UPLO, N, AP, WORK ) * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER N @@ -137,17 +136,14 @@ REAL FUNCTION CLANHP( NORM, UPLO, N, AP, WORK ) * .. * .. Local Scalars .. INTEGER I, J, K - REAL ABSA, SUM, VALUE -* .. -* .. Local Arrays .. - REAL SSQ( 2 ), COLSSQ( 2 ) + REAL ABSA, SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME, SISNAN EXTERNAL LSAME, SISNAN * .. * .. External Subroutines .. - EXTERNAL CLASSQ, SCOMBSSQ + EXTERNAL CLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, REAL, SQRT @@ -226,48 +222,31 @@ REAL FUNCTION CLANHP( NORM, UPLO, N, AP, WORK ) ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. -* - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE -* -* Sum off-diagonals * + SCALE = ZERO + SUM = ONE K = 2 IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL CLASSQ( J-1, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL CLASSQ( J-1, AP( K ), 1, SCALE, SUM ) K = K + J 110 CONTINUE ELSE DO 120 J = 1, N - 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL CLASSQ( N-J, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL CLASSQ( N-J, AP( K ), 1, SCALE, SUM ) K = K + N - J + 1 120 CONTINUE END IF - SSQ( 2 ) = 2*SSQ( 2 ) -* -* Sum diagonal -* + SUM = 2*SUM K = 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE DO 130 I = 1, N IF( REAL( AP( K ) ).NE.ZERO ) THEN ABSA = ABS( REAL( AP( K ) ) ) - IF( COLSSQ( 1 ).LT.ABSA ) THEN - COLSSQ( 2 ) = ONE + COLSSQ(2)*( COLSSQ(1) / ABSA )**2 - COLSSQ( 1 ) = ABSA + IF( SCALE.LT.ABSA ) THEN + SUM = ONE + SUM*( SCALE / ABSA )**2 + SCALE = ABSA ELSE - COLSSQ( 2 ) = COLSSQ( 2 ) + ( ABSA / COLSSQ( 1 ) )**2 + SUM = SUM + ( ABSA / SCALE )**2 END IF END IF IF( LSAME( UPLO, 'U' ) ) THEN @@ -276,8 +255,7 @@ REAL FUNCTION CLANHP( NORM, UPLO, N, AP, WORK ) K = K + N - I + 1 END IF 130 CONTINUE - CALL SCOMBSSQ( SSQ, COLSSQ ) - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * CLANHP = VALUE diff --git a/SRC/clanhs.f b/SRC/clanhs.f index 514a8b67b7..faf86124ad 100644 --- a/SRC/clanhs.f +++ b/SRC/clanhs.f @@ -111,7 +111,6 @@ REAL FUNCTION CLANHS( NORM, N, A, LDA, WORK ) * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM INTEGER LDA, N @@ -129,17 +128,14 @@ REAL FUNCTION CLANHS( NORM, N, A, LDA, WORK ) * .. * .. Local Scalars .. INTEGER I, J - REAL SUM, VALUE -* .. -* .. Local Arrays .. - REAL SSQ( 2 ), COLSSQ( 2 ) + REAL SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME, SISNAN EXTERNAL LSAME, SISNAN * .. * .. External Subroutines .. - EXTERNAL CLASSQ, SCOMBSSQ + EXTERNAL CLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MIN, SQRT @@ -191,20 +187,13 @@ REAL FUNCTION CLANHS( NORM, N, A, LDA, WORK ) ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. * - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 90 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL CLASSQ( MIN( N, J+1 ), A( 1, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL CLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * CLANHS = VALUE diff --git a/SRC/clansb.f b/SRC/clansb.f index 44c00c31d3..b95f6335f2 100644 --- a/SRC/clansb.f +++ b/SRC/clansb.f @@ -132,7 +132,6 @@ REAL FUNCTION CLANSB( NORM, UPLO, N, K, AB, LDAB, * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER K, LDAB, N @@ -150,17 +149,14 @@ REAL FUNCTION CLANSB( NORM, UPLO, N, K, AB, LDAB, * .. * .. Local Scalars .. INTEGER I, J, L - REAL ABSA, SUM, VALUE -* .. -* .. Local Arrays .. - REAL SSQ( 2 ), COLSSQ( 2 ) + REAL ABSA, SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME, SISNAN EXTERNAL LSAME, SISNAN * .. * .. External Subroutines .. - EXTERNAL CLASSQ, SCOMBSSQ + EXTERNAL CLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT @@ -228,47 +224,29 @@ REAL FUNCTION CLANSB( NORM, UPLO, N, K, AB, LDAB, ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. -* - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE -* -* Sum off-diagonals * + SCALE = ZERO + SUM = ONE IF( K.GT.0 ) THEN IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE CALL CLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ), - $ 1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + $ 1, SCALE, SUM ) 110 CONTINUE L = K + 1 ELSE DO 120 J = 1, N - 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL CLASSQ( MIN( N-J, K ), AB( 2, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL CLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE, + $ SUM ) 120 CONTINUE L = 1 END IF - SSQ( 2 ) = 2*SSQ( 2 ) + SUM = 2*SUM ELSE L = 1 END IF -* -* Sum diagonal -* - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL CLASSQ( N, AB( L, 1 ), LDAB, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + CALL CLASSQ( N, AB( L, 1 ), LDAB, SCALE, SUM ) + VALUE = SCALE*SQRT( SUM ) END IF * CLANSB = VALUE diff --git a/SRC/clansp.f b/SRC/clansp.f index 5d41258258..1065066d33 100644 --- a/SRC/clansp.f +++ b/SRC/clansp.f @@ -117,7 +117,6 @@ REAL FUNCTION CLANSP( NORM, UPLO, N, AP, WORK ) * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER N @@ -135,17 +134,14 @@ REAL FUNCTION CLANSP( NORM, UPLO, N, AP, WORK ) * .. * .. Local Scalars .. INTEGER I, J, K - REAL ABSA, SUM, VALUE -* .. -* .. Local Arrays .. - REAL SSQ( 2 ), COLSSQ( 2 ) + REAL ABSA, SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME, SISNAN EXTERNAL LSAME, SISNAN * .. * .. External Subroutines .. - EXTERNAL CLASSQ, SCOMBSSQ + EXTERNAL CLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, REAL, SQRT @@ -220,57 +216,40 @@ REAL FUNCTION CLANSP( NORM, UPLO, N, AP, WORK ) ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. -* - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE -* -* Sum off-diagonals * + SCALE = ZERO + SUM = ONE K = 2 IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL CLASSQ( J-1, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL CLASSQ( J-1, AP( K ), 1, SCALE, SUM ) K = K + J 110 CONTINUE ELSE DO 120 J = 1, N - 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL CLASSQ( N-J, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL CLASSQ( N-J, AP( K ), 1, SCALE, SUM ) K = K + N - J + 1 120 CONTINUE END IF - SSQ( 2 ) = 2*SSQ( 2 ) -* -* Sum diagonal -* + SUM = 2*SUM K = 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE DO 130 I = 1, N IF( REAL( AP( K ) ).NE.ZERO ) THEN ABSA = ABS( REAL( AP( K ) ) ) - IF( COLSSQ( 1 ).LT.ABSA ) THEN - COLSSQ( 2 ) = ONE + COLSSQ(2)*( COLSSQ(1) / ABSA )**2 - COLSSQ( 1 ) = ABSA + IF( SCALE.LT.ABSA ) THEN + SUM = ONE + SUM*( SCALE / ABSA )**2 + SCALE = ABSA ELSE - COLSSQ( 2 ) = COLSSQ( 2 ) + ( ABSA / COLSSQ( 1 ) )**2 + SUM = SUM + ( ABSA / SCALE )**2 END IF END IF IF( AIMAG( AP( K ) ).NE.ZERO ) THEN ABSA = ABS( AIMAG( AP( K ) ) ) - IF( COLSSQ( 1 ).LT.ABSA ) THEN - COLSSQ( 2 ) = ONE + COLSSQ(2)*( COLSSQ(1) / ABSA )**2 - COLSSQ( 1 ) = ABSA + IF( SCALE.LT.ABSA ) THEN + SUM = ONE + SUM*( SCALE / ABSA )**2 + SCALE = ABSA ELSE - COLSSQ( 2 ) = COLSSQ( 2 ) + ( ABSA / COLSSQ( 1 ) )**2 + SUM = SUM + ( ABSA / SCALE )**2 END IF END IF IF( LSAME( UPLO, 'U' ) ) THEN @@ -279,8 +258,7 @@ REAL FUNCTION CLANSP( NORM, UPLO, N, AP, WORK ) K = K + N - I + 1 END IF 130 CONTINUE - CALL SCOMBSSQ( SSQ, COLSSQ ) - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * CLANSP = VALUE diff --git a/SRC/clansy.f b/SRC/clansy.f index 2bb77b79d2..478c14040d 100644 --- a/SRC/clansy.f +++ b/SRC/clansy.f @@ -125,7 +125,6 @@ REAL FUNCTION CLANSY( NORM, UPLO, N, A, LDA, WORK ) * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER LDA, N @@ -143,17 +142,14 @@ REAL FUNCTION CLANSY( NORM, UPLO, N, A, LDA, WORK ) * .. * .. Local Scalars .. INTEGER I, J - REAL ABSA, SUM, VALUE -* .. -* .. Local Arrays .. - REAL SSQ( 2 ), COLSSQ( 2 ) + REAL ABSA, SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME, SISNAN EXTERNAL LSAME, SISNAN * .. * .. External Subroutines .. - EXTERNAL CLASSQ, SCOMBSSQ + EXTERNAL CLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT @@ -219,39 +215,21 @@ REAL FUNCTION CLANSY( NORM, UPLO, N, A, LDA, WORK ) ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. -* - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE -* -* Sum off-diagonals * + SCALE = ZERO + SUM = ONE IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL CLASSQ( J-1, A( 1, J ), 1, COLSSQ(1), COLSSQ(2) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL CLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) 110 CONTINUE ELSE DO 120 J = 1, N - 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL CLASSQ( N-J, A( J+1, J ), 1, COLSSQ(1), COLSSQ(2) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL CLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) 120 CONTINUE END IF - SSQ( 2 ) = 2*SSQ( 2 ) -* -* Sum diagonal -* - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL CLASSQ( N, A, LDA+1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + SUM = 2*SUM + CALL CLASSQ( N, A, LDA+1, SCALE, SUM ) + VALUE = SCALE*SQRT( SUM ) END IF * CLANSY = VALUE diff --git a/SRC/clantb.f b/SRC/clantb.f index 6769975cc7..f7747b6edd 100644 --- a/SRC/clantb.f +++ b/SRC/clantb.f @@ -143,7 +143,6 @@ REAL FUNCTION CLANTB( NORM, UPLO, DIAG, N, K, AB, * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO INTEGER K, LDAB, N @@ -162,17 +161,14 @@ REAL FUNCTION CLANTB( NORM, UPLO, DIAG, N, K, AB, * .. Local Scalars .. LOGICAL UDIAG INTEGER I, J, L - REAL SUM, VALUE -* .. -* .. Local Arrays .. - REAL SSQ( 2 ), COLSSQ( 2 ) + REAL SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME, SISNAN EXTERNAL LSAME, SISNAN * .. * .. External Subroutines .. - EXTERNAL CLASSQ, SCOMBSSQ + EXTERNAL CLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT @@ -314,61 +310,46 @@ REAL FUNCTION CLANTB( NORM, UPLO, DIAG, N, K, AB, ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. * IF( LSAME( UPLO, 'U' ) ) THEN IF( LSAME( DIAG, 'U' ) ) THEN - SSQ( 1 ) = ONE - SSQ( 2 ) = N + SCALE = ONE + SUM = N IF( K.GT.0 ) THEN DO 280 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE CALL CLASSQ( MIN( J-1, K ), - $ AB( MAX( K+2-J, 1 ), J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + $ AB( MAX( K+2-J, 1 ), J ), 1, SCALE, + $ SUM ) 280 CONTINUE END IF ELSE - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 290 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE CALL CLASSQ( MIN( J, K+1 ), AB( MAX( K+2-J, 1 ), J ), - $ 1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + $ 1, SCALE, SUM ) 290 CONTINUE END IF ELSE IF( LSAME( DIAG, 'U' ) ) THEN - SSQ( 1 ) = ONE - SSQ( 2 ) = N + SCALE = ONE + SUM = N IF( K.GT.0 ) THEN DO 300 J = 1, N - 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL CLASSQ( MIN( N-J, K ), AB( 2, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL CLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE, + $ SUM ) 300 CONTINUE END IF ELSE - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 310 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL CLASSQ( MIN( N-J+1, K+1 ), AB( 1, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL CLASSQ( MIN( N-J+1, K+1 ), AB( 1, J ), 1, SCALE, + $ SUM ) 310 CONTINUE END IF END IF - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * CLANTB = VALUE diff --git a/SRC/clantp.f b/SRC/clantp.f index bae81eb5a9..f7169360eb 100644 --- a/SRC/clantp.f +++ b/SRC/clantp.f @@ -127,7 +127,6 @@ REAL FUNCTION CLANTP( NORM, UPLO, DIAG, N, AP, WORK ) * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO INTEGER N @@ -146,17 +145,14 @@ REAL FUNCTION CLANTP( NORM, UPLO, DIAG, N, AP, WORK ) * .. Local Scalars .. LOGICAL UDIAG INTEGER I, J, K - REAL SUM, VALUE -* .. -* .. Local Arrays .. - REAL SSQ( 2 ), COLSSQ( 2 ) + REAL SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME, SISNAN EXTERNAL LSAME, SISNAN * .. * .. External Subroutines .. - EXTERNAL CLASSQ, SCOMBSSQ + EXTERNAL CLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT @@ -309,64 +305,45 @@ REAL FUNCTION CLANTP( NORM, UPLO, DIAG, N, AP, WORK ) ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. * IF( LSAME( UPLO, 'U' ) ) THEN IF( LSAME( DIAG, 'U' ) ) THEN - SSQ( 1 ) = ONE - SSQ( 2 ) = N + SCALE = ONE + SUM = N K = 2 DO 280 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL CLASSQ( J-1, AP( K ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL CLASSQ( J-1, AP( K ), 1, SCALE, SUM ) K = K + J 280 CONTINUE ELSE - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE K = 1 DO 290 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL CLASSQ( J, AP( K ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL CLASSQ( J, AP( K ), 1, SCALE, SUM ) K = K + J 290 CONTINUE END IF ELSE IF( LSAME( DIAG, 'U' ) ) THEN - SSQ( 1 ) = ONE - SSQ( 2 ) = N + SCALE = ONE + SUM = N K = 2 DO 300 J = 1, N - 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL CLASSQ( N-J, AP( K ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL CLASSQ( N-J, AP( K ), 1, SCALE, SUM ) K = K + N - J + 1 300 CONTINUE ELSE - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE K = 1 DO 310 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL CLASSQ( N-J+1, AP( K ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL CLASSQ( N-J+1, AP( K ), 1, SCALE, SUM ) K = K + N - J + 1 310 CONTINUE END IF END IF - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * CLANTP = VALUE diff --git a/SRC/clantr.f b/SRC/clantr.f index 03c30c01a6..f1dce1402d 100644 --- a/SRC/clantr.f +++ b/SRC/clantr.f @@ -144,7 +144,6 @@ REAL FUNCTION CLANTR( NORM, UPLO, DIAG, M, N, A, LDA, * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO INTEGER LDA, M, N @@ -163,17 +162,14 @@ REAL FUNCTION CLANTR( NORM, UPLO, DIAG, M, N, A, LDA, * .. Local Scalars .. LOGICAL UDIAG INTEGER I, J - REAL SUM, VALUE -* .. -* .. Local Arrays .. - REAL SSQ( 2 ), COLSSQ( 2 ) + REAL SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME, SISNAN EXTERNAL LSAME, SISNAN * .. * .. External Subroutines .. - EXTERNAL CLASSQ, SCOMBSSQ + EXTERNAL CLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MIN, SQRT @@ -314,56 +310,38 @@ REAL FUNCTION CLANTR( NORM, UPLO, DIAG, M, N, A, LDA, ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. * IF( LSAME( UPLO, 'U' ) ) THEN IF( LSAME( DIAG, 'U' ) ) THEN - SSQ( 1 ) = ONE - SSQ( 2 ) = MIN( M, N ) + SCALE = ONE + SUM = MIN( M, N ) DO 290 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL CLASSQ( MIN( M, J-1 ), A( 1, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL CLASSQ( MIN( M, J-1 ), A( 1, J ), 1, SCALE, SUM ) 290 CONTINUE ELSE - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 300 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL CLASSQ( MIN( M, J ), A( 1, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL CLASSQ( MIN( M, J ), A( 1, J ), 1, SCALE, SUM ) 300 CONTINUE END IF ELSE IF( LSAME( DIAG, 'U' ) ) THEN - SSQ( 1 ) = ONE - SSQ( 2 ) = MIN( M, N ) + SCALE = ONE + SUM = MIN( M, N ) DO 310 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL CLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL CLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE, + $ SUM ) 310 CONTINUE ELSE - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 320 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL CLASSQ( M-J+1, A( J, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL CLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM ) 320 CONTINUE END IF END IF - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * CLANTR = VALUE diff --git a/SRC/dcombssq.f b/SRC/dcombssq.f deleted file mode 100644 index c32bbc5908..0000000000 --- a/SRC/dcombssq.f +++ /dev/null @@ -1,95 +0,0 @@ -*> \brief \b DCOMBSSQ adds two scaled sum of squares quantities. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* -* Definition: -* =========== -* -* SUBROUTINE DCOMBSSQ( V1, V2 ) -* -* .. Array Arguments .. -* DOUBLE PRECISION V1( 2 ), V2( 2 ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DCOMBSSQ adds two scaled sum of squares quantities, V1 := V1 + V2. -*> That is, -*> -*> V1_scale**2 * V1_sumsq := V1_scale**2 * V1_sumsq -*> + V2_scale**2 * V2_sumsq -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in,out] V1 -*> \verbatim -*> V1 is DOUBLE PRECISION array, dimension (2). -*> The first scaled sum. -*> V1(1) = V1_scale, V1(2) = V1_sumsq. -*> \endverbatim -*> -*> \param[in] V2 -*> \verbatim -*> V2 is DOUBLE PRECISION array, dimension (2). -*> The second scaled sum. -*> V2(1) = V2_scale, V2(2) = V2_sumsq. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - SUBROUTINE DCOMBSSQ( V1, V2 ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2018 -* -* .. Array Arguments .. - DOUBLE PRECISION V1( 2 ), V2( 2 ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* A zero sum V2 shall not modify the scaling factor of V1 - IF( V2( 2 ).EQ.ZERO ) RETURN -* - IF( V1( 1 ).GE.V2( 1 ) ) THEN - IF( V1( 1 ).NE.ZERO ) THEN - V1( 2 ) = V1( 2 ) + ( V2( 1 ) / V1( 1 ) )**2 * V2( 2 ) - ELSE - V1( 2 ) = V1( 2 ) + V2( 2 ) - END IF - ELSE - V1( 2 ) = V2( 2 ) + ( V1( 1 ) / V2( 1 ) )**2 * V1( 2 ) - V1( 1 ) = V2( 1 ) - END IF - RETURN -* -* End of DCOMBSSQ -* - END diff --git a/SRC/dlangb.f b/SRC/dlangb.f index 52dad05098..96c9570852 100644 --- a/SRC/dlangb.f +++ b/SRC/dlangb.f @@ -126,7 +126,6 @@ DOUBLE PRECISION FUNCTION DLANGB( NORM, N, KL, KU, AB, LDAB, * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM INTEGER KL, KU, LDAB, N @@ -137,24 +136,22 @@ DOUBLE PRECISION FUNCTION DLANGB( NORM, N, KL, KU, AB, LDAB, * * ===================================================================== * +* * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J, K, L - DOUBLE PRECISION SUM, VALUE, TEMP + DOUBLE PRECISION SCALE, SUM, VALUE, TEMP * .. -* .. Local Arrays .. - DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) +* .. External Subroutines .. + EXTERNAL DLASSQ * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. -* .. External Subroutines .. - EXTERNAL DLASSQ, DCOMBSSQ -* .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. @@ -206,22 +203,15 @@ DOUBLE PRECISION FUNCTION DLANGB( NORM, N, KL, KU, AB, LDAB, ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. * - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 90 J = 1, N L = MAX( 1, J-KU ) K = KU + 1 - J + L - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL DLASSQ( MIN( N, J+KL )-L+1, AB( K, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL DLASSQ( MIN( N, J+KL )-L+1, AB( K, J ), 1, SCALE, SUM ) 90 CONTINUE - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * DLANGB = VALUE diff --git a/SRC/dlange.f b/SRC/dlange.f index ac5b1403eb..9d214cb542 100644 --- a/SRC/dlange.f +++ b/SRC/dlange.f @@ -116,7 +116,6 @@ DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM INTEGER LDA, M, N @@ -133,13 +132,10 @@ DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) * .. * .. Local Scalars .. INTEGER I, J - DOUBLE PRECISION SUM, VALUE, TEMP -* .. -* .. Local Arrays .. - DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) + DOUBLE PRECISION SCALE, SUM, VALUE, TEMP * .. * .. External Subroutines .. - EXTERNAL DLASSQ, DCOMBSSQ + EXTERNAL DLASSQ * .. * .. External Functions .. LOGICAL LSAME, DISNAN @@ -195,19 +191,13 @@ DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. * - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 90 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL DLASSQ( M, A( 1, J ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL DLASSQ( M, A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * DLANGE = VALUE diff --git a/SRC/dlanhs.f b/SRC/dlanhs.f index 9a448736a4..29560e4a66 100644 --- a/SRC/dlanhs.f +++ b/SRC/dlanhs.f @@ -110,7 +110,6 @@ DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK ) * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM INTEGER LDA, N @@ -127,18 +126,15 @@ DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK ) * .. * .. Local Scalars .. INTEGER I, J - DOUBLE PRECISION SUM, VALUE + DOUBLE PRECISION SCALE, SUM, VALUE * .. -* .. Local Arrays .. - DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) +* .. External Subroutines .. + EXTERNAL DLASSQ * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. -* .. External Subroutines .. - EXTERNAL DLASSQ, DCOMBSSQ -* .. * .. Intrinsic Functions .. INTRINSIC ABS, MIN, SQRT * .. @@ -189,20 +185,13 @@ DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK ) ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. * - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 90 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL DLASSQ( MIN( N, J+1 ), A( 1, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL DLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * DLANHS = VALUE diff --git a/SRC/dlansb.f b/SRC/dlansb.f index dae769b25d..4df8db250f 100644 --- a/SRC/dlansb.f +++ b/SRC/dlansb.f @@ -131,7 +131,6 @@ DOUBLE PRECISION FUNCTION DLANSB( NORM, UPLO, N, K, AB, LDAB, * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER K, LDAB, N @@ -148,18 +147,15 @@ DOUBLE PRECISION FUNCTION DLANSB( NORM, UPLO, N, K, AB, LDAB, * .. * .. Local Scalars .. INTEGER I, J, L - DOUBLE PRECISION ABSA, SUM, VALUE + DOUBLE PRECISION ABSA, SCALE, SUM, VALUE * .. -* .. Local Arrays .. - DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) +* .. External Subroutines .. + EXTERNAL DLASSQ * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. -* .. External Subroutines .. - EXTERNAL DLASSQ, DCOMBSSQ -* .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. @@ -226,47 +222,29 @@ DOUBLE PRECISION FUNCTION DLANSB( NORM, UPLO, N, K, AB, LDAB, ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. -* - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE -* -* Sum off-diagonals * + SCALE = ZERO + SUM = ONE IF( K.GT.0 ) THEN IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE CALL DLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ), - $ 1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + $ 1, SCALE, SUM ) 110 CONTINUE L = K + 1 ELSE DO 120 J = 1, N - 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL DLASSQ( MIN( N-J, K ), AB( 2, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL DLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE, + $ SUM ) 120 CONTINUE L = 1 END IF - SSQ( 2 ) = 2*SSQ( 2 ) + SUM = 2*SUM ELSE L = 1 END IF -* -* Sum diagonal -* - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL DLASSQ( N, AB( L, 1 ), LDAB, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + CALL DLASSQ( N, AB( L, 1 ), LDAB, SCALE, SUM ) + VALUE = SCALE*SQRT( SUM ) END IF * DLANSB = VALUE diff --git a/SRC/dlansp.f b/SRC/dlansp.f index 60e74a03d3..50f974e1e0 100644 --- a/SRC/dlansp.f +++ b/SRC/dlansp.f @@ -116,7 +116,6 @@ DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK ) * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER N @@ -133,18 +132,15 @@ DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK ) * .. * .. Local Scalars .. INTEGER I, J, K - DOUBLE PRECISION ABSA, SUM, VALUE + DOUBLE PRECISION ABSA, SCALE, SUM, VALUE * .. -* .. Local Arrays .. - DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) +* .. External Subroutines .. + EXTERNAL DLASSQ * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. -* .. External Subroutines .. - EXTERNAL DLASSQ, DCOMBSSQ -* .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. @@ -218,48 +214,31 @@ DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK ) ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. -* - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE -* -* Sum off-diagonals * + SCALE = ZERO + SUM = ONE K = 2 IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL DLASSQ( J-1, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL DLASSQ( J-1, AP( K ), 1, SCALE, SUM ) K = K + J 110 CONTINUE ELSE DO 120 J = 1, N - 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL DLASSQ( N-J, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL DLASSQ( N-J, AP( K ), 1, SCALE, SUM ) K = K + N - J + 1 120 CONTINUE END IF - SSQ( 2 ) = 2*SSQ( 2 ) -* -* Sum diagonal -* + SUM = 2*SUM K = 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE DO 130 I = 1, N IF( AP( K ).NE.ZERO ) THEN ABSA = ABS( AP( K ) ) - IF( COLSSQ( 1 ).LT.ABSA ) THEN - COLSSQ( 2 ) = ONE + COLSSQ(2)*( COLSSQ(1) / ABSA )**2 - COLSSQ( 1 ) = ABSA + IF( SCALE.LT.ABSA ) THEN + SUM = ONE + SUM*( SCALE / ABSA )**2 + SCALE = ABSA ELSE - COLSSQ( 2 ) = COLSSQ( 2 ) + ( ABSA / COLSSQ( 1 ) )**2 + SUM = SUM + ( ABSA / SCALE )**2 END IF END IF IF( LSAME( UPLO, 'U' ) ) THEN @@ -268,8 +247,7 @@ DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK ) K = K + N - I + 1 END IF 130 CONTINUE - CALL DCOMBSSQ( SSQ, COLSSQ ) - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * DLANSP = VALUE diff --git a/SRC/dlansy.f b/SRC/dlansy.f index 4eab8696e9..949c5535a2 100644 --- a/SRC/dlansy.f +++ b/SRC/dlansy.f @@ -124,7 +124,6 @@ DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER LDA, N @@ -141,18 +140,15 @@ DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) * .. * .. Local Scalars .. INTEGER I, J - DOUBLE PRECISION ABSA, SUM, VALUE + DOUBLE PRECISION ABSA, SCALE, SUM, VALUE * .. -* .. Local Arrays .. - DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) +* .. External Subroutines .. + EXTERNAL DLASSQ * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. -* .. External Subroutines .. - EXTERNAL DLASSQ, DCOMBSSQ -* .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. @@ -217,39 +213,21 @@ DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. -* - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE -* -* Sum off-diagonals * + SCALE = ZERO + SUM = ONE IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL DLASSQ( J-1, A( 1, J ), 1, COLSSQ(1), COLSSQ(2) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL DLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) 110 CONTINUE ELSE DO 120 J = 1, N - 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL DLASSQ( N-J, A( J+1, J ), 1, COLSSQ(1), COLSSQ(2) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL DLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) 120 CONTINUE END IF - SSQ( 2 ) = 2*SSQ( 2 ) -* -* Sum diagonal -* - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL DLASSQ( N, A, LDA+1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + SUM = 2*SUM + CALL DLASSQ( N, A, LDA+1, SCALE, SUM ) + VALUE = SCALE*SQRT( SUM ) END IF * DLANSY = VALUE diff --git a/SRC/dlantb.f b/SRC/dlantb.f index e267d57fc2..c2bcfa6122 100644 --- a/SRC/dlantb.f +++ b/SRC/dlantb.f @@ -142,7 +142,6 @@ DOUBLE PRECISION FUNCTION DLANTB( NORM, UPLO, DIAG, N, K, AB, * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO INTEGER K, LDAB, N @@ -160,18 +159,15 @@ DOUBLE PRECISION FUNCTION DLANTB( NORM, UPLO, DIAG, N, K, AB, * .. Local Scalars .. LOGICAL UDIAG INTEGER I, J, L - DOUBLE PRECISION SUM, VALUE + DOUBLE PRECISION SCALE, SUM, VALUE * .. -* .. Local Arrays .. - DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) +* .. External Subroutines .. + EXTERNAL DLASSQ * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. -* .. External Subroutines .. - EXTERNAL DLASSQ, DCOMBSSQ -* .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. @@ -312,61 +308,46 @@ DOUBLE PRECISION FUNCTION DLANTB( NORM, UPLO, DIAG, N, K, AB, ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. * IF( LSAME( UPLO, 'U' ) ) THEN IF( LSAME( DIAG, 'U' ) ) THEN - SSQ( 1 ) = ONE - SSQ( 2 ) = N + SCALE = ONE + SUM = N IF( K.GT.0 ) THEN DO 280 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE CALL DLASSQ( MIN( J-1, K ), - $ AB( MAX( K+2-J, 1 ), J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + $ AB( MAX( K+2-J, 1 ), J ), 1, SCALE, + $ SUM ) 280 CONTINUE END IF ELSE - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 290 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE CALL DLASSQ( MIN( J, K+1 ), AB( MAX( K+2-J, 1 ), J ), - $ 1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + $ 1, SCALE, SUM ) 290 CONTINUE END IF ELSE IF( LSAME( DIAG, 'U' ) ) THEN - SSQ( 1 ) = ONE - SSQ( 2 ) = N + SCALE = ONE + SUM = N IF( K.GT.0 ) THEN DO 300 J = 1, N - 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL DLASSQ( MIN( N-J, K ), AB( 2, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL DLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE, + $ SUM ) 300 CONTINUE END IF ELSE - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 310 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL DLASSQ( MIN( N-J+1, K+1 ), AB( 1, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL DLASSQ( MIN( N-J+1, K+1 ), AB( 1, J ), 1, SCALE, + $ SUM ) 310 CONTINUE END IF END IF - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * DLANTB = VALUE diff --git a/SRC/dlantp.f b/SRC/dlantp.f index d4b6505ac9..12f8b8e756 100644 --- a/SRC/dlantp.f +++ b/SRC/dlantp.f @@ -126,7 +126,6 @@ DOUBLE PRECISION FUNCTION DLANTP( NORM, UPLO, DIAG, N, AP, WORK ) * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO INTEGER N @@ -144,18 +143,15 @@ DOUBLE PRECISION FUNCTION DLANTP( NORM, UPLO, DIAG, N, AP, WORK ) * .. Local Scalars .. LOGICAL UDIAG INTEGER I, J, K - DOUBLE PRECISION SUM, VALUE + DOUBLE PRECISION SCALE, SUM, VALUE * .. -* .. Local Arrays .. - DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) +* .. External Subroutines .. + EXTERNAL DLASSQ * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. -* .. External Subroutines .. - EXTERNAL DLASSQ, DCOMBSSQ -* .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. @@ -307,64 +303,45 @@ DOUBLE PRECISION FUNCTION DLANTP( NORM, UPLO, DIAG, N, AP, WORK ) ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. * IF( LSAME( UPLO, 'U' ) ) THEN IF( LSAME( DIAG, 'U' ) ) THEN - SSQ( 1 ) = ONE - SSQ( 2 ) = N + SCALE = ONE + SUM = N K = 2 DO 280 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL DLASSQ( J-1, AP( K ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL DLASSQ( J-1, AP( K ), 1, SCALE, SUM ) K = K + J 280 CONTINUE ELSE - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE K = 1 DO 290 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL DLASSQ( J, AP( K ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL DLASSQ( J, AP( K ), 1, SCALE, SUM ) K = K + J 290 CONTINUE END IF ELSE IF( LSAME( DIAG, 'U' ) ) THEN - SSQ( 1 ) = ONE - SSQ( 2 ) = N + SCALE = ONE + SUM = N K = 2 DO 300 J = 1, N - 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL DLASSQ( N-J, AP( K ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL DLASSQ( N-J, AP( K ), 1, SCALE, SUM ) K = K + N - J + 1 300 CONTINUE ELSE - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE K = 1 DO 310 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL DLASSQ( N-J+1, AP( K ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL DLASSQ( N-J+1, AP( K ), 1, SCALE, SUM ) K = K + N - J + 1 310 CONTINUE END IF END IF - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * DLANTP = VALUE diff --git a/SRC/dlantr.f b/SRC/dlantr.f index 2ce93047e0..9b68f19755 100644 --- a/SRC/dlantr.f +++ b/SRC/dlantr.f @@ -143,7 +143,6 @@ DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA, * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO INTEGER LDA, M, N @@ -161,18 +160,15 @@ DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA, * .. Local Scalars .. LOGICAL UDIAG INTEGER I, J - DOUBLE PRECISION SUM, VALUE + DOUBLE PRECISION SCALE, SUM, VALUE * .. -* .. Local Arrays .. - DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) +* .. External Subroutines .. + EXTERNAL DLASSQ * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. -* .. External Subroutines .. - EXTERNAL DLASSQ, DCOMBSSQ -* .. * .. Intrinsic Functions .. INTRINSIC ABS, MIN, SQRT * .. @@ -312,56 +308,38 @@ DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA, ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. * IF( LSAME( UPLO, 'U' ) ) THEN IF( LSAME( DIAG, 'U' ) ) THEN - SSQ( 1 ) = ONE - SSQ( 2 ) = MIN( M, N ) + SCALE = ONE + SUM = MIN( M, N ) DO 290 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL DLASSQ( MIN( M, J-1 ), A( 1, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL DLASSQ( MIN( M, J-1 ), A( 1, J ), 1, SCALE, SUM ) 290 CONTINUE ELSE - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 300 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL DLASSQ( MIN( M, J ), A( 1, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL DLASSQ( MIN( M, J ), A( 1, J ), 1, SCALE, SUM ) 300 CONTINUE END IF ELSE IF( LSAME( DIAG, 'U' ) ) THEN - SSQ( 1 ) = ONE - SSQ( 2 ) = MIN( M, N ) + SCALE = ONE + SUM = MIN( M, N ) DO 310 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL DLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL DLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE, + $ SUM ) 310 CONTINUE ELSE - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 320 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL DLASSQ( M-J+1, A( J, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL DLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM ) 320 CONTINUE END IF END IF - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * DLANTR = VALUE diff --git a/SRC/scombssq.f b/SRC/scombssq.f deleted file mode 100644 index b2810ad320..0000000000 --- a/SRC/scombssq.f +++ /dev/null @@ -1,95 +0,0 @@ -*> \brief \b SCOMBSSQ adds two scaled sum of squares quantities -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* -* Definition: -* =========== -* -* SUBROUTINE SCOMBSSQ( V1, V2 ) -* -* .. Array Arguments .. -* REAL V1( 2 ), V2( 2 ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> SCOMBSSQ adds two scaled sum of squares quantities, V1 := V1 + V2. -*> That is, -*> -*> V1_scale**2 * V1_sumsq := V1_scale**2 * V1_sumsq -*> + V2_scale**2 * V2_sumsq -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in,out] V1 -*> \verbatim -*> V1 is REAL array, dimension (2). -*> The first scaled sum. -*> V1(1) = V1_scale, V1(2) = V1_sumsq. -*> \endverbatim -*> -*> \param[in] V2 -*> \verbatim -*> V2 is REAL array, dimension (2). -*> The second scaled sum. -*> V2(1) = V2_scale, V2(2) = V2_sumsq. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - SUBROUTINE SCOMBSSQ( V1, V2 ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2018 -* -* .. Array Arguments .. - REAL V1( 2 ), V2( 2 ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* A zero sum V2 shall not modify the scaling factor of V1 - IF( V2( 2 ).EQ.ZERO ) RETURN -* - IF( V1( 1 ).GE.V2( 1 ) ) THEN - IF( V1( 1 ).NE.ZERO ) THEN - V1( 2 ) = V1( 2 ) + ( V2( 1 ) / V1( 1 ) )**2 * V2( 2 ) - ELSE - V1( 2 ) = V1( 2 ) + V2( 2 ) - END IF - ELSE - V1( 2 ) = V2( 2 ) + ( V1( 1 ) / V2( 1 ) )**2 * V1( 2 ) - V1( 1 ) = V2( 1 ) - END IF - RETURN -* -* End of SCOMBSSQ -* - END diff --git a/SRC/slangb.f b/SRC/slangb.f index b8a8f00abe..a240092854 100644 --- a/SRC/slangb.f +++ b/SRC/slangb.f @@ -126,7 +126,6 @@ REAL FUNCTION SLANGB( NORM, N, KL, KU, AB, LDAB, * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM INTEGER KL, KU, LDAB, N @@ -137,24 +136,22 @@ REAL FUNCTION SLANGB( NORM, N, KL, KU, AB, LDAB, * * ===================================================================== * +* * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER I, J, K, L - REAL SUM, VALUE, TEMP + REAL SCALE, SUM, VALUE, TEMP * .. -* .. Local Arrays .. - REAL SSQ( 2 ), COLSSQ( 2 ) +* .. External Subroutines .. + EXTERNAL SLASSQ * .. * .. External Functions .. LOGICAL LSAME, SISNAN EXTERNAL LSAME, SISNAN * .. -* .. External Subroutines .. - EXTERNAL SLASSQ, SCOMBSSQ -* .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. @@ -206,22 +203,15 @@ REAL FUNCTION SLANGB( NORM, N, KL, KU, AB, LDAB, ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. * - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 90 J = 1, N L = MAX( 1, J-KU ) K = KU + 1 - J + L - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL SLASSQ( MIN( N, J+KL )-L+1, AB( K, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL SLASSQ( MIN( N, J+KL )-L+1, AB( K, J ), 1, SCALE, SUM ) 90 CONTINUE - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * SLANGB = VALUE diff --git a/SRC/slange.f b/SRC/slange.f index b1a864e671..79eef87261 100644 --- a/SRC/slange.f +++ b/SRC/slange.f @@ -116,7 +116,6 @@ REAL FUNCTION SLANGE( NORM, M, N, A, LDA, WORK ) * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM INTEGER LDA, M, N @@ -133,13 +132,10 @@ REAL FUNCTION SLANGE( NORM, M, N, A, LDA, WORK ) * .. * .. Local Scalars .. INTEGER I, J - REAL SUM, VALUE, TEMP -* .. -* .. Local Arrays .. - REAL SSQ( 2 ), COLSSQ( 2 ) + REAL SCALE, SUM, VALUE, TEMP * .. * .. External Subroutines .. - EXTERNAL SLASSQ, SCOMBSSQ + EXTERNAL SLASSQ * .. * .. External Functions .. LOGICAL LSAME, SISNAN @@ -195,19 +191,13 @@ REAL FUNCTION SLANGE( NORM, M, N, A, LDA, WORK ) ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. * - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 90 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL SLASSQ( M, A( 1, J ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL SLASSQ( M, A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * SLANGE = VALUE diff --git a/SRC/slanhs.f b/SRC/slanhs.f index 5c44ff1f21..e913806918 100644 --- a/SRC/slanhs.f +++ b/SRC/slanhs.f @@ -110,7 +110,6 @@ REAL FUNCTION SLANHS( NORM, N, A, LDA, WORK ) * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM INTEGER LDA, N @@ -127,18 +126,15 @@ REAL FUNCTION SLANHS( NORM, N, A, LDA, WORK ) * .. * .. Local Scalars .. INTEGER I, J - REAL SUM, VALUE + REAL SCALE, SUM, VALUE * .. -* .. Local Arrays .. - REAL SSQ( 2 ), COLSSQ( 2 ) +* .. External Subroutines .. + EXTERNAL SLASSQ * .. * .. External Functions .. LOGICAL LSAME, SISNAN EXTERNAL LSAME, SISNAN * .. -* .. External Subroutines .. - EXTERNAL SLASSQ, SCOMBSSQ -* .. * .. Intrinsic Functions .. INTRINSIC ABS, MIN, SQRT * .. @@ -189,20 +185,13 @@ REAL FUNCTION SLANHS( NORM, N, A, LDA, WORK ) ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. * - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 90 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL SLASSQ( MIN( N, J+1 ), A( 1, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL SLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * SLANHS = VALUE diff --git a/SRC/slansb.f b/SRC/slansb.f index e751dd773f..eb89d94cb6 100644 --- a/SRC/slansb.f +++ b/SRC/slansb.f @@ -131,7 +131,6 @@ REAL FUNCTION SLANSB( NORM, UPLO, N, K, AB, LDAB, * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER K, LDAB, N @@ -148,18 +147,15 @@ REAL FUNCTION SLANSB( NORM, UPLO, N, K, AB, LDAB, * .. * .. Local Scalars .. INTEGER I, J, L - REAL ABSA, SUM, VALUE + REAL ABSA, SCALE, SUM, VALUE * .. -* .. Local Arrays .. - REAL SSQ( 2 ), COLSSQ( 2 ) +* .. External Subroutines .. + EXTERNAL SLASSQ * .. * .. External Functions .. LOGICAL LSAME, SISNAN EXTERNAL LSAME, SISNAN * .. -* .. External Subroutines .. - EXTERNAL SLASSQ, SCOMBSSQ -* .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. @@ -226,47 +222,29 @@ REAL FUNCTION SLANSB( NORM, UPLO, N, K, AB, LDAB, ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. -* - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE -* -* Sum off-diagonals * + SCALE = ZERO + SUM = ONE IF( K.GT.0 ) THEN IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE CALL SLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ), - $ 1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + $ 1, SCALE, SUM ) 110 CONTINUE L = K + 1 ELSE DO 120 J = 1, N - 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL SLASSQ( MIN( N-J, K ), AB( 2, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL SLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE, + $ SUM ) 120 CONTINUE L = 1 END IF - SSQ( 2 ) = 2*SSQ( 2 ) + SUM = 2*SUM ELSE L = 1 END IF -* -* Sum diagonal -* - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL SLASSQ( N, AB( L, 1 ), LDAB, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + CALL SLASSQ( N, AB( L, 1 ), LDAB, SCALE, SUM ) + VALUE = SCALE*SQRT( SUM ) END IF * SLANSB = VALUE diff --git a/SRC/slansp.f b/SRC/slansp.f index 2d99831e74..2189510a6e 100644 --- a/SRC/slansp.f +++ b/SRC/slansp.f @@ -116,7 +116,6 @@ REAL FUNCTION SLANSP( NORM, UPLO, N, AP, WORK ) * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER N @@ -133,18 +132,15 @@ REAL FUNCTION SLANSP( NORM, UPLO, N, AP, WORK ) * .. * .. Local Scalars .. INTEGER I, J, K - REAL ABSA, SUM, VALUE + REAL ABSA, SCALE, SUM, VALUE * .. -* .. Local Arrays .. - REAL SSQ( 2 ), COLSSQ( 2 ) +* .. External Subroutines .. + EXTERNAL SLASSQ * .. * .. External Functions .. LOGICAL LSAME, SISNAN EXTERNAL LSAME, SISNAN * .. -* .. External Subroutines .. - EXTERNAL SLASSQ, SCOMBSSQ -* .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. @@ -218,48 +214,31 @@ REAL FUNCTION SLANSP( NORM, UPLO, N, AP, WORK ) ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. -* - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE -* -* Sum off-diagonals * + SCALE = ZERO + SUM = ONE K = 2 IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL SLASSQ( J-1, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL SLASSQ( J-1, AP( K ), 1, SCALE, SUM ) K = K + J 110 CONTINUE ELSE DO 120 J = 1, N - 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL SLASSQ( N-J, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL SLASSQ( N-J, AP( K ), 1, SCALE, SUM ) K = K + N - J + 1 120 CONTINUE END IF - SSQ( 2 ) = 2*SSQ( 2 ) -* -* Sum diagonal -* + SUM = 2*SUM K = 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE DO 130 I = 1, N IF( AP( K ).NE.ZERO ) THEN ABSA = ABS( AP( K ) ) - IF( COLSSQ( 1 ).LT.ABSA ) THEN - COLSSQ( 2 ) = ONE + COLSSQ(2)*( COLSSQ(1) / ABSA )**2 - COLSSQ( 1 ) = ABSA + IF( SCALE.LT.ABSA ) THEN + SUM = ONE + SUM*( SCALE / ABSA )**2 + SCALE = ABSA ELSE - COLSSQ( 2 ) = COLSSQ( 2 ) + ( ABSA / COLSSQ( 1 ) )**2 + SUM = SUM + ( ABSA / SCALE )**2 END IF END IF IF( LSAME( UPLO, 'U' ) ) THEN @@ -268,8 +247,7 @@ REAL FUNCTION SLANSP( NORM, UPLO, N, AP, WORK ) K = K + N - I + 1 END IF 130 CONTINUE - CALL SCOMBSSQ( SSQ, COLSSQ ) - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * SLANSP = VALUE diff --git a/SRC/slansy.f b/SRC/slansy.f index 139a5a5e36..4a23a42f2c 100644 --- a/SRC/slansy.f +++ b/SRC/slansy.f @@ -124,7 +124,6 @@ REAL FUNCTION SLANSY( NORM, UPLO, N, A, LDA, WORK ) * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER LDA, N @@ -141,18 +140,15 @@ REAL FUNCTION SLANSY( NORM, UPLO, N, A, LDA, WORK ) * .. * .. Local Scalars .. INTEGER I, J - REAL ABSA, SUM, VALUE + REAL ABSA, SCALE, SUM, VALUE * .. -* .. Local Arrays .. - REAL SSQ( 2 ), COLSSQ( 2 ) +* .. External Subroutines .. + EXTERNAL SLASSQ * .. * .. External Functions .. LOGICAL LSAME, SISNAN EXTERNAL LSAME, SISNAN * .. -* .. External Subroutines .. - EXTERNAL SLASSQ, SCOMBSSQ -* .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. @@ -217,39 +213,21 @@ REAL FUNCTION SLANSY( NORM, UPLO, N, A, LDA, WORK ) ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. -* - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE -* -* Sum off-diagonals * + SCALE = ZERO + SUM = ONE IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL SLASSQ( J-1, A( 1, J ), 1, COLSSQ(1), COLSSQ(2) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL SLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) 110 CONTINUE ELSE DO 120 J = 1, N - 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL SLASSQ( N-J, A( J+1, J ), 1, COLSSQ(1), COLSSQ(2) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL SLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) 120 CONTINUE END IF - SSQ( 2 ) = 2*SSQ( 2 ) -* -* Sum diagonal -* - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL SLASSQ( N, A, LDA+1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + SUM = 2*SUM + CALL SLASSQ( N, A, LDA+1, SCALE, SUM ) + VALUE = SCALE*SQRT( SUM ) END IF * SLANSY = VALUE diff --git a/SRC/slantb.f b/SRC/slantb.f index 064bd83f2e..c29db2416b 100644 --- a/SRC/slantb.f +++ b/SRC/slantb.f @@ -142,7 +142,6 @@ REAL FUNCTION SLANTB( NORM, UPLO, DIAG, N, K, AB, * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO INTEGER K, LDAB, N @@ -160,18 +159,15 @@ REAL FUNCTION SLANTB( NORM, UPLO, DIAG, N, K, AB, * .. Local Scalars .. LOGICAL UDIAG INTEGER I, J, L - REAL SUM, VALUE + REAL SCALE, SUM, VALUE * .. -* .. Local Arrays .. - REAL SSQ( 2 ), COLSSQ( 2 ) +* .. External Subroutines .. + EXTERNAL SLASSQ * .. * .. External Functions .. LOGICAL LSAME, SISNAN EXTERNAL LSAME, SISNAN * .. -* .. External Subroutines .. - EXTERNAL SLASSQ, SCOMBSSQ -* .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. @@ -312,61 +308,46 @@ REAL FUNCTION SLANTB( NORM, UPLO, DIAG, N, K, AB, ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. * IF( LSAME( UPLO, 'U' ) ) THEN IF( LSAME( DIAG, 'U' ) ) THEN - SSQ( 1 ) = ONE - SSQ( 2 ) = N + SCALE = ONE + SUM = N IF( K.GT.0 ) THEN DO 280 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE CALL SLASSQ( MIN( J-1, K ), - $ AB( MAX( K+2-J, 1 ), J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + $ AB( MAX( K+2-J, 1 ), J ), 1, SCALE, + $ SUM ) 280 CONTINUE END IF ELSE - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 290 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE CALL SLASSQ( MIN( J, K+1 ), AB( MAX( K+2-J, 1 ), J ), - $ 1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + $ 1, SCALE, SUM ) 290 CONTINUE END IF ELSE IF( LSAME( DIAG, 'U' ) ) THEN - SSQ( 1 ) = ONE - SSQ( 2 ) = N + SCALE = ONE + SUM = N IF( K.GT.0 ) THEN DO 300 J = 1, N - 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL SLASSQ( MIN( N-J, K ), AB( 2, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL SLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE, + $ SUM ) 300 CONTINUE END IF ELSE - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 310 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL SLASSQ( MIN( N-J+1, K+1 ), AB( 1, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL SLASSQ( MIN( N-J+1, K+1 ), AB( 1, J ), 1, SCALE, + $ SUM ) 310 CONTINUE END IF END IF - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * SLANTB = VALUE diff --git a/SRC/slantp.f b/SRC/slantp.f index fa65736fe8..00fe42a53f 100644 --- a/SRC/slantp.f +++ b/SRC/slantp.f @@ -126,7 +126,6 @@ REAL FUNCTION SLANTP( NORM, UPLO, DIAG, N, AP, WORK ) * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO INTEGER N @@ -144,18 +143,15 @@ REAL FUNCTION SLANTP( NORM, UPLO, DIAG, N, AP, WORK ) * .. Local Scalars .. LOGICAL UDIAG INTEGER I, J, K - REAL SUM, VALUE + REAL SCALE, SUM, VALUE * .. -* .. Local Arrays .. - REAL SSQ( 2 ), COLSSQ( 2 ) +* .. External Subroutines .. + EXTERNAL SLASSQ * .. * .. External Functions .. LOGICAL LSAME, SISNAN EXTERNAL LSAME, SISNAN * .. -* .. External Subroutines .. - EXTERNAL SLASSQ, SCOMBSSQ -* .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. @@ -307,64 +303,45 @@ REAL FUNCTION SLANTP( NORM, UPLO, DIAG, N, AP, WORK ) ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. * IF( LSAME( UPLO, 'U' ) ) THEN IF( LSAME( DIAG, 'U' ) ) THEN - SSQ( 1 ) = ONE - SSQ( 2 ) = N + SCALE = ONE + SUM = N K = 2 DO 280 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL SLASSQ( J-1, AP( K ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL SLASSQ( J-1, AP( K ), 1, SCALE, SUM ) K = K + J 280 CONTINUE ELSE - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE K = 1 DO 290 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL SLASSQ( J, AP( K ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL SLASSQ( J, AP( K ), 1, SCALE, SUM ) K = K + J 290 CONTINUE END IF ELSE IF( LSAME( DIAG, 'U' ) ) THEN - SSQ( 1 ) = ONE - SSQ( 2 ) = N + SCALE = ONE + SUM = N K = 2 DO 300 J = 1, N - 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL SLASSQ( N-J, AP( K ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL SLASSQ( N-J, AP( K ), 1, SCALE, SUM ) K = K + N - J + 1 300 CONTINUE ELSE - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE K = 1 DO 310 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL SLASSQ( N-J+1, AP( K ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL SLASSQ( N-J+1, AP( K ), 1, SCALE, SUM ) K = K + N - J + 1 310 CONTINUE END IF END IF - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * SLANTP = VALUE diff --git a/SRC/slantr.f b/SRC/slantr.f index c77cc865f4..384f58550b 100644 --- a/SRC/slantr.f +++ b/SRC/slantr.f @@ -143,7 +143,6 @@ REAL FUNCTION SLANTR( NORM, UPLO, DIAG, M, N, A, LDA, * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO INTEGER LDA, M, N @@ -161,18 +160,15 @@ REAL FUNCTION SLANTR( NORM, UPLO, DIAG, M, N, A, LDA, * .. Local Scalars .. LOGICAL UDIAG INTEGER I, J - REAL SUM, VALUE + REAL SCALE, SUM, VALUE * .. -* .. Local Arrays .. - REAL SSQ( 2 ), COLSSQ( 2 ) +* .. External Subroutines .. + EXTERNAL SLASSQ * .. * .. External Functions .. LOGICAL LSAME, SISNAN EXTERNAL LSAME, SISNAN * .. -* .. External Subroutines .. - EXTERNAL SLASSQ, SCOMBSSQ -* .. * .. Intrinsic Functions .. INTRINSIC ABS, MIN, SQRT * .. @@ -312,56 +308,38 @@ REAL FUNCTION SLANTR( NORM, UPLO, DIAG, M, N, A, LDA, ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. * IF( LSAME( UPLO, 'U' ) ) THEN IF( LSAME( DIAG, 'U' ) ) THEN - SSQ( 1 ) = ONE - SSQ( 2 ) = MIN( M, N ) + SCALE = ONE + SUM = MIN( M, N ) DO 290 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL SLASSQ( MIN( M, J-1 ), A( 1, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL SLASSQ( MIN( M, J-1 ), A( 1, J ), 1, SCALE, SUM ) 290 CONTINUE ELSE - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 300 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL SLASSQ( MIN( M, J ), A( 1, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL SLASSQ( MIN( M, J ), A( 1, J ), 1, SCALE, SUM ) 300 CONTINUE END IF ELSE IF( LSAME( DIAG, 'U' ) ) THEN - SSQ( 1 ) = ONE - SSQ( 2 ) = MIN( M, N ) + SCALE = ONE + SUM = MIN( M, N ) DO 310 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL SLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL SLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE, + $ SUM ) 310 CONTINUE ELSE - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 320 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL SLASSQ( M-J+1, A( J, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL SCOMBSSQ( SSQ, COLSSQ ) + CALL SLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM ) 320 CONTINUE END IF END IF - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * SLANTR = VALUE diff --git a/SRC/zlangb.f b/SRC/zlangb.f index 37cb77e65f..25089ee58b 100644 --- a/SRC/zlangb.f +++ b/SRC/zlangb.f @@ -127,7 +127,6 @@ DOUBLE PRECISION FUNCTION ZLANGB( NORM, N, KL, KU, AB, LDAB, * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM INTEGER KL, KU, LDAB, N @@ -145,17 +144,14 @@ DOUBLE PRECISION FUNCTION ZLANGB( NORM, N, KL, KU, AB, LDAB, * .. * .. Local Scalars .. INTEGER I, J, K, L - DOUBLE PRECISION SUM, VALUE, TEMP -* .. -* .. Local Arrays .. - DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) + DOUBLE PRECISION SCALE, SUM, VALUE, TEMP * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. External Subroutines .. - EXTERNAL ZLASSQ, DCOMBSSQ + EXTERNAL ZLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT @@ -208,22 +204,15 @@ DOUBLE PRECISION FUNCTION ZLANGB( NORM, N, KL, KU, AB, LDAB, ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. * - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 90 J = 1, N L = MAX( 1, J-KU ) K = KU + 1 - J + L - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL ZLASSQ( MIN( N, J+KL )-L+1, AB( K, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL ZLASSQ( MIN( N, J+KL )-L+1, AB( K, J ), 1, SCALE, SUM ) 90 CONTINUE - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * ZLANGB = VALUE diff --git a/SRC/zlange.f b/SRC/zlange.f index ab76455087..d68560e995 100644 --- a/SRC/zlange.f +++ b/SRC/zlange.f @@ -117,7 +117,6 @@ DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK ) * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM INTEGER LDA, M, N @@ -135,17 +134,14 @@ DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK ) * .. * .. Local Scalars .. INTEGER I, J - DOUBLE PRECISION SUM, VALUE, TEMP -* .. -* .. Local Arrays .. - DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) + DOUBLE PRECISION SCALE, SUM, VALUE, TEMP * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. External Subroutines .. - EXTERNAL ZLASSQ, DCOMBSSQ + EXTERNAL ZLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MIN, SQRT @@ -197,19 +193,13 @@ DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK ) ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. * - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 90 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL ZLASSQ( M, A( 1, J ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL ZLASSQ( M, A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * ZLANGE = VALUE diff --git a/SRC/zlanhb.f b/SRC/zlanhb.f index 289b6c5f1c..52f46dbc6e 100644 --- a/SRC/zlanhb.f +++ b/SRC/zlanhb.f @@ -134,7 +134,6 @@ DOUBLE PRECISION FUNCTION ZLANHB( NORM, UPLO, N, K, AB, LDAB, * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER K, LDAB, N @@ -152,17 +151,14 @@ DOUBLE PRECISION FUNCTION ZLANHB( NORM, UPLO, N, K, AB, LDAB, * .. * .. Local Scalars .. INTEGER I, J, L - DOUBLE PRECISION ABSA, SUM, VALUE -* .. -* .. Local Arrays .. - DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) + DOUBLE PRECISION ABSA, SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. External Subroutines .. - EXTERNAL ZLASSQ, DCOMBSSQ + EXTERNAL ZLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN, SQRT @@ -234,57 +230,39 @@ DOUBLE PRECISION FUNCTION ZLANHB( NORM, UPLO, N, K, AB, LDAB, ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. -* - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE -* -* Sum off-diagonals * + SCALE = ZERO + SUM = ONE IF( K.GT.0 ) THEN IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE CALL ZLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ), - $ 1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + $ 1, SCALE, SUM ) 110 CONTINUE L = K + 1 ELSE DO 120 J = 1, N - 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL ZLASSQ( MIN( N-J, K ), AB( 2, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL ZLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE, + $ SUM ) 120 CONTINUE L = 1 END IF - SSQ( 2 ) = 2*SSQ( 2 ) + SUM = 2*SUM ELSE L = 1 END IF -* -* Sum diagonal -* - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE DO 130 J = 1, N IF( DBLE( AB( L, J ) ).NE.ZERO ) THEN ABSA = ABS( DBLE( AB( L, J ) ) ) - IF( COLSSQ( 1 ).LT.ABSA ) THEN - COLSSQ( 2 ) = ONE + COLSSQ(2)*( COLSSQ(1) / ABSA )**2 - COLSSQ( 1 ) = ABSA + IF( SCALE.LT.ABSA ) THEN + SUM = ONE + SUM*( SCALE / ABSA )**2 + SCALE = ABSA ELSE - COLSSQ( 2 ) = COLSSQ( 2 ) + ( ABSA / COLSSQ( 1 ) )**2 + SUM = SUM + ( ABSA / SCALE )**2 END IF END IF 130 CONTINUE - CALL DCOMBSSQ( SSQ, COLSSQ ) - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * ZLANHB = VALUE diff --git a/SRC/zlanhe.f b/SRC/zlanhe.f index a48d177280..bbb4843ffd 100644 --- a/SRC/zlanhe.f +++ b/SRC/zlanhe.f @@ -126,7 +126,6 @@ DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK ) * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER LDA, N @@ -144,17 +143,14 @@ DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK ) * .. * .. Local Scalars .. INTEGER I, J - DOUBLE PRECISION ABSA, SUM, VALUE -* .. -* .. Local Arrays .. - DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) + DOUBLE PRECISION ABSA, SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. External Subroutines .. - EXTERNAL ZLASSQ, DCOMBSSQ + EXTERNAL ZLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, SQRT @@ -224,48 +220,31 @@ DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK ) ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. -* - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE -* -* Sum off-diagonals * + SCALE = ZERO + SUM = ONE IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL ZLASSQ( J-1, A( 1, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL ZLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) 110 CONTINUE ELSE DO 120 J = 1, N - 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL ZLASSQ( N-J, A( J+1, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL ZLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) 120 CONTINUE END IF - SSQ( 2 ) = 2*SSQ( 2 ) -* -* Sum diagonal -* + SUM = 2*SUM DO 130 I = 1, N IF( DBLE( A( I, I ) ).NE.ZERO ) THEN ABSA = ABS( DBLE( A( I, I ) ) ) - IF( SSQ( 1 ).LT.ABSA ) THEN - SSQ( 2 ) = ONE + SSQ( 2 )*( SSQ( 1 ) / ABSA )**2 - SSQ( 1 ) = ABSA + IF( SCALE.LT.ABSA ) THEN + SUM = ONE + SUM*( SCALE / ABSA )**2 + SCALE = ABSA ELSE - SSQ( 2 ) = SSQ( 2 ) + ( ABSA / SSQ( 1 ) )**2 + SUM = SUM + ( ABSA / SCALE )**2 END IF END IF 130 CONTINUE - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * ZLANHE = VALUE diff --git a/SRC/zlanhp.f b/SRC/zlanhp.f index cd947ae9e5..ac45467d0e 100644 --- a/SRC/zlanhp.f +++ b/SRC/zlanhp.f @@ -119,7 +119,6 @@ DOUBLE PRECISION FUNCTION ZLANHP( NORM, UPLO, N, AP, WORK ) * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER N @@ -137,17 +136,14 @@ DOUBLE PRECISION FUNCTION ZLANHP( NORM, UPLO, N, AP, WORK ) * .. * .. Local Scalars .. INTEGER I, J, K - DOUBLE PRECISION ABSA, SUM, VALUE -* .. -* .. Local Arrays .. - DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) + DOUBLE PRECISION ABSA, SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. External Subroutines .. - EXTERNAL ZLASSQ, DCOMBSSQ + EXTERNAL ZLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, SQRT @@ -226,48 +222,31 @@ DOUBLE PRECISION FUNCTION ZLANHP( NORM, UPLO, N, AP, WORK ) ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. -* - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE -* -* Sum off-diagonals * + SCALE = ZERO + SUM = ONE K = 2 IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL ZLASSQ( J-1, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL ZLASSQ( J-1, AP( K ), 1, SCALE, SUM ) K = K + J 110 CONTINUE ELSE DO 120 J = 1, N - 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL ZLASSQ( N-J, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL ZLASSQ( N-J, AP( K ), 1, SCALE, SUM ) K = K + N - J + 1 120 CONTINUE END IF - SSQ( 2 ) = 2*SSQ( 2 ) -* -* Sum diagonal -* + SUM = 2*SUM K = 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE DO 130 I = 1, N IF( DBLE( AP( K ) ).NE.ZERO ) THEN ABSA = ABS( DBLE( AP( K ) ) ) - IF( COLSSQ( 1 ).LT.ABSA ) THEN - COLSSQ( 2 ) = ONE + COLSSQ(2)*( COLSSQ(1) / ABSA )**2 - COLSSQ( 1 ) = ABSA + IF( SCALE.LT.ABSA ) THEN + SUM = ONE + SUM*( SCALE / ABSA )**2 + SCALE = ABSA ELSE - COLSSQ( 2 ) = COLSSQ( 2 ) + ( ABSA / COLSSQ( 1 ) )**2 + SUM = SUM + ( ABSA / SCALE )**2 END IF END IF IF( LSAME( UPLO, 'U' ) ) THEN @@ -276,8 +255,7 @@ DOUBLE PRECISION FUNCTION ZLANHP( NORM, UPLO, N, AP, WORK ) K = K + N - I + 1 END IF 130 CONTINUE - CALL DCOMBSSQ( SSQ, COLSSQ ) - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * ZLANHP = VALUE diff --git a/SRC/zlanhs.f b/SRC/zlanhs.f index 73cf4c4bec..d6725804f7 100644 --- a/SRC/zlanhs.f +++ b/SRC/zlanhs.f @@ -111,7 +111,6 @@ DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK ) * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM INTEGER LDA, N @@ -129,17 +128,14 @@ DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK ) * .. * .. Local Scalars .. INTEGER I, J - DOUBLE PRECISION SUM, VALUE -* .. -* .. Local Arrays .. - DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) + DOUBLE PRECISION SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. External Subroutines .. - EXTERNAL ZLASSQ, DCOMBSSQ + EXTERNAL ZLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MIN, SQRT @@ -191,20 +187,13 @@ DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK ) ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. * - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 90 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL ZLASSQ( MIN( N, J+1 ), A( 1, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL ZLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * ZLANHS = VALUE diff --git a/SRC/zlansb.f b/SRC/zlansb.f index 3f3dad7516..ded6d2b7ea 100644 --- a/SRC/zlansb.f +++ b/SRC/zlansb.f @@ -132,7 +132,6 @@ DOUBLE PRECISION FUNCTION ZLANSB( NORM, UPLO, N, K, AB, LDAB, * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER K, LDAB, N @@ -150,17 +149,14 @@ DOUBLE PRECISION FUNCTION ZLANSB( NORM, UPLO, N, K, AB, LDAB, * .. * .. Local Scalars .. INTEGER I, J, L - DOUBLE PRECISION ABSA, SUM, VALUE -* .. -* .. Local Arrays .. - DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) + DOUBLE PRECISION ABSA, SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. External Subroutines .. - EXTERNAL ZLASSQ, DCOMBSSQ + EXTERNAL ZLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT @@ -228,47 +224,29 @@ DOUBLE PRECISION FUNCTION ZLANSB( NORM, UPLO, N, K, AB, LDAB, ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. -* - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE -* -* Sum off-diagonals * + SCALE = ZERO + SUM = ONE IF( K.GT.0 ) THEN IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE CALL ZLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ), - $ 1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + $ 1, SCALE, SUM ) 110 CONTINUE L = K + 1 ELSE DO 120 J = 1, N - 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL ZLASSQ( MIN( N-J, K ), AB( 2, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL ZLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE, + $ SUM ) 120 CONTINUE L = 1 END IF - SSQ( 2 ) = 2*SSQ( 2 ) + SUM = 2*SUM ELSE L = 1 END IF -* -* Sum diagonal -* - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL ZLASSQ( N, AB( L, 1 ), LDAB, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + CALL ZLASSQ( N, AB( L, 1 ), LDAB, SCALE, SUM ) + VALUE = SCALE*SQRT( SUM ) END IF * ZLANSB = VALUE diff --git a/SRC/zlansp.f b/SRC/zlansp.f index e294c03b1c..b565a1e1c0 100644 --- a/SRC/zlansp.f +++ b/SRC/zlansp.f @@ -117,7 +117,6 @@ DOUBLE PRECISION FUNCTION ZLANSP( NORM, UPLO, N, AP, WORK ) * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER N @@ -135,17 +134,14 @@ DOUBLE PRECISION FUNCTION ZLANSP( NORM, UPLO, N, AP, WORK ) * .. * .. Local Scalars .. INTEGER I, J, K - DOUBLE PRECISION ABSA, SUM, VALUE -* .. -* .. Local Arrays .. - DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) + DOUBLE PRECISION ABSA, SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. External Subroutines .. - EXTERNAL ZLASSQ, DCOMBSSQ + EXTERNAL ZLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG, SQRT @@ -220,57 +216,40 @@ DOUBLE PRECISION FUNCTION ZLANSP( NORM, UPLO, N, AP, WORK ) ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. -* - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE -* -* Sum off-diagonals * + SCALE = ZERO + SUM = ONE K = 2 IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL ZLASSQ( J-1, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL ZLASSQ( J-1, AP( K ), 1, SCALE, SUM ) K = K + J 110 CONTINUE ELSE DO 120 J = 1, N - 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL ZLASSQ( N-J, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL ZLASSQ( N-J, AP( K ), 1, SCALE, SUM ) K = K + N - J + 1 120 CONTINUE END IF - SSQ( 2 ) = 2*SSQ( 2 ) -* -* Sum diagonal -* + SUM = 2*SUM K = 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE DO 130 I = 1, N IF( DBLE( AP( K ) ).NE.ZERO ) THEN ABSA = ABS( DBLE( AP( K ) ) ) - IF( COLSSQ( 1 ).LT.ABSA ) THEN - COLSSQ( 2 ) = ONE + COLSSQ(2)*( COLSSQ(1) / ABSA )**2 - COLSSQ( 1 ) = ABSA + IF( SCALE.LT.ABSA ) THEN + SUM = ONE + SUM*( SCALE / ABSA )**2 + SCALE = ABSA ELSE - COLSSQ( 2 ) = COLSSQ( 2 ) + ( ABSA / COLSSQ( 1 ) )**2 + SUM = SUM + ( ABSA / SCALE )**2 END IF END IF IF( DIMAG( AP( K ) ).NE.ZERO ) THEN ABSA = ABS( DIMAG( AP( K ) ) ) - IF( COLSSQ( 1 ).LT.ABSA ) THEN - COLSSQ( 2 ) = ONE + COLSSQ(2)*( COLSSQ(1) / ABSA )**2 - COLSSQ( 1 ) = ABSA + IF( SCALE.LT.ABSA ) THEN + SUM = ONE + SUM*( SCALE / ABSA )**2 + SCALE = ABSA ELSE - COLSSQ( 2 ) = COLSSQ( 2 ) + ( ABSA / COLSSQ( 1 ) )**2 + SUM = SUM + ( ABSA / SCALE )**2 END IF END IF IF( LSAME( UPLO, 'U' ) ) THEN @@ -279,8 +258,7 @@ DOUBLE PRECISION FUNCTION ZLANSP( NORM, UPLO, N, AP, WORK ) K = K + N - I + 1 END IF 130 CONTINUE - CALL DCOMBSSQ( SSQ, COLSSQ ) - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * ZLANSP = VALUE diff --git a/SRC/zlansy.f b/SRC/zlansy.f index 09d13e0616..fd28bda204 100644 --- a/SRC/zlansy.f +++ b/SRC/zlansy.f @@ -125,7 +125,6 @@ DOUBLE PRECISION FUNCTION ZLANSY( NORM, UPLO, N, A, LDA, WORK ) * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER LDA, N @@ -143,17 +142,14 @@ DOUBLE PRECISION FUNCTION ZLANSY( NORM, UPLO, N, A, LDA, WORK ) * .. * .. Local Scalars .. INTEGER I, J - DOUBLE PRECISION ABSA, SUM, VALUE -* .. -* .. Local Arrays .. - DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) + DOUBLE PRECISION ABSA, SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. External Subroutines .. - EXTERNAL ZLASSQ, DCOMBSSQ + EXTERNAL ZLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT @@ -219,39 +215,21 @@ DOUBLE PRECISION FUNCTION ZLANSY( NORM, UPLO, N, A, LDA, WORK ) ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. -* - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE -* -* Sum off-diagonals * + SCALE = ZERO + SUM = ONE IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL ZLASSQ( J-1, A( 1, J ), 1, COLSSQ(1), COLSSQ(2) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL ZLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) 110 CONTINUE ELSE DO 120 J = 1, N - 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL ZLASSQ( N-J, A( J+1, J ), 1, COLSSQ(1), COLSSQ(2) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL ZLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) 120 CONTINUE END IF - SSQ( 2 ) = 2*SSQ( 2 ) -* -* Sum diagonal -* - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL ZLASSQ( N, A, LDA+1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + SUM = 2*SUM + CALL ZLASSQ( N, A, LDA+1, SCALE, SUM ) + VALUE = SCALE*SQRT( SUM ) END IF * ZLANSY = VALUE diff --git a/SRC/zlantb.f b/SRC/zlantb.f index e8edfe18f2..13014ceaca 100644 --- a/SRC/zlantb.f +++ b/SRC/zlantb.f @@ -143,7 +143,6 @@ DOUBLE PRECISION FUNCTION ZLANTB( NORM, UPLO, DIAG, N, K, AB, * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO INTEGER K, LDAB, N @@ -162,17 +161,14 @@ DOUBLE PRECISION FUNCTION ZLANTB( NORM, UPLO, DIAG, N, K, AB, * .. Local Scalars .. LOGICAL UDIAG INTEGER I, J, L - DOUBLE PRECISION SUM, VALUE -* .. -* .. Local Arrays .. - DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) + DOUBLE PRECISION SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. External Subroutines .. - EXTERNAL ZLASSQ, DCOMBSSQ + EXTERNAL ZLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT @@ -314,61 +310,46 @@ DOUBLE PRECISION FUNCTION ZLANTB( NORM, UPLO, DIAG, N, K, AB, ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. * IF( LSAME( UPLO, 'U' ) ) THEN IF( LSAME( DIAG, 'U' ) ) THEN - SSQ( 1 ) = ONE - SSQ( 2 ) = N + SCALE = ONE + SUM = N IF( K.GT.0 ) THEN DO 280 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE CALL ZLASSQ( MIN( J-1, K ), - $ AB( MAX( K+2-J, 1 ), J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + $ AB( MAX( K+2-J, 1 ), J ), 1, SCALE, + $ SUM ) 280 CONTINUE END IF ELSE - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 290 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE CALL ZLASSQ( MIN( J, K+1 ), AB( MAX( K+2-J, 1 ), J ), - $ 1, COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + $ 1, SCALE, SUM ) 290 CONTINUE END IF ELSE IF( LSAME( DIAG, 'U' ) ) THEN - SSQ( 1 ) = ONE - SSQ( 2 ) = N + SCALE = ONE + SUM = N IF( K.GT.0 ) THEN DO 300 J = 1, N - 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL ZLASSQ( MIN( N-J, K ), AB( 2, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL ZLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE, + $ SUM ) 300 CONTINUE END IF ELSE - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 310 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL ZLASSQ( MIN( N-J+1, K+1 ), AB( 1, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL ZLASSQ( MIN( N-J+1, K+1 ), AB( 1, J ), 1, SCALE, + $ SUM ) 310 CONTINUE END IF END IF - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * ZLANTB = VALUE diff --git a/SRC/zlantp.f b/SRC/zlantp.f index 48fe7c6013..af2b2cf75f 100644 --- a/SRC/zlantp.f +++ b/SRC/zlantp.f @@ -127,7 +127,6 @@ DOUBLE PRECISION FUNCTION ZLANTP( NORM, UPLO, DIAG, N, AP, WORK ) * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO INTEGER N @@ -146,17 +145,14 @@ DOUBLE PRECISION FUNCTION ZLANTP( NORM, UPLO, DIAG, N, AP, WORK ) * .. Local Scalars .. LOGICAL UDIAG INTEGER I, J, K - DOUBLE PRECISION SUM, VALUE -* .. -* .. Local Arrays .. - DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) + DOUBLE PRECISION SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. External Subroutines .. - EXTERNAL ZLASSQ, DCOMBSSQ + EXTERNAL ZLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT @@ -309,64 +305,45 @@ DOUBLE PRECISION FUNCTION ZLANTP( NORM, UPLO, DIAG, N, AP, WORK ) ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. * IF( LSAME( UPLO, 'U' ) ) THEN IF( LSAME( DIAG, 'U' ) ) THEN - SSQ( 1 ) = ONE - SSQ( 2 ) = N + SCALE = ONE + SUM = N K = 2 DO 280 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL ZLASSQ( J-1, AP( K ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL ZLASSQ( J-1, AP( K ), 1, SCALE, SUM ) K = K + J 280 CONTINUE ELSE - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE K = 1 DO 290 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL ZLASSQ( J, AP( K ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL ZLASSQ( J, AP( K ), 1, SCALE, SUM ) K = K + J 290 CONTINUE END IF ELSE IF( LSAME( DIAG, 'U' ) ) THEN - SSQ( 1 ) = ONE - SSQ( 2 ) = N + SCALE = ONE + SUM = N K = 2 DO 300 J = 1, N - 1 - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL ZLASSQ( N-J, AP( K ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL ZLASSQ( N-J, AP( K ), 1, SCALE, SUM ) K = K + N - J + 1 300 CONTINUE ELSE - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE K = 1 DO 310 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL ZLASSQ( N-J+1, AP( K ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL ZLASSQ( N-J+1, AP( K ), 1, SCALE, SUM ) K = K + N - J + 1 310 CONTINUE END IF END IF - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * ZLANTP = VALUE diff --git a/SRC/zlantr.f b/SRC/zlantr.f index 62cd3f3451..bd4b5da7c2 100644 --- a/SRC/zlantr.f +++ b/SRC/zlantr.f @@ -144,7 +144,6 @@ DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A, LDA, * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * - IMPLICIT NONE * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO INTEGER LDA, M, N @@ -163,17 +162,14 @@ DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A, LDA, * .. Local Scalars .. LOGICAL UDIAG INTEGER I, J - DOUBLE PRECISION SUM, VALUE -* .. -* .. Local Arrays .. - DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) + DOUBLE PRECISION SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. External Subroutines .. - EXTERNAL ZLASSQ, DCOMBSSQ + EXTERNAL ZLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MIN, SQRT @@ -314,56 +310,38 @@ DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A, LDA, ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). -* SSQ(1) is scale -* SSQ(2) is sum-of-squares -* For better accuracy, sum each column separately. * IF( LSAME( UPLO, 'U' ) ) THEN IF( LSAME( DIAG, 'U' ) ) THEN - SSQ( 1 ) = ONE - SSQ( 2 ) = MIN( M, N ) + SCALE = ONE + SUM = MIN( M, N ) DO 290 J = 2, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL ZLASSQ( MIN( M, J-1 ), A( 1, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL ZLASSQ( MIN( M, J-1 ), A( 1, J ), 1, SCALE, SUM ) 290 CONTINUE ELSE - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 300 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL ZLASSQ( MIN( M, J ), A( 1, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL ZLASSQ( MIN( M, J ), A( 1, J ), 1, SCALE, SUM ) 300 CONTINUE END IF ELSE IF( LSAME( DIAG, 'U' ) ) THEN - SSQ( 1 ) = ONE - SSQ( 2 ) = MIN( M, N ) + SCALE = ONE + SUM = MIN( M, N ) DO 310 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL ZLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL ZLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE, + $ SUM ) 310 CONTINUE ELSE - SSQ( 1 ) = ZERO - SSQ( 2 ) = ONE + SCALE = ZERO + SUM = ONE DO 320 J = 1, N - COLSSQ( 1 ) = ZERO - COLSSQ( 2 ) = ONE - CALL ZLASSQ( M-J+1, A( J, J ), 1, - $ COLSSQ( 1 ), COLSSQ( 2 ) ) - CALL DCOMBSSQ( SSQ, COLSSQ ) + CALL ZLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM ) 320 CONTINUE END IF END IF - VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) + VALUE = SCALE*SQRT( SUM ) END IF * ZLANTR = VALUE From e7d572c5234e2b4789cde63dbeb82019ba4b19bb Mon Sep 17 00:00:00 2001 From: "weslley.spereira" Date: Fri, 18 Jun 2021 19:37:07 -0300 Subject: [PATCH 2/4] Improve xSLASSQ by removing one operation like sqrt( sumsq )**2 !> If scale * sqrt( sumsq ) > tbig then !> we now require: scale >= sqrt( TINY*EPS ) / sbig on entry, !> and if scale * sqrt( sumsq ) < tsml then !> we now require: scale <= sqrt( HUGE ) / ssml on entry, !> where !> tbig -- upper threshold for values whose square is representable; !> sbig -- scaling constant for big numbers; \see la_constants.f90 !> tsml -- lower threshold for values whose square is representable; !> ssml -- scaling constant for small numbers; \see la_constants.f90 !> and !> TINY*EPS -- tiniest representable number; !> HUGE -- biggest representable number. --- SRC/classq.f90 | 25 +++++++++++++++++++------ SRC/dlassq.f90 | 25 +++++++++++++++++++------ SRC/slassq.f90 | 25 +++++++++++++++++++------ SRC/zlassq.f90 | 25 +++++++++++++++++++------ 4 files changed, 76 insertions(+), 24 deletions(-) diff --git a/SRC/classq.f90 b/SRC/classq.f90 index bbf3baf29d..c6b01fa263 100644 --- a/SRC/classq.f90 +++ b/SRC/classq.f90 @@ -39,13 +39,24 @@ !> ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, !> !> where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is -!> assumed to be non-negative and scl returns the value -!> -!> scl = max( scale, abs( x( i ) ) ). +!> assumed to be non-negative. !> !> scale and sumsq must be supplied in SCALE and SUMSQ and !> scl and smsq are overwritten on SCALE and SUMSQ respectively. !> +!> If scale * sqrt( sumsq ) > tbig then +!> we require: scale >= sqrt( TINY*EPS ) / sbig on entry, +!> and if scale * sqrt( sumsq ) < tsml then +!> we require: scale <= sqrt( HUGE ) / ssml on entry, +!> where +!> tbig -- upper threshold for values whose square is representable; +!> sbig -- scaling constant for big numbers; \see la_constants.f90 +!> tsml -- lower threshold for values whose square is representable; +!> ssml -- scaling constant for small numbers; \see la_constants.f90 +!> and +!> TINY*EPS -- tiniest representable number; +!> HUGE -- biggest representable number. +!> !> \endverbatim ! ! Arguments: @@ -198,12 +209,14 @@ subroutine CLASSQ( n, x, incx, scl, sumsq ) if( sumsq > zero ) then ax = scl*sqrt( sumsq ) if (ax > tbig) then - abig = abig + (ax*sbig)**2 +! We assume scl >= sqrt( TINY*EPS ) / sbig + abig = abig + (scl*sbig)**2 * sumsq notbig = .false. else if (ax < tsml) then - if (notbig) asml = asml + (ax*ssml)**2 +! We assume scl <= sqrt( HUGE ) / ssml + if (notbig) asml = asml + (scl*ssml)**2 * sumsq else - amed = amed + ax**2 + amed = amed + scl**2 * sumsq end if end if ! diff --git a/SRC/dlassq.f90 b/SRC/dlassq.f90 index 95797018e8..de6225589d 100644 --- a/SRC/dlassq.f90 +++ b/SRC/dlassq.f90 @@ -39,13 +39,24 @@ !> ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, !> !> where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is -!> assumed to be non-negative and scl returns the value -!> -!> scl = max( scale, abs( x( i ) ) ). +!> assumed to be non-negative. !> !> scale and sumsq must be supplied in SCALE and SUMSQ and !> scl and smsq are overwritten on SCALE and SUMSQ respectively. !> +!> If scale * sqrt( sumsq ) > tbig then +!> we require: scale >= sqrt( TINY*EPS ) / sbig on entry, +!> and if scale * sqrt( sumsq ) < tsml then +!> we require: scale <= sqrt( HUGE ) / ssml on entry, +!> where +!> tbig -- upper threshold for values whose square is representable; +!> sbig -- scaling constant for big numbers; \see la_constants.f90 +!> tsml -- lower threshold for values whose square is representable; +!> ssml -- scaling constant for small numbers; \see la_constants.f90 +!> and +!> TINY*EPS -- tiniest representable number; +!> HUGE -- biggest representable number. +!> !> \endverbatim ! ! Arguments: @@ -189,12 +200,14 @@ subroutine DLASSQ( n, x, incx, scl, sumsq ) if( sumsq > zero ) then ax = scl*sqrt( sumsq ) if (ax > tbig) then - abig = abig + (ax*sbig)**2 +! We assume scl >= sqrt( TINY*EPS ) / sbig + abig = abig + (scl*sbig)**2 * sumsq notbig = .false. else if (ax < tsml) then - if (notbig) asml = asml + (ax*ssml)**2 +! We assume scl <= sqrt( HUGE ) / ssml + if (notbig) asml = asml + (scl*ssml)**2 * sumsq else - amed = amed + ax**2 + amed = amed + scl**2 * sumsq end if end if ! diff --git a/SRC/slassq.f90 b/SRC/slassq.f90 index 407c1e0397..55fd829a51 100644 --- a/SRC/slassq.f90 +++ b/SRC/slassq.f90 @@ -39,13 +39,24 @@ !> ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, !> !> where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is -!> assumed to be non-negative and scl returns the value -!> -!> scl = max( scale, abs( x( i ) ) ). +!> assumed to be non-negative. !> !> scale and sumsq must be supplied in SCALE and SUMSQ and !> scl and smsq are overwritten on SCALE and SUMSQ respectively. !> +!> If scale * sqrt( sumsq ) > tbig then +!> we require: scale >= sqrt( TINY*EPS ) / sbig on entry, +!> and if scale * sqrt( sumsq ) < tsml then +!> we require: scale <= sqrt( HUGE ) / ssml on entry, +!> where +!> tbig -- upper threshold for values whose square is representable; +!> sbig -- scaling constant for big numbers; \see la_constants.f90 +!> tsml -- lower threshold for values whose square is representable; +!> ssml -- scaling constant for small numbers; \see la_constants.f90 +!> and +!> TINY*EPS -- tiniest representable number; +!> HUGE -- biggest representable number. +!> !> \endverbatim ! ! Arguments: @@ -189,12 +200,14 @@ subroutine SLASSQ( n, x, incx, scl, sumsq ) if( sumsq > zero ) then ax = scl*sqrt( sumsq ) if (ax > tbig) then - abig = abig + (ax*sbig)**2 +! We assume scl >= sqrt( TINY*EPS ) / sbig + abig = abig + (scl*sbig)**2 * sumsq notbig = .false. else if (ax < tsml) then - if (notbig) asml = asml + (ax*ssml)**2 +! We assume scl <= sqrt( HUGE ) / ssml + if (notbig) asml = asml + (scl*ssml)**2 * sumsq else - amed = amed + ax**2 + amed = amed + scl**2 * sumsq end if end if ! diff --git a/SRC/zlassq.f90 b/SRC/zlassq.f90 index 7d25cf1d80..fe1bb5e45d 100644 --- a/SRC/zlassq.f90 +++ b/SRC/zlassq.f90 @@ -39,13 +39,24 @@ !> ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, !> !> where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is -!> assumed to be non-negative and scl returns the value -!> -!> scl = max( scale, abs( x( i ) ) ). +!> assumed to be non-negative. !> !> scale and sumsq must be supplied in SCALE and SUMSQ and !> scl and smsq are overwritten on SCALE and SUMSQ respectively. !> +!> If scale * sqrt( sumsq ) > tbig then +!> we require: scale >= sqrt( TINY*EPS ) / sbig on entry, +!> and if scale * sqrt( sumsq ) < tsml then +!> we require: scale <= sqrt( HUGE ) / ssml on entry, +!> where +!> tbig -- upper threshold for values whose square is representable; +!> sbig -- scaling constant for big numbers; \see la_constants.f90 +!> tsml -- lower threshold for values whose square is representable; +!> ssml -- scaling constant for small numbers; \see la_constants.f90 +!> and +!> TINY*EPS -- tiniest representable number; +!> HUGE -- biggest representable number. +!> !> \endverbatim ! ! Arguments: @@ -198,12 +209,14 @@ subroutine ZLASSQ( n, x, incx, scl, sumsq ) if( sumsq > zero ) then ax = scl*sqrt( sumsq ) if (ax > tbig) then - abig = abig + (ax*sbig)**2 +! We assume scl >= sqrt( TINY*EPS ) / sbig + abig = abig + (scl*sbig)**2 * sumsq notbig = .false. else if (ax < tsml) then - if (notbig) asml = asml + (ax*ssml)**2 +! We assume scl <= sqrt( HUGE ) / ssml + if (notbig) asml = asml + (scl*ssml)**2 * sumsq else - amed = amed + ax**2 + amed = amed + scl**2 * sumsq end if end if ! From a8a03af993e77bc0cd44543d588833f006196a78 Mon Sep 17 00:00:00 2001 From: "weslley.spereira" Date: Thu, 24 Jun 2021 18:57:14 -0300 Subject: [PATCH 3/4] Remove unused notbig = .false. thanks to @vladimir-ch --- SRC/classq.f90 | 1 - SRC/dlassq.f90 | 1 - SRC/slassq.f90 | 1 - SRC/zlassq.f90 | 1 - 4 files changed, 4 deletions(-) diff --git a/SRC/classq.f90 b/SRC/classq.f90 index c6b01fa263..a26035dc44 100644 --- a/SRC/classq.f90 +++ b/SRC/classq.f90 @@ -211,7 +211,6 @@ subroutine CLASSQ( n, x, incx, scl, sumsq ) if (ax > tbig) then ! We assume scl >= sqrt( TINY*EPS ) / sbig abig = abig + (scl*sbig)**2 * sumsq - notbig = .false. else if (ax < tsml) then ! We assume scl <= sqrt( HUGE ) / ssml if (notbig) asml = asml + (scl*ssml)**2 * sumsq diff --git a/SRC/dlassq.f90 b/SRC/dlassq.f90 index de6225589d..76ede8c9ec 100644 --- a/SRC/dlassq.f90 +++ b/SRC/dlassq.f90 @@ -202,7 +202,6 @@ subroutine DLASSQ( n, x, incx, scl, sumsq ) if (ax > tbig) then ! We assume scl >= sqrt( TINY*EPS ) / sbig abig = abig + (scl*sbig)**2 * sumsq - notbig = .false. else if (ax < tsml) then ! We assume scl <= sqrt( HUGE ) / ssml if (notbig) asml = asml + (scl*ssml)**2 * sumsq diff --git a/SRC/slassq.f90 b/SRC/slassq.f90 index 55fd829a51..8de6329f7d 100644 --- a/SRC/slassq.f90 +++ b/SRC/slassq.f90 @@ -202,7 +202,6 @@ subroutine SLASSQ( n, x, incx, scl, sumsq ) if (ax > tbig) then ! We assume scl >= sqrt( TINY*EPS ) / sbig abig = abig + (scl*sbig)**2 * sumsq - notbig = .false. else if (ax < tsml) then ! We assume scl <= sqrt( HUGE ) / ssml if (notbig) asml = asml + (scl*ssml)**2 * sumsq diff --git a/SRC/zlassq.f90 b/SRC/zlassq.f90 index fe1bb5e45d..a6186d27e9 100644 --- a/SRC/zlassq.f90 +++ b/SRC/zlassq.f90 @@ -211,7 +211,6 @@ subroutine ZLASSQ( n, x, incx, scl, sumsq ) if (ax > tbig) then ! We assume scl >= sqrt( TINY*EPS ) / sbig abig = abig + (scl*sbig)**2 * sumsq - notbig = .false. else if (ax < tsml) then ! We assume scl <= sqrt( HUGE ) / ssml if (notbig) asml = asml + (scl*ssml)**2 * sumsq From aaeeef2c305559f7451f4d959e60b962e8b5ad59 Mon Sep 17 00:00:00 2001 From: "weslley.spereira" Date: Fri, 23 Jul 2021 16:21:57 -0300 Subject: [PATCH 4/4] Fix comments thanks to @vladimir-ch --- SRC/classq.f90 | 2 +- SRC/dlassq.f90 | 2 +- SRC/slassq.f90 | 2 +- SRC/zlassq.f90 | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/SRC/classq.f90 b/SRC/classq.f90 index a26035dc44..cb4e7971f0 100644 --- a/SRC/classq.f90 +++ b/SRC/classq.f90 @@ -46,7 +46,7 @@ !> !> If scale * sqrt( sumsq ) > tbig then !> we require: scale >= sqrt( TINY*EPS ) / sbig on entry, -!> and if scale * sqrt( sumsq ) < tsml then +!> and if 0 < scale * sqrt( sumsq ) < tsml then !> we require: scale <= sqrt( HUGE ) / ssml on entry, !> where !> tbig -- upper threshold for values whose square is representable; diff --git a/SRC/dlassq.f90 b/SRC/dlassq.f90 index 76ede8c9ec..fddd1bf38f 100644 --- a/SRC/dlassq.f90 +++ b/SRC/dlassq.f90 @@ -46,7 +46,7 @@ !> !> If scale * sqrt( sumsq ) > tbig then !> we require: scale >= sqrt( TINY*EPS ) / sbig on entry, -!> and if scale * sqrt( sumsq ) < tsml then +!> and if 0 < scale * sqrt( sumsq ) < tsml then !> we require: scale <= sqrt( HUGE ) / ssml on entry, !> where !> tbig -- upper threshold for values whose square is representable; diff --git a/SRC/slassq.f90 b/SRC/slassq.f90 index 8de6329f7d..19f49402b1 100644 --- a/SRC/slassq.f90 +++ b/SRC/slassq.f90 @@ -46,7 +46,7 @@ !> !> If scale * sqrt( sumsq ) > tbig then !> we require: scale >= sqrt( TINY*EPS ) / sbig on entry, -!> and if scale * sqrt( sumsq ) < tsml then +!> and if 0 < scale * sqrt( sumsq ) < tsml then !> we require: scale <= sqrt( HUGE ) / ssml on entry, !> where !> tbig -- upper threshold for values whose square is representable; diff --git a/SRC/zlassq.f90 b/SRC/zlassq.f90 index a6186d27e9..9346dacac9 100644 --- a/SRC/zlassq.f90 +++ b/SRC/zlassq.f90 @@ -46,7 +46,7 @@ !> !> If scale * sqrt( sumsq ) > tbig then !> we require: scale >= sqrt( TINY*EPS ) / sbig on entry, -!> and if scale * sqrt( sumsq ) < tsml then +!> and if 0 < scale * sqrt( sumsq ) < tsml then !> we require: scale <= sqrt( HUGE ) / ssml on entry, !> where !> tbig -- upper threshold for values whose square is representable;