! Efficient routines for robustly computing the L_2 norm
! of a vector, x.  The code uses the IEEE intrinsic modules
! (when available) in Fortran 2003.

! The basic concept is that for the great majority of input
! vectors there is no need to resort to the testing or scaling required
! by Kahan's algorithm (or similar variants). Thus we attempt to
! compute the norm using a simple loop and only if this
! approach causes a NaN, overflow or underflow do we use the more
! complex approach.  The result is a saving in time for "normal"
! problems.  The computation of the initial sum of
! squares will complete in order for exception flags to be
! tested and remedial action to be taken.
!
! If the input vector contains Inf or -Inf then the result is 
! returned as Inf and no overflow flag is set. That distinguishes
! this case from the overflow case below. The standard specifies
! that computations using Inf are usually considered exact and
! do not signal.
! 
! If the input vector contains NaN values and no Infs the result
! is returned as a quiet NaN and no flags are set. This agrees
! with the philosophy of propagating NaNs through a calculation.
! 
! If the size of the vector is zero or INCX <= 0, then a value
! of zero is returned. This is in line with the way in which
! these conditions were dealt with in the originally published
! BLAS Level 1 routines.
!
! If the norm of the input vector is computed greater than huge (i.e.,
! scaling cannot provide a valid computation) the answer is returned as
! Inf and the overflow flag is set.
! 

      FUNCTION snrm2(n, x, incx) RESULT (norm)
        USE set_precision, ONLY : skind
        USE, INTRINSIC :: ieee_arithmetic
        USE, INTRINSIC :: ieee_features
        USE, INTRINSIC :: ieee_exceptions
        IMPLICIT NONE
        INTEGER, INTENT (IN) :: n, incx
        REAL (skind), INTENT (IN) :: x(1:(n-1)*incx+1)
        REAL (skind) :: norm
        REAL (skind) :: s, t
        REAL (skind), PARAMETER :: zero = 0.0E0_skind
        REAL (skind), EXTERNAL :: snrm2Kahan

        INCLUDE 'realHybrid.inc'
! Call the specific version of the Kahan method
        norm = snrm2Kahan(n, x, incx)
        INCLUDE 'HybridTail.inc'

      END FUNCTION snrm2
       
      FUNCTION dnrm2(n, x, incx) RESULT (norm)
        USE set_precision, ONLY : dkind
        USE, INTRINSIC :: ieee_arithmetic
        USE, INTRINSIC :: ieee_features
        USE, INTRINSIC :: ieee_exceptions
        IMPLICIT NONE
        INTEGER, INTENT (IN) :: n, incx
        REAL (dkind), INTENT (IN) :: x(1:(n-1)*incx+1)
        REAL (dkind) :: norm
        REAL (dkind) :: s, t
        REAL (dkind), PARAMETER :: zero = 0.0E0_dkind
        REAL (dkind), EXTERNAL :: dnrm2Kahan

        INCLUDE 'realHybrid.inc'
! Call the specific version of the Kahan method
        norm = dnrm2Kahan(n, x, incx)
        INCLUDE 'HybridTail.inc'

      END FUNCTION dnrm2

      FUNCTION scnrm2(n, x, incx) RESULT (norm)
        USE set_precision, ONLY: skind
        USE, INTRINSIC :: ieee_arithmetic
        USE, INTRINSIC :: ieee_features
        USE, INTRINSIC :: ieee_exceptions
        IMPLICIT NONE
        INTEGER, INTENT (IN) :: n, incx
        COMPLEX (skind), INTENT (IN) :: x(1:(n-1)*incx+1)
        REAL (skind) :: norm
        REAL (skind) :: s, t
        REAL (skind), PARAMETER :: zero = 0.0E0_skind
        REAL (skind), EXTERNAL :: scnrm2Kahan
        
        INCLUDE 'complexHybrid.inc'
! Call the specific version of the Kahan method
        norm = scnrm2Kahan(n, x, incx)
        INCLUDE 'HybridTail.inc'
        
      END FUNCTION scnrm2

      FUNCTION dznrm2(n, x, incx) RESULT (norm)
        USE set_precision, ONLY: dkind
        USE, INTRINSIC :: ieee_arithmetic
        USE, INTRINSIC :: ieee_features
        USE, INTRINSIC :: ieee_exceptions
        IMPLICIT NONE
        INTEGER, INTENT (IN) :: n, incx
        COMPLEX (dkind), INTENT (IN) :: x(1:(n-1)*incx+1)
        REAL (dkind) ::  norm
        REAL (dkind) :: s, t
        REAL (dkind), PARAMETER :: zero = 0.0E0_dkind
        REAL (dkind), EXTERNAL :: dznrm2Kahan
        
        INCLUDE 'complexHybrid.inc'
! Call the specific version of the Kahan method
        norm = dznrm2Kahan(n, x, incx)
        INCLUDE 'HybridTail.inc'
        
      END FUNCTION dznrm2

! Routines implementing the Kahan algorithm
! for computing the L2 norm of a real vector.
! [Communicated by W. Kahan, April 2012 and based on a Matlab
!  code -- not shown here.]
!
     FUNCTION dnrm2Kahan(n, x, incx) RESULT (y)
       USE set_precision, ONLY: dkind
       USE, INTRINSIC :: ieee_arithmetic
       USE, INTRINSIC :: ieee_features
       USE, INTRINSIC :: ieee_exceptions
       IMPLICIT NONE
       INTEGER, INTENT (IN) :: n, incx
       REAL (dkind), INTENT (IN) :: x(1:(n-1)*incx+1)
       REAL (dkind) :: y
