MODULE nrm2HybridOrigKMod

! Module for the Level 1 BLAS function subprograms:
! SNRM2 (N, SX, INCX)
! DNRM2 (N, DX, INCX)
! SCNRM2(N, CX, INCX)
! DZNRM2(N, ZX, INCX) 
!             (not in the Level 1 original publication)

  USE, INTRINSIC :: ieee_arithmetic
  USE, INTRINSIC :: ieee_features
  USE, INTRINSIC :: ieee_exceptions
  USE set_precision, ONLY : skind, dkind
  IMPLICIT NONE

! 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.
! 
!
! Define values that are used both in the nrm2 implementations and
! in their testing -- see getRangeValues procedures below
  REAL (skind), PRIVATE, PARAMETER :: oneSp = 1.0E0_skind, &
      lowValueSp = SCALE(oneSp, -40), highValueSp = SCALE(oneSp, 64)
  REAL (dkind), PRIVATE, PARAMETER :: oneDp = 1.0E0_dkind, &
      lowValueDp = SCALE(oneDp, -459), highValueDp = SCALE(oneDp, 512)

! Define generic interfaces
! For the hybrid routines ...
  INTERFACE nrm2
    MODULE PROCEDURE snrm2, dnrm2, scnrm2, dznrm2
  END INTERFACE nrm2
! ... and the Kahan algorithm
  INTERFACE nrm2Kahan
    MODULE PROCEDURE dnrm2Kahan, snrm2Kahan, dznrm2Kahan, scnrm2Kahan
  END INTERFACE nrm2Kahan
! ... and the getRangeValues used for testing
  INTERFACE getRangeValues
    MODULE PROCEDURE getRangeValuesSp, getRangeValuesDp
  END INTERFACE getRangeValues
 

  CONTAINS

    FUNCTION snrm2(n, x, incx) RESULT (norm)
      USE set_precision, ONLY : skind
      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

      INCLUDE 'realHybrid.inc'
! Call the generic Kahan method
      norm = nrm2Kahan(n, x, incx)
      INCLUDE 'HybridTail.inc'
      

    END FUNCTION snrm2
     
    FUNCTION dnrm2(n, x, incx) RESULT (norm)
      USE set_precision, ONLY : dkind
      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

      INCLUDE 'realHybrid.inc'
! Call the generic Kahan method
      norm = nrm2Kahan(n, x, incx)
      INCLUDE 'HybridTail.inc'

    END FUNCTION dnrm2

    FUNCTION scnrm2(n, x, incx) RESULT (norm)
      USE set_precision, ONLY: skind
      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
      
      INCLUDE 'complexHybrid.inc'
! Call the generic Kahan method
      norm = nrm2Kahan(n, x, incx)
      INCLUDE 'HybridTail.inc'
      
    END FUNCTION scnrm2

    FUNCTION dznrm2(n, x, incx) RESULT (norm)
      USE set_precision, ONLY: dkind
      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
      
      INCLUDE 'complexHybrid.inc'
