MODULE nrm2_other

! This module implements Blue's algorithm as presented in:

! A Portable Fortran Program to Find the Euclidean Norm of a
! Vector James L. Blue, ACM TOMS Vol. 4, No. 1, March 1978,
! pp.15--23

! The procedure uses three accumulators to form the sum of
! squares with scaling taking place if an element value,
! x(i), is either less than b or greater than B in magnitude
! where b and B are dependent on the precision and the
! floating-point arithmetic parameters. It is a one-pass
! algorithm which detects the overflow condition; i.e.,
! the correct result is not storable.
! 
! The following values are required by the algorithm to set
! scaling factors and for choosing which elements need to
! be scaled.
! 
! Specifically if r = 2**(emin-1) and R = (2**emax)*(1-2**(-t))
! are the smallest and largest magnitude floating-point
! numbers representable then
! 
!     b = 2**(ceiling((emin-1)/2))
!     B = 2**(floor((emax-t+1)/2))
!     s = 2**(floor((emin-1)/2))
!     S = 2**(ceiling((emax+t-1)/2))
! 
! We have assumed here that the base of the arithmetic is
! binary although Blue's algorithm is presented for a general
! radix, beta.
! 
! emin, emax and t may be obtained using the Fortran
! numerical enquiry functions minexponent, maxexponent and
! digits respectively.
! 
! The other values required are the the machine epsilon and
! the largest positive balue representable; these may be
! obtained from the Fortran intrinsic functions, epsilon
! and huge respectively.

  USE ieee_arithmetic, ONLY: ieee_value, ieee_positive_inf
  USE set_precision, ONLY: skind, dkind
  CHARACTER (LEN=*), PARAMETER :: descript = &
    'Blue''s algorithm (TOMS 4(1), Mar 1978, pp15-23) updated&
    & to use just two accumulators'

  real(skind),parameter :: spTwo=2.0e0_skind, spEps= epsilon(spTwo), &
                           spHuge=huge(sptwo)
  real(dkind),parameter :: dpTwo=2.0e0_dkind, dpEps=epsilon(dpTwo), &
                           dpHuge=huge(dptwo)
  integer,parameter :: spDig=digits(spTwo), dpDig=digits(dpTwo)
  integer,parameter :: spEmin=minexponent(spTwo), spEmax=maxexponent(spTwo)
  integer,parameter :: dpEmin=minexponent(dpTwo), dpEmax=maxexponent(dpTwo)
  integer,parameter :: spLCb = ceiling(REAL((spEmin-1),KIND=skind)/spTwo)
  integer,parameter :: spUCb = floor(REAL((spEmax-spDig+1),KIND=skind)/spTwo)
  integer,parameter :: spLCs = floor(REAL((spEmin-1),KIND=skind)/spTwo)
  integer,parameter :: spUCs = ceiling(REAL((spEmax+spDig-1),KIND=skind)/spTwo)
  integer,parameter :: dpLCb = ceiling(REAL((dpEmin-1),KIND=dkind)/dpTwo)
  integer,parameter :: dpUCb = floor(REAL((dpEmax-dpDig+1),KIND=dkind)/dpTwo)
  integer,parameter :: dpLCs = floor(REAL((dpEmin-1),KIND=dkind)/dpTwo)
  integer,parameter :: dpUCs = ceiling(REAL((dpEmax+dpDig-1),KIND=dkind)/dpTwo)


CONTAINS
  FUNCTION dnrm2(n, x, incx) RESULT(res)
  USE set_precision, ONLY: wp=>dkind

    REAL(wp), INTENT(IN) :: x(*)
    INTEGER, INTENT(IN) :: n, incx
    REAL(wp) :: res
  
    INTEGER, PARAMETER :: su=dpUCs, rsu=-su, s=dpLCs, rs=-s
    REAL(wp), PARAMETER :: one = 1.0E0_wp, zero = 0.0E0_wp
    REAL(wp), PARAMETER :: b=SCALE(one, dpLCb), &
                   bu=SCALE(one, dpUCb), &
                   oflimit=SCALE(dpHuge,rsu), sqrteps=sqrt(dpEps)
 
    INCLUDE 'newBlueReal.inc'
  END FUNCTION dnrm2

  FUNCTION snrm2(n, x, incx) RESULT(res)
  USE set_precision, ONLY: wp=>skind

    REAL(wp), INTENT(IN) :: x(*)
    INTEGER, INTENT(IN) :: n, incx
    REAL(wp) :: res
  
    INTEGER, PARAMETER :: su=spUCs, rsu=-su, s=spLCs, rs=-s
    REAL(wp), PARAMETER ::  one = 1.0E0_wp, zero = 0.0E0_wp
    REAL(wp), PARAMETER :: b=SCALE(one, spLCb), &
                   bu=SCALE(one, spUCb), &
                   oflimit=SCALE(spHuge,rsu), sqrteps=sqrt(spEps)

    INCLUDE 'newBlueReal.inc'
  END FUNCTION snrm2

  FUNCTION dznrm2(n, x, incx) RESULT(res)
  USE set_precision, ONLY: wp=>dkind

    COMPLEX(wp), INTENT(IN) :: x(*)
    INTEGER, INTENT(IN) :: n, incx
    REAL(wp) :: res
  
    INTEGER, PARAMETER :: su=dpUCs, rsu=-su, s=dpLCs, rs=-s
    REAL(wp), PARAMETER :: one = 1.0E0_wp, zero = 0.0E0_wp
    REAL(wp), PARAMETER :: b=SCALE(one, dpLCb), &
                   bu=SCALE(one, dpUCb), &
                   oflimit=SCALE(dpHuge,rsu), sqrteps=sqrt(dpEps)

    INCLUDE 'newBlueComplex.inc'
  END FUNCTION dznrm2

  FUNCTION scnrm2(n, x, incx) RESULT(res)
  USE set_precision, ONLY: wp=>skind

    COMPLEX(wp), INTENT(IN) :: x(*)
    INTEGER, INTENT(IN) :: n, incx
    REAL(wp) :: res
  
    INTEGER, PARAMETER :: su=spUCs, rsu=-su, s=spLCs, rs=-s
    REAL(wp), PARAMETER ::  one = 1.0E0_wp, zero = 0.0E0_wp
    REAL(wp), PARAMETER :: b=SCALE(one, spLCb), &
                   bu=SCALE(one, spUCb), &
                   oflimit=SCALE(spHuge,rsu), sqrteps=sqrt(spEps)

    INCLUDE 'newBlueComplex.inc'
  END FUNCTION scnrm2
END MODULE nrm2_other
