LAPACK  3.10.0
LAPACK: Linear Algebra PACKage
dnrm2.f90
Go to the documentation of this file.
1 
2 !
3 ! =========== DOCUMENTATION ===========
4 !
5 ! Online html documentation available at
6 ! http://www.netlib.org/lapack/explore-html/
7 !
8 ! Definition:
9 ! ===========
10 !
11 ! DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX)
12 !
13 ! .. Scalar Arguments ..
14 ! INTEGER INCX,N
15 ! ..
16 ! .. Array Arguments ..
17 ! DOUBLE PRECISION X(*)
18 ! ..
19 !
20 !
22 ! =============
31 !
32 ! Arguments:
33 ! ==========
34 !
55 !
56 ! Authors:
57 ! ========
58 !
60 !
62 !
64 !
66 ! ==================
69 !
71 ! =====================
87 ! =====================================================================
88 function dnrm2( n, x, incx )
89  integer, parameter :: wp = kind(1.d0)
90  real(wp) :: dnrm2
91 !
92 ! -- Reference BLAS level1 routine (version 3.9.1) --
93 ! -- Reference BLAS is a software package provided by Univ. of Tennessee, --
94 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
95 ! March 2021
96 !
97 ! .. Constants ..
98  real(wp), parameter :: zero = 0.0_wp
99  real(wp), parameter :: one = 1.0_wp
100  real(wp), parameter :: maxn = huge(0.0_wp)
101 ! ..
102 ! .. Blue's ccaling constants ..
103  real(wp), parameter :: tsml = real(radix(0._wp), wp)**ceiling( &
104  (minexponent(0._wp) - 1) * 0.5_wp)
105  real(wp), parameter :: tbig = real(radix(0._wp), wp)**floor( &
106  (maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp)
107  real(wp), parameter :: ssml = real(radix(0._wp), wp)**( - floor( &
108  (minexponent(0._wp) - 1) * 0.5_wp))
109  real(wp), parameter :: sbig = real(radix(0._wp), wp)**( - ceiling( &
110  (maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp))
111 ! ..
112 ! .. Scalar Arguments ..
113  integer :: incx, n
114 ! ..
115 ! .. Array Arguments ..
116  real(wp) :: x(*)
117 ! ..
118 ! .. Local Scalars ..
119  integer :: i, ix
120  logical :: notbig
121  real(wp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin
122 !
123 ! Quick return if possible
124 !
125  dnrm2 = zero
126  if( n <= 0 ) return
127 !
128  scl = one
129  sumsq = zero
130 !
131 ! Compute the sum of squares in 3 accumulators:
132 ! abig -- sums of squares scaled down to avoid overflow
133 ! asml -- sums of squares scaled up to avoid underflow
134 ! amed -- sums of squares that do not require scaling
135 ! The thresholds and multipliers are
136 ! tbig -- values bigger than this are scaled down by sbig
137 ! tsml -- values smaller than this are scaled up by ssml
138 !
139  notbig = .true.
140  asml = zero
141  amed = zero
142  abig = zero
143  ix = 1
144  if( incx < 0 ) ix = 1 - (n-1)*incx
145  do i = 1, n
146  ax = abs(x(ix))
147  if (ax > tbig) then
148  abig = abig + (ax*sbig)**2
149  notbig = .false.
150  else if (ax < tsml) then
151  if (notbig) asml = asml + (ax*ssml)**2
152  else
153  amed = amed + ax**2
154  end if
155  ix = ix + incx
156  end do
157 !
158 ! Combine abig and amed or amed and asml if more than one
159 ! accumulator was used.
160 !
161  if (abig > zero) then
162 !
163 ! Combine abig and amed if abig > 0.
164 !
165  if ( (amed > zero) .or. (amed > maxn) .or. (amed /= amed) ) then
166  abig = abig + (amed*sbig)*sbig
167  end if
168  scl = one / sbig
169  sumsq = abig
170  else if (asml > zero) then
171 !
172 ! Combine amed and asml if asml > 0.
173 !
174  if ( (amed > zero) .or. (amed > maxn) .or. (amed /= amed) ) then
175  amed = sqrt(amed)
176  asml = sqrt(asml) / ssml
177  if (asml > amed) then
178  ymin = amed
179  ymax = asml
180  else
181  ymin = asml
182  ymax = amed
183  end if
184  scl = one
185  sumsq = ymax**2*( one + (ymin/ymax)**2 )
186  else
187  scl = one / ssml
188  sumsq = asml
189  end if
190  else
191 !
192 ! Otherwise all values are mid-range
193 !
194  scl = one
195  sumsq = amed
196  end if
197  dnrm2 = scl*sqrt( sumsq )
198  return
199 end function
real(wp) function dnrm2(n, x, incx)
DNRM2
Definition: dnrm2.f90:89