floraachy
/
OpenBLAS
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge pull request #4294 from martin-frbg/lapack909 

Fix accumulation in LAPACK ?LASSQ (Reference-LAPACK PR 909)
This commit is contained in:
Martin Kroeker 2023-11-07 12:23:16 +01:00 committed by GitHub
parent 6f11992dbb f6ec777701
commit fea1d4f66c
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
4 changed files with 160 additions and 164 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

81
lapack-netlib/SRC/classq.f90
View File

@ -34,28 +34,15 @@
!> !>
!> \verbatim !> \verbatim
!> !>
!> CLASSQ returns the values scl and smsq such that !> CLASSQ returns the values scale_out and sumsq_out such that
!> !>
!> ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, !> (scale_out**2)*sumsq_out = x( 1 )**2 +...+ x( n )**2 + (scale**2)*sumsq,
!> !>
!> where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is !> where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is
!> assumed to be non-negative. !> assumed to be non-negative.
!> !>
!> scale and sumsq must be supplied in SCALE and SUMSQ and !> scale and sumsq must be supplied in SCALE and SUMSQ and
!> scl and smsq are overwritten on SCALE and SUMSQ respectively. !> scale_out and sumsq_out are overwritten on SCALE and SUMSQ respectively.
!>
!> If scale * sqrt( sumsq ) > tbig then
!> we require: scale >= sqrt( TINY*EPS ) / sbig on entry,
!> 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;
!> 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 !> \endverbatim
! !
@ -72,7 +59,7 @@
!> \verbatim !> \verbatim
!> X is COMPLEX array, dimension (1+(N-1)*abs(INCX)) !> X is COMPLEX array, dimension (1+(N-1)*abs(INCX))
!> The vector for which a scaled sum of squares is computed. !> The vector for which a scaled sum of squares is computed.
!> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. !> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
!> \endverbatim !> \endverbatim
!> !>
!> \param[in] INCX !> \param[in] INCX
@ -82,24 +69,24 @@
!> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n !> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n
!> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n !> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n
!> If INCX = 0, x isn't a vector so there is no need to call !> If INCX = 0, x isn't a vector so there is no need to call
!> this subroutine. If you call it anyway, it will count x(1) !> this subroutine. If you call it anyway, it will count x(1)
!> in the vector norm N times. !> in the vector norm N times.
!> \endverbatim !> \endverbatim
!> !>
!> \param[in,out] SCALE !> \param[in,out] SCALE
!> \verbatim !> \verbatim
!> SCALE is REAL !> SCALE is REAL
!> On entry, the value scale in the equation above. !> On entry, the value scale in the equation above.
!> On exit, SCALE is overwritten with scl , the scaling factor !> On exit, SCALE is overwritten by scale_out, the scaling factor
!> for the sum of squares. !> for the sum of squares.
!> \endverbatim !> \endverbatim
!> !>
!> \param[in,out] SUMSQ !> \param[in,out] SUMSQ
!> \verbatim !> \verbatim
!> SUMSQ is REAL !> SUMSQ is REAL
!> On entry, the value sumsq in the equation above. !> On entry, the value sumsq in the equation above.
!> On exit, SUMSQ is overwritten with smsq , the basic sum of !> On exit, SUMSQ is overwritten by sumsq_out, the basic sum of
!> squares from which scl has been factored out. !> squares from which scale_out has been factored out.
!> \endverbatim !> \endverbatim
! !
! Authors: ! Authors:
@ -130,10 +117,10 @@
!> !>
!> \endverbatim !> \endverbatim
! !
!> \ingroup OTHERauxiliary !> \ingroup lassq
! !
! ===================================================================== ! =====================================================================
subroutine CLASSQ( n, x, incx, scl, sumsq ) subroutine CLASSQ( n, x, incx, scale, sumsq )
use LA_CONSTANTS, & use LA_CONSTANTS, &
only: wp=>sp, zero=>szero, one=>sone, & only: wp=>sp, zero=>szero, one=>sone, &
sbig=>ssbig, ssml=>sssml, tbig=>stbig, tsml=>stsml sbig=>ssbig, ssml=>sssml, tbig=>stbig, tsml=>stsml
@ -145,7 +132,7 @@ subroutine CLASSQ( n, x, incx, scl, sumsq )
! !
! .. Scalar Arguments .. ! .. Scalar Arguments ..
integer :: incx, n integer :: incx, n
real(wp) :: scl, sumsq real(wp) :: scale, sumsq
! .. ! ..
! .. Array Arguments .. ! .. Array Arguments ..
complex(wp) :: x(*) complex(wp) :: x(*)
@ -158,10 +145,10 @@ subroutine CLASSQ( n, x, incx, scl, sumsq )
! !
! Quick return if possible ! Quick return if possible
! !
if( LA_ISNAN(scl) .or. LA_ISNAN(sumsq) ) return if( LA_ISNAN(scale) .or. LA_ISNAN(sumsq) ) return
if( sumsq == zero ) scl = one if( sumsq == zero ) scale = one
if( scl == zero ) then if( scale == zero ) then
scl = one scale = one
sumsq = zero sumsq = zero
end if end if
if (n <= 0) then if (n <= 0) then
@ -207,15 +194,27 @@ subroutine CLASSQ( n, x, incx, scl, sumsq )
! Put the existing sum of squares into one of the accumulators ! Put the existing sum of squares into one of the accumulators
! !
if( sumsq > zero ) then if( sumsq > zero ) then
ax = scl*sqrt( sumsq ) ax = scale*sqrt( sumsq )
if (ax > tbig) then if (ax > tbig) then
! We assume scl >= sqrt( TINY*EPS ) / sbig if (scale > one) then
abig = abig + (scl*sbig)**2 * sumsq scale = scale * sbig
abig = abig + scale * (scale * sumsq)
else
! sumsq > tbig^2 => (sbig * (sbig * sumsq)) is representable
abig = abig + scale * (scale * (sbig * (sbig * sumsq)))
end if
else if (ax < tsml) then else if (ax < tsml) then
! We assume scl <= sqrt( HUGE ) / ssml if (notbig) then
if (notbig) asml = asml + (scl*ssml)**2 * sumsq if (scale < one) then
scale = scale * ssml
asml = asml + scale * (scale * sumsq)
else
! sumsq < tsml^2 => (ssml * (ssml * sumsq)) is representable
asml = asml + scale * (scale * (ssml * (ssml * sumsq)))
end if
end if
else else
amed = amed + scl**2 * sumsq amed = amed + scale * (scale * sumsq)
end if end if
end if end if
! !
@ -229,7 +228,7 @@ subroutine CLASSQ( n, x, incx, scl, sumsq )
if (amed > zero .or. LA_ISNAN(amed)) then if (amed > zero .or. LA_ISNAN(amed)) then
abig = abig + (amed*sbig)*sbig abig = abig + (amed*sbig)*sbig
end if end if
scl = one / sbig scale = one / sbig
sumsq = abig sumsq = abig
else if (asml > zero) then else if (asml > zero) then
! !
@ -245,17 +244,17 @@ subroutine CLASSQ( n, x, incx, scl, sumsq )
ymin = asml ymin = asml
ymax = amed ymax = amed
end if end if
scl = one scale = one
sumsq = ymax**2*( one + (ymin/ymax)**2 ) sumsq = ymax**2*( one + (ymin/ymax)**2 )
else else
scl = one / ssml scale = one / ssml
sumsq = asml sumsq = asml
end if end if
else else
! !
! Otherwise all values are mid-range or zero ! Otherwise all values are mid-range or zero
! !
scl = one scale = one
sumsq = amed sumsq = amed
end if end if
return return