! Call the generic Kahan method
      norm = nrm2Kahan(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
      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 ;    
!   
!   tinyl and hugeu are stored as integers to allow the use
!   of the SCALE intrinsic rather than a floating point
!   multiply or divide.
!
! We set precomputed parameter values.
      REAL (dkind), PARAMETER :: zero = 0.0e0_dkind, one = 1.0e0_dkind
      REAL (dkind), PARAMETER :: hugel = highValueDp
      INTEGER, PARAMETER :: tinyl = -538
      INTEGER, PARAMETER :: hugeu = 563
      REAL (dkind), PARAMETER :: tinyu = lowValueDp

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

      INCLUDE 'realKahan.inc'
! Include the code to deal with the IEEE status flags
      INCLUDE 'setStatusFlags.inc'
    END FUNCTION dnrm2Kahan

    FUNCTION snrm2Kahan(n, x, incx) RESULT (y)
      USE set_precision, ONLY: skind
      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 ;    
!   
!   tinyl and hugeu are stored as integers to allow the use
!   of the SCALE intrinsic rather than a floating point
!   multiply or divide.
!
! We set precomputed parameter values.
      REAL (skind), PARAMETER :: zero = 0.0e0_skind, one = 1.0e0_skind
      REAL (skind), PARAMETER :: hugel = highValueSp
      INTEGER, PARAMETER :: tinyl = -76
      INTEGER, PARAMETER :: hugeu = 86
      REAL (skind), PARAMETER :: tinyu = lowValueSp

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

      INCLUDE 'realKahan.inc'
! Include the code to deal with the IEEE status flags
      INCLUDE 'setStatusFlags.inc'
    END FUNCTION snrm2Kahan

    FUNCTION dznrm2Kahan(n, x, incx) RESULT (y)
      USE set_precision, ONLY: dkind
      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 = rtomega ;
!   tinyl = sqrt(eps)/rtomega ; tinyu = rttau/eps ;    
!   
!   tinyl and hugeu are stored as integers to allow the use
!   of the SCALE intrinsic rather than a floating point
!   multiply or divide.
!
! We set precomputed parameter values.
      REAL (dkind), PARAMETER :: zero = 0.0e0_dkind, one = 1.0e0_dkind
      REAL (dkind), PARAMETER :: hugel = highValueDp
      INTEGER, PARAMETER :: tinyl = -538
      INTEGER, PARAMETER :: hugeu = 563
      REAL (dkind), PARAMETER :: tinyu = lowValueDp

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

      INCLUDE 'complexKahan.inc'
! Include the code to deal with the IEEE status flags
      INCLUDE 'setStatusFlags.inc'
    END FUNCTION dznrm2Kahan

    FUNCTION scnrm2Kahan(n, x, incx) RESULT (y)
      USE set_precision, ONLY: skind
      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 ;    
!   
!   tinyl and hugeu are stored as integers to allow the use
!   of the SCALE intrinsic rather than a floating point
!   multiply or divide.
!
! We set precomputed parameter values.
      REAL (skind), PARAMETER :: zero = 0.0e0_skind, one = 1.0e0_skind
      REAL (skind), PARAMETER :: hugel = highValueSp
      INTEGER, PARAMETER :: tinyl = -76
      INTEGER, PARAMETER :: hugeu = 86
      REAL (skind), PARAMETER :: tinyu = lowValueSp

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

      INCLUDE 'complexKahan.inc'
! Include the code to deal with the IEEE status flags
      INCLUDE 'setStatusFlags.inc'
    END FUNCTION scnrm2Kahan

! The following two routines return the two (nVals) points
! in the floating point range where scaling takes place. The
! lower value is in vals(1) and the higher in vals(2). The
! user needs to provide the number of elements to be used
! in the norm computation as this is used as a scale factor
! for the upper value.
!
! These routines are only intended for use with the testing 
! package associated with this module

    SUBROUTINE getRangeValuesSp(nElts, nVals, vals)
    INTEGER, INTENT(IN) :: nElts
    INTEGER, INTENT(OUT) :: nVals
    REAL(skind), INTENT(OUT) :: vals(2)

    nVals = 2
    vals(1:nVals) = [lowValueSp, &
                  highValueSp/SQRT(REAL(nElts, KIND=skind))]

    END SUBROUTINE getRangeValuesSp

    SUBROUTINE getRangeValuesDp(nElts, nVals, vals)
    INTEGER, INTENT(IN) :: nElts
    INTEGER, INTENT(OUT) :: nVals
    REAL(dkind), INTENT(OUT) :: vals(2)

    nVals = 2
    vals(1:nVals) = [lowValueDp, &
                  highValueDp/SQRT(REAL(nElts, KIND=dkind))]

    END SUBROUTINE getRangeValuesDp

END MODULE nrm2HybridOrigKMod