! Constants:  All turn out to be integer powers of  2 
!             for IEEE double precision
!   rttau = sqrt(realmin) ;   rtomega = sqrt(realmax) ;
!   hugel = 1/(eps*rttau) ;     hugeu = rtomega ;
!   tinyl = sqrt(eps)/rtomega ; tinyu = rttau/eps ;    
!
! We set precomputed parameter values.
       REAL (dkind), PARAMETER :: zero = 0.0e0_dkind, one = 1.0e0_dkind
       REAL (dkind), PARAMETER :: hugel = SCALE(one, 512)
       INTEGER, PARAMETER :: hugeu = 563
       INTEGER, PARAMETER :: tinyl = -538
       REAL (dkind), PARAMETER :: tinyu = SCALE(one, -459)

! Local variables:
       REAL (dkind) :: ahat, big, norm
       REAL (dkind) :: s, t

       INCLUDE 'realKahan.inc'
       INCLUDE 'setStatusFlags.inc'
     END FUNCTION dnrm2Kahan

     FUNCTION snrm2Kahan(n, x, incx) RESULT (y)
       USE set_precision, ONLY: skind
       USE, INTRINSIC :: ieee_arithmetic
       USE, INTRINSIC :: ieee_features
       USE, INTRINSIC :: ieee_exceptions
       IMPLICIT NONE
       INTEGER, INTENT (IN) :: n, incx
       REAL (skind), INTENT (IN) :: x(1:(n-1)*incx+1)
       REAL (skind) :: y
! Constants:  All but tinyl are integer powers of  2 
!             for IEEE single precision.
!             To make tinyl a power of two we follow Kahan and
!             replace eps by eps/2.
!   rttau = sqrt(realmin) ;   rtomega = sqrt(realmax) ;
!   hugel = 1/(eps*rttau) ;     hugeu = rtomega ;
!   tinyl = sqrt(eps)/rtomega ; tinyu = rttau/eps ;    
!
! We set precomputed parameter values.
       REAL (skind), PARAMETER :: zero = 0.0e0_skind, one = 1.0e0_skind
       REAL (skind), PARAMETER :: hugel = SCALE(one, 64)
       INTEGER, PARAMETER :: hugeu = 86
       INTEGER, PARAMETER :: tinyl = -76
       REAL (skind), PARAMETER :: tinyu = SCALE(one, -40)

! Local variables:
       REAL (skind) :: ahat, big, norm
       REAL (skind), VOLATILE :: s, t

       INCLUDE 'realKahan.inc'
       INCLUDE 'setStatusFlags.inc'
     END FUNCTION snrm2Kahan

     FUNCTION dznrm2Kahan(n, x, incx) RESULT (y)
       USE set_precision, ONLY: dkind
       USE, INTRINSIC :: ieee_arithmetic
       USE, INTRINSIC :: ieee_features
       USE, INTRINSIC :: ieee_exceptions
       IMPLICIT NONE
       INTEGER, INTENT (IN) :: n, incx
       COMPLEX (dkind), INTENT (IN) :: x(1:(n-1)*incx+1)
       REAL (dkind) :: y, xr, xi
! Constants:  All turn out to be integer powers of  2 
!             for IEEE double precision
!   rttau = sqrt(realmin) ;   rtomega = sqrt(realmax) ;
!   hugel = 1/(eps*rttau) ;     hugeu = rtodmega ;
!   tinyl = sqrt(eps)/rtomega ; tinyu = rttau/eps ;    
!
! We set precomputed parameter values.
       REAL (dkind), PARAMETER :: zero = 0.0e0_dkind, one = 1.0e0_dkind
       REAL (dkind), PARAMETER :: hugel = SCALE(one, 512)
       INTEGER, PARAMETER :: hugeu = 563
       INTEGER, PARAMETER :: tinyl = -538
       REAL (dkind), PARAMETER :: tinyu = SCALE(one, -459)

! Local variables:
       REAL (dkind) :: ahat, big, norm
       REAL (dkind) :: s, t

       INCLUDE 'complexKahan.inc'
       INCLUDE 'setStatusFlags.inc'
     END FUNCTION dznrm2Kahan

     FUNCTION scnrm2Kahan(n, x, incx) RESULT (y)
       USE set_precision, ONLY: skind
       USE, INTRINSIC :: ieee_arithmetic
       USE, INTRINSIC :: ieee_features
       USE, INTRINSIC :: ieee_exceptions
       IMPLICIT NONE
       INTEGER, INTENT (IN) :: n, incx
       COMPLEX (skind), INTENT (IN) :: x(1:(n-1)*incx+1)
       REAL (skind) :: y, xr, xi
! Constants:  All but tinyl are integer powers of  2 
!             for IEEE single precision.
!             To make tinyl a power of two we follow Kahan and
!             replace eps by eps/2.
!   rttau = sqrt(realmin) ;   rtomega = sqrt(realmax) ;
!   hugel = 1/(eps*rttau) ;     hugeu = rtomega ;
!   tinyl = sqrt(eps)/rtomega ; tinyu = rttau/eps ;    
!
! We set precomputed parameter values.
       REAL (skind), PARAMETER :: zero = 0.0e0_skind, one = 1.0e0_skind
       REAL (skind), PARAMETER :: hugel = SCALE(one, 64)
       INTEGER, PARAMETER :: hugeu = 86
       INTEGER, PARAMETER :: tinyl = -76
       REAL (skind), PARAMETER :: tinyu = SCALE(one, -40)

! Local variables:
       REAL (skind) :: ahat, big, norm
       REAL (skind), VOLATILE :: s, t

       INCLUDE 'complexKahan.inc'
       INCLUDE 'setStatusFlags.inc'
     END FUNCTION scnrm2Kahan