81
lapack-netlib/SRC/dlassq.f90
View File

@ -34,28 +34,15 @@
!> !>
!> \verbatim !> \verbatim
!> !>
!> DLASSQ returns the values scl and smsq such that !> DLASSQ returns the values scale_out and sumsq_out such that
!> !>
!> ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, !> (scale_out**2)*sumsq_out = x( 1 )**2 +...+ x( n )**2 + (scale**2)*sumsq,
!> !>
!> where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is !> where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is
!> assumed to be non-negative. !> assumed to be non-negative.
!> !>
!> scale and sumsq must be supplied in SCALE and SUMSQ and !> scale and sumsq must be supplied in SCALE and SUMSQ and
!> scl and smsq are overwritten on SCALE and SUMSQ respectively. !> scale_out and sumsq_out are overwritten on SCALE and SUMSQ respectively.
!>
!> If scale * sqrt( sumsq ) > tbig then
!> we require: scale >= sqrt( TINY*EPS ) / sbig on entry,
!> 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;
!> 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 !> \endverbatim
! !
@ -72,7 +59,7 @@
!> \verbatim !> \verbatim
!> X is DOUBLE PRECISION array, dimension (1+(N-1)*abs(INCX)) !> X is DOUBLE PRECISION array, dimension (1+(N-1)*abs(INCX))
!> The vector for which a scaled sum of squares is computed. !> The vector for which a scaled sum of squares is computed.
!> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. !> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
!> \endverbatim !> \endverbatim
!> !>
!> \param[in] INCX !> \param[in] INCX
@ -82,24 +69,24 @@
!> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n !> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n
!> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n !> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n
!> If INCX = 0, x isn't a vector so there is no need to call !> If INCX = 0, x isn't a vector so there is no need to call
!> this subroutine. If you call it anyway, it will count x(1) !> this subroutine. If you call it anyway, it will count x(1)
!> in the vector norm N times. !> in the vector norm N times.
!> \endverbatim !> \endverbatim
!> !>
!> \param[in,out] SCALE !> \param[in,out] SCALE
!> \verbatim !> \verbatim
!> SCALE is DOUBLE PRECISION !> SCALE is DOUBLE PRECISION
!> On entry, the value scale in the equation above. !> On entry, the value scale in the equation above.
!> On exit, SCALE is overwritten with scl , the scaling factor !> On exit, SCALE is overwritten by scale_out, the scaling factor
!> for the sum of squares. !> for the sum of squares.
!> \endverbatim !> \endverbatim
!> !>
!> \param[in,out] SUMSQ !> \param[in,out] SUMSQ
!> \verbatim !> \verbatim
!> SUMSQ is DOUBLE PRECISION !> SUMSQ is DOUBLE PRECISION
!> On entry, the value sumsq in the equation above. !> On entry, the value sumsq in the equation above.
!> On exit, SUMSQ is overwritten with smsq , the basic sum of !> On exit, SUMSQ is overwritten by sumsq_out, the basic sum of
!> squares from which scl has been factored out. !> squares from which scale_out has been factored out.
!> \endverbatim !> \endverbatim
! !
! Authors: ! Authors:
@ -130,10 +117,10 @@
!> !>
!> \endverbatim !> \endverbatim
! !
!> \ingroup OTHERauxiliary !> \ingroup lassq
! !
! ===================================================================== ! =====================================================================
subroutine DLASSQ( n, x, incx, scl, sumsq ) subroutine DLASSQ( n, x, incx, scale, sumsq )
use LA_CONSTANTS, & use LA_CONSTANTS, &
only: wp=>dp, zero=>dzero, one=>done, & only: wp=>dp, zero=>dzero, one=>done, &
sbig=>dsbig, ssml=>dssml, tbig=>dtbig, tsml=>dtsml sbig=>dsbig, ssml=>dssml, tbig=>dtbig, tsml=>dtsml
@ -145,7 +132,7 @@ subroutine DLASSQ( n, x, incx, scl, sumsq )
! !
! .. Scalar Arguments .. ! .. Scalar Arguments ..
integer :: incx, n integer :: incx, n
real(wp) :: scl, sumsq real(wp) :: scale, sumsq
! .. ! ..
! .. Array Arguments .. ! .. Array Arguments ..
real(wp) :: x(*) real(wp) :: x(*)
@ -158,10 +145,10 @@ subroutine DLASSQ( n, x, incx, scl, sumsq )
! !
! Quick return if possible ! Quick return if possible
! !
if( LA_ISNAN(scl) .or. LA_ISNAN(sumsq) ) return if( LA_ISNAN(scale) .or. LA_ISNAN(sumsq) ) return
if( sumsq == zero ) scl = one if( sumsq == zero ) scale = one
if( scl == zero ) then if( scale == zero ) then
scl = one scale = one
sumsq = zero sumsq = zero
end if end if
if (n <= 0) then if (n <= 0) then
@ -198,15 +185,27 @@ subroutine DLASSQ( n, x, incx, scl, sumsq )
! Put the existing sum of squares into one of the accumulators ! Put the existing sum of squares into one of the accumulators
! !
if( sumsq > zero ) then if( sumsq > zero ) then
ax = scl*sqrt( sumsq ) ax = scale*sqrt( sumsq )
if (ax > tbig) then if (ax > tbig) then
! We assume scl >= sqrt( TINY*EPS ) / sbig if (scale > one) then
abig = abig + (scl*sbig)**2 * sumsq scale = scale * sbig
abig = abig + scale * (scale * sumsq)
else
! sumsq > tbig^2 => (sbig * (sbig * sumsq)) is representable
abig = abig + scale * (scale * (sbig * (sbig * sumsq)))
end if
else if (ax < tsml) then else if (ax < tsml) then
! We assume scl <= sqrt( HUGE ) / ssml if (notbig) then
if (notbig) asml = asml + (scl*ssml)**2 * sumsq if (scale < one) then
scale = scale * ssml
asml = asml + scale * (scale * sumsq)
else
! sumsq < tsml^2 => (ssml * (ssml * sumsq)) is representable
asml = asml + scale * (scale * (ssml * (ssml * sumsq)))
end if
end if
else else
amed = amed + scl**2 * sumsq amed = amed + scale * (scale * sumsq)
end if end if
end if end if
! !
@ -220,7 +219,7 @@ subroutine DLASSQ( n, x, incx, scl, sumsq )
if (amed > zero .or. LA_ISNAN(amed)) then if (amed > zero .or. LA_ISNAN(amed)) then
abig = abig + (amed*sbig)*sbig abig = abig + (amed*sbig)*sbig
end if end if
scl = one / sbig scale = one / sbig
sumsq = abig sumsq = abig
else if (asml > zero) then else if (asml > zero) then
! !
@ -236,17 +235,17 @@ subroutine DLASSQ( n, x, incx, scl, sumsq )
ymin = asml ymin = asml
ymax = amed ymax = amed
end if end if
scl = one scale = one
sumsq = ymax**2*( one + (ymin/ymax)**2 ) sumsq = ymax**2*( one + (ymin/ymax)**2 )
else else
scl = one / ssml scale = one / ssml
sumsq = asml sumsq = asml
end if end if
else else
! !
! Otherwise all values are mid-range or zero ! Otherwise all values are mid-range or zero
! !
scl = one scale = one
sumsq = amed sumsq = amed
end if end if
return return

81
lapack-netlib/SRC/slassq.f90
View File

@ -34,28 +34,15 @@
!> !>
!> \verbatim !> \verbatim
!> !>
!> SLASSQ returns the values scl and smsq such that !> SLASSQ returns the values scale_out and sumsq_out such that
!> !>
!> ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, !> (scale_out**2)*sumsq_out = x( 1 )**2 +...+ x( n )**2 + (scale**2)*sumsq,
!> !>
!> where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is !> where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is
!> assumed to be non-negative. !> assumed to be non-negative.
!> !>
!> scale and sumsq must be supplied in SCALE and SUMSQ and !> scale and sumsq must be supplied in SCALE and SUMSQ and
!> scl and smsq are overwritten on SCALE and SUMSQ respectively. !> scale_out and sumsq_out are overwritten on SCALE and SUMSQ respectively.
!>
!> If scale * sqrt( sumsq ) > tbig then
!> we require: scale >= sqrt( TINY*EPS ) / sbig on entry,
!> 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;
!> 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 !> \endverbatim
! !
@ -72,7 +59,7 @@
!> \verbatim !> \verbatim
!> X is REAL array, dimension (1+(N-1)*abs(INCX)) !> X is REAL array, dimension (1+(N-1)*abs(INCX))
!> The vector for which a scaled sum of squares is computed. !> The vector for which a scaled sum of squares is computed.
!> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. !> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
!> \endverbatim !> \endverbatim
!> !>
!> \param[in] INCX !> \param[in] INCX
@ -82,24 +69,24 @@
!> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n !> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n
!> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n !> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n
!> If INCX = 0, x isn't a vector so there is no need to call !> If INCX = 0, x isn't a vector so there is no need to call
!> this subroutine. If you call it anyway, it will count x(1) !> this subroutine. If you call it anyway, it will count x(1)
!> in the vector norm N times. !> in the vector norm N times.
!> \endverbatim !> \endverbatim
!> !>
!> \param[in,out] SCALE !> \param[in,out] SCALE
!> \verbatim !> \verbatim
!> SCALE is REAL !> SCALE is REAL
!> On entry, the value scale in the equation above. !> On entry, the value scale in the equation above.
!> On exit, SCALE is overwritten with scl , the scaling factor !> On exit, SCALE is overwritten by scale_out, the scaling factor
!> for the sum of squares. !> for the sum of squares.
!> \endverbatim !> \endverbatim
!> !>
!> \param[in,out] SUMSQ !> \param[in,out] SUMSQ
!> \verbatim !> \verbatim
!> SUMSQ is REAL !> SUMSQ is REAL
!> On entry, the value sumsq in the equation above. !> On entry, the value sumsq in the equation above.
!> On exit, SUMSQ is overwritten with smsq , the basic sum of !> On exit, SUMSQ is overwritten by sumsq_out, the basic sum of
!> squares from which scl has been factored out. !> squares from which scale_out has been factored out.
!> \endverbatim !> \endverbatim
! !
! Authors: ! Authors:
@ -130,10 +117,10 @@
!> !>
!> \endverbatim !> \endverbatim
! !
!> \ingroup OTHERauxiliary !> \ingroup lassq
! !
! ===================================================================== ! =====================================================================
subroutine SLASSQ( n, x, incx, scl, sumsq ) subroutine SLASSQ( n, x, incx, scale, sumsq )
use LA_CONSTANTS, & use LA_CONSTANTS, &
only: wp=>sp, zero=>szero, one=>sone, & only: wp=>sp, zero=>szero, one=>sone, &
sbig=>ssbig, ssml=>sssml, tbig=>stbig, tsml=>stsml sbig=>ssbig, ssml=>sssml, tbig=>stbig, tsml=>stsml
@ -145,7 +132,7 @@ subroutine SLASSQ( n, x, incx, scl, sumsq )
! !
! .. Scalar Arguments .. ! .. Scalar Arguments ..
integer :: incx, n integer :: incx, n
real(wp) :: scl, sumsq real(wp) :: scale, sumsq
! .. ! ..
! .. Array Arguments .. ! .. Array Arguments ..
real(wp) :: x(*) real(wp) :: x(*)
@ -158,10 +145,10 @@ subroutine SLASSQ( n, x, incx, scl, sumsq )
! !
! Quick return if possible ! Quick return if possible
! !
if( LA_ISNAN(scl) .or. LA_ISNAN(sumsq) ) return if( LA_ISNAN(scale) .or. LA_ISNAN(sumsq) ) return
if( sumsq == zero ) scl = one if( sumsq == zero ) scale = one
if( scl == zero ) then if( scale == zero ) then
scl = one scale = one
sumsq = zero sumsq = zero
end if end if
if (n <= 0) then if (n <= 0) then
@ -198,15 +185,27 @@ subroutine SLASSQ( n, x, incx, scl, sumsq )
! Put the existing sum of squares into one of the accumulators ! Put the existing sum of squares into one of the accumulators
! !
if( sumsq > zero ) then if( sumsq > zero ) then
ax = scl*sqrt( sumsq ) ax = scale*sqrt( sumsq )
if (ax > tbig) then if (ax > tbig) then
! We assume scl >= sqrt( TINY*EPS ) / sbig if (scale > one) then
abig = abig + (scl*sbig)**2 * sumsq scale = scale * sbig
abig = abig + scale * (scale * sumsq)
else
! sumsq > tbig^2 => (sbig * (sbig * sumsq)) is representable
abig = abig + scale * (scale * (sbig * (sbig * sumsq)))
end if
else if (ax < tsml) then else if (ax < tsml) then
! We assume scl <= sqrt( HUGE ) / ssml if (notbig) then
if (notbig) asml = asml + (scl*ssml)**2 * sumsq if (scale < one) then
scale = scale * ssml
asml = asml + scale * (scale * sumsq)
else
! sumsq < tsml^2 => (ssml * (ssml * sumsq)) is representable
asml = asml + scale * (scale * (ssml * (ssml * sumsq)))
end if
end if
else else
amed = amed + scl**2 * sumsq amed = amed + scale * (scale * sumsq)
end if end if
end if end if
! !
@ -220,7 +219,7 @@ subroutine SLASSQ( n, x, incx, scl, sumsq )
if (amed > zero .or. LA_ISNAN(amed)) then if (amed > zero .or. LA_ISNAN(amed)) then
abig = abig + (amed*sbig)*sbig abig = abig + (amed*sbig)*sbig
end if end if
scl = one / sbig scale = one / sbig
sumsq = abig sumsq = abig
else if (asml > zero) then else if (asml > zero) then
! !
@ -236,17 +235,17 @@ subroutine SLASSQ( n, x, incx, scl, sumsq )
ymin = asml ymin = asml
ymax = amed ymax = amed
end if end if
scl = one scale = one
sumsq = ymax**2*( one + (ymin/ymax)**2 ) sumsq = ymax**2*( one + (ymin/ymax)**2 )
else else
scl = one / ssml scale = one / ssml
sumsq = asml sumsq = asml
end if end if
else else
! !
! Otherwise all values are mid-range or zero ! Otherwise all values are mid-range or zero
! !
scl = one scale = one
sumsq = amed sumsq = amed
end if end if
return return

81
lapack-netlib/SRC/zlassq.f90
View File

@ -34,28 +34,15 @@
!> !>
!> \verbatim !> \verbatim
!> !>
!> ZLASSQ returns the values scl and smsq such that !> ZLASSQ returns the values scale_out and sumsq_out such that
!> !>
!> ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, !> (scale_out**2)*sumsq_out = x( 1 )**2 +...+ x( n )**2 + (scale**2)*sumsq,
!> !>
!> where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is !> where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is
!> assumed to be non-negative. !> assumed to be non-negative.
!> !>
!> scale and sumsq must be supplied in SCALE and SUMSQ and !> scale and sumsq must be supplied in SCALE and SUMSQ and
!> scl and smsq are overwritten on SCALE and SUMSQ respectively. !> scale_out and sumsq_out are overwritten on SCALE and SUMSQ respectively.
!>
!> If scale * sqrt( sumsq ) > tbig then
!> we require: scale >= sqrt( TINY*EPS ) / sbig on entry,
!> 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;
!> 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 !> \endverbatim
! !
@ -72,7 +59,7 @@
!> \verbatim !> \verbatim
!> X is DOUBLE COMPLEX array, dimension (1+(N-1)*abs(INCX)) !> X is DOUBLE COMPLEX array, dimension (1+(N-1)*abs(INCX))
!> The vector for which a scaled sum of squares is computed. !> The vector for which a scaled sum of squares is computed.
!> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. !> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
!> \endverbatim !> \endverbatim
!> !>
!> \param[in] INCX !> \param[in] INCX
@ -82,24 +69,24 @@
!> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n !> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n
!> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n !> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n
!> If INCX = 0, x isn't a vector so there is no need to call !> If INCX = 0, x isn't a vector so there is no need to call
!> this subroutine. If you call it anyway, it will count x(1) !> this subroutine. If you call it anyway, it will count x(1)
!> in the vector norm N times. !> in the vector norm N times.
!> \endverbatim !> \endverbatim
!> !>
!> \param[in,out] SCALE !> \param[in,out] SCALE
!> \verbatim !> \verbatim
!> SCALE is DOUBLE PRECISION !> SCALE is DOUBLE PRECISION
!> On entry, the value scale in the equation above. !> On entry, the value scale in the equation above.
!> On exit, SCALE is overwritten with scl , the scaling factor !> On exit, SCALE is overwritten by scale_out, the scaling factor
!> for the sum of squares. !> for the sum of squares.
!> \endverbatim !> \endverbatim
!> !>
!> \param[in,out] SUMSQ !> \param[in,out] SUMSQ
!> \verbatim !> \verbatim
!> SUMSQ is DOUBLE PRECISION !> SUMSQ is DOUBLE PRECISION
!> On entry, the value sumsq in the equation above. !> On entry, the value sumsq in the equation above.
!> On exit, SUMSQ is overwritten with smsq , the basic sum of !> On exit, SUMSQ is overwritten by sumsq_out, the basic sum of
!> squares from which scl has been factored out. !> squares from which scale_out has been factored out.
!> \endverbatim !> \endverbatim
! !
! Authors: ! Authors:
@ -130,10 +117,10 @@
!> !>
!> \endverbatim !> \endverbatim
! !
!> \ingroup OTHERauxiliary !> \ingroup lassq
! !
! ===================================================================== ! =====================================================================
subroutine ZLASSQ( n, x, incx, scl, sumsq ) subroutine ZLASSQ( n, x, incx, scale, sumsq )
use LA_CONSTANTS, & use LA_CONSTANTS, &
only: wp=>dp, zero=>dzero, one=>done, & only: wp=>dp, zero=>dzero, one=>done, &
sbig=>dsbig, ssml=>dssml, tbig=>dtbig, tsml=>dtsml sbig=>dsbig, ssml=>dssml, tbig=>dtbig, tsml=>dtsml
@ -145,7 +132,7 @@ subroutine ZLASSQ( n, x, incx, scl, sumsq )
! !
! .. Scalar Arguments .. ! .. Scalar Arguments ..
integer :: incx, n integer :: incx, n
real(wp) :: scl, sumsq real(wp) :: scale, sumsq
! .. ! ..
! .. Array Arguments .. ! .. Array Arguments ..
complex(wp) :: x(*) complex(wp) :: x(*)
@ -158,10 +145,10 @@ subroutine ZLASSQ( n, x, incx, scl, sumsq )
! !
! Quick return if possible ! Quick return if possible
! !
if( LA_ISNAN(scl) .or. LA_ISNAN(sumsq) ) return if( LA_ISNAN(scale) .or. LA_ISNAN(sumsq) ) return
if( sumsq == zero ) scl = one if( sumsq == zero ) scale = one
if( scl == zero ) then if( scale == zero ) then
scl = one scale = one
sumsq = zero sumsq = zero
end if end if
if (n <= 0) then if (n <= 0) then
@ -207,15 +194,27 @@ subroutine ZLASSQ( n, x, incx, scl, sumsq )
! Put the existing sum of squares into one of the accumulators ! Put the existing sum of squares into one of the accumulators
! !
if( sumsq > zero ) then if( sumsq > zero ) then
ax = scl*sqrt( sumsq ) ax = scale*sqrt( sumsq )
if (ax > tbig) then if (ax > tbig) then
! We assume scl >= sqrt( TINY*EPS ) / sbig if (scale > one) then
abig = abig + (scl*sbig)**2 * sumsq scale = scale * sbig
abig = abig + scale * (scale * sumsq)
else
! sumsq > tbig^2 => (sbig * (sbig * sumsq)) is representable
abig = abig + scale * (scale * (sbig * (sbig * sumsq)))
end if
else if (ax < tsml) then else if (ax < tsml) then
! We assume scl <= sqrt( HUGE ) / ssml if (notbig) then
if (notbig) asml = asml + (scl*ssml)**2 * sumsq if (scale < one) then
scale = scale * ssml
asml = asml + scale * (scale * sumsq)
else
! sumsq < tsml^2 => (ssml * (ssml * sumsq)) is representable
asml = asml + scale * (scale * (ssml * (ssml * sumsq)))
end if
end if
else else
amed = amed + scl**2 * sumsq amed = amed + scale * (scale * sumsq)
end if end if
end if end if
! !
@ -229,7 +228,7 @@ subroutine ZLASSQ( n, x, incx, scl, sumsq )
if (amed > zero .or. LA_ISNAN(amed)) then if (amed > zero .or. LA_ISNAN(amed)) then
abig = abig + (amed*sbig)*sbig abig = abig + (amed*sbig)*sbig
end if end if
scl = one / sbig scale = one / sbig
sumsq = abig sumsq = abig
else if (asml > zero) then else if (asml > zero) then
! !
@ -245,17 +244,17 @@ subroutine ZLASSQ( n, x, incx, scl, sumsq )
ymin = asml ymin = asml
ymax = amed ymax = amed
end if end if
scl = one scale = one
sumsq = ymax**2*( one + (ymin/ymax)**2 ) sumsq = ymax**2*( one + (ymin/ymax)**2 )
else else
scl = one / ssml scale = one / ssml
sumsq = asml sumsq = asml
end if end if
else else
! !
! Otherwise all values are mid-range or zero ! Otherwise all values are mid-range or zero
! !
scl = one scale = one
sumsq = amed sumsq = amed
end if end if
return return