    MODULE nrm2_other
! This module contains an updated version of the routines
! supplied with Lapack (version 3.4.2) to use compensated 
! summation and to generate scaling factors that are powers
! of 2 in an attempt to minimze rounding errors.
      USE set_precision
      CHARACTER (LEN=*), PARAMETER :: descript = &
        'nrm2 routines modified from Lapack version 3.5.0 '//&
        'supplemented with compensated sums and powers of 2 scaling'
    CONTAINS
      REAL FUNCTION snrm2(n, x, incx)
        IMPLICIT NONE
!*     .. Scalar Arguments ..
        INTEGER incx, n
!*     .. Array Arguments ..
        REAL x(*)
!*     ..
!*
!*  SNRM2 returns the Euclidean norm of a vector via the function
!*  name, so that
!*
!*     SNRM2 := sqrt( x'*x )
!*
!*     .. Parameters ..
        REAL one, zero
        PARAMETER (one=1.0E+0, zero=0.0E+0)
!*     .. Local Scalars ..
        INTEGER i, iscale, isadj
        REAL norm, xtest, tp, cnorm, fac, big
!*     .. Intrinsic Functions ..
        INTRINSIC abs, sqrt
!*     ..
!*     .. Executable Statements ..
        IF (n<1 .OR. incx<1) THEN
          norm = zero
        ELSE IF (n==1) THEN
          norm = abs(x(1))
        ELSE

          xtest = zero
          cnorm = zero
          norm = zero
          fac = one
          big = huge(one)
! Adjustment to fac that avoids underflows    
          isadj = exponent(huge(1)/sqrt(big))

          DO i = 1, 1 + (n-1)*incx, incx
            IF (abs(x(i))>xtest) THEN ! Need to set scaling
              xtest = abs(x(i))
              IF (xtest>big) THEN ! Result must be +Inf
                norm = xtest
                EXIT
              END IF

              iscale = exponent(xtest) + isadj
              tp = fac
! fac scales numbers so encountered big numbers don't overflow
! and underflows are avoided.  Underflows assumed bad for performance.
              fac = scale(one, -iscale)
              tp = fac/tp
              cnorm = tp*(cnorm*tp)
              norm = tp*(norm*tp)
            END IF
! NaN in x(i) causes cnorm and norm to be NaN.
! Result could be +Inf if Inf somewhere later in x(*).
            cnorm = cnorm + (x(i)*fac)**2 ! Compensated summation with scaling
            tp = norm
            norm = norm + cnorm
            cnorm = (tp-norm) + cnorm
          END DO
          norm = sqrt(norm)/fac ! Rescaled final result.
        END IF
!*
        snrm2 = norm
!*
!*     End of SNRM2.
!*
      END FUNCTION snrm2

      DOUBLE PRECISION FUNCTION dnrm2(n, x, incx)
        IMPLICIT NONE
!*     .. Scalar Arguments ..
        INTEGER incx, n
!*     .. Array Arguments ..
        DOUBLE PRECISION x(*)
!*     ..
!*
!*  DNRM2 returns the Euclidean norm of a vector via the function
!*  name, so that
!*
!*     DNRM2 := sqrt( x'*x )
!*
!*     .. Parameters ..
        REAL one, zero
        PARAMETER (one=1.0D+0, zero=0.0D+0)
!*     .. Local Scalars ..
        INTEGER i, iscale, isadj
        DOUBLE PRECISION norm, xtest, tp, cnorm, fac, big
!*     .. Intrinsic Functions ..
        INTRINSIC abs, sqrt
!*     ..
!*     .. Executable Statements ..
        IF (n<1 .OR. incx<1) THEN
          norm = zero
        ELSE IF (n==1) THEN
          norm = abs(x(1))
        ELSE

!        dnrm2=norm2(x(1:1+(n-1)*incx:incx)) ! Intrinsic function
!        return

          xtest = zero
          cnorm = zero
          norm = zero
          fac = one
          big = huge(one)
! Adjustment to fac that avoids underflows    
          isadj = exponent(huge(1)/sqrt(big))

          DO i = 1, 1 + (n-1)*incx, incx
            IF (abs(x(i))>xtest) THEN ! Need to set scaling
              xtest = abs(x(i))
              IF (xtest>big) THEN ! Result must be +Inf
                norm = xtest
                EXIT
              END IF

              iscale = exponent(xtest) + isadj
              tp = fac
! fac scales numbers so encountered big numbers don't overflow
! and underflows are avoided.  Underflows assumed bad for performance.
              fac = scale(one, -iscale)
              tp = fac/tp
              cnorm = tp*(cnorm*tp)
              norm = tp*(norm*tp)
            END IF
! NaN in x(i) causes cnorm and norm to be NaN.
! Result could be +Inf if Inf somewhere later in x(*).
            cnorm = cnorm + (x(i)*fac)**2 ! Compensated summation with scaling
            tp = norm
            norm = norm + cnorm
            cnorm = (tp-norm) + cnorm
          END DO
          norm = sqrt(norm)/fac ! Rescaled final result.
        END IF
!*
        dnrm2 = norm
!*
!*     End of DNRM2.
!*
      END FUNCTION dnrm2

      REAL FUNCTION scnrm2(n, x, incx)
        IMPLICIT NONE
!*     .. Scalar Arguments ..
        INTEGER incx, n
!*     .. Array Arguments ..
        COMPLEX x(*)
!*     ..
!*
!*  SCNRM2 returns the Euclidean norm of a vector via the function
!*  name, so that
!*
!*     SCNRM2 := sqrt( conjg( x' )*x ) = sqrt(dot_product(x,x))
!*
!*     .. Parameters ..
        REAL one, zero
        PARAMETER (one=1.0E+0, zero=0.0E+0)
!*     .. Local Scalars ..
        INTEGER i, iscale, isadj
        REAL big, cnorm, fac, norm, sp, tp, xtest
!*     .. Intrinsic Functions ..
        INTRINSIC abs, aimag, real, sqrt
!*     ..
!*     .. Executable Statements ..
        IF (n<1 .OR. incx<1) THEN
          norm = zero
        ELSE
          xtest = zero
          cnorm = zero
          norm = zero
          fac = one
          big = huge(one)
! Adjustment to fac that avoids underflows    
          isadj = exponent(huge(1)/sqrt(big))

          DO i = 1, 1 + (n-1)*incx, incx
            tp = abs(real(x(i)))
            IF (tp>xtest) THEN ! Need to set scaling
              xtest = tp
!  As long as a new x is less than the xtest computed, we won't get overflows.
              IF (xtest>big) THEN ! Results from an overflow
                norm = xtest
                EXIT
              END IF
              iscale = exponent(xtest) + isadj
              sp = fac
              fac = scale(one, -iscale)
! fac scales numbers so allowed big numbers don't overflow
              sp = (fac/sp)
              cnorm = sp*(cnorm*sp)
              norm = sp*(norm*sp)
            END IF
! NaN in x(i) causes cnorm and norm to be NaN.
! Result could be +Inf if Inf somewhere later in x(*).
            cnorm = cnorm + (tp*fac)**2 ! Compensated summation with scaling
            sp = norm
            norm = norm + cnorm
            cnorm = (sp-norm) + cnorm

            tp = abs(aimag(x(i)))
            IF (tp>xtest) THEN ! Need to set scaling
              CALL newxtest(tp)
              IF (xtest>big) THEN ! Results from an overflow
                norm = xtest
                EXIT
              END IF
            END IF
! NaN in x(i) causes cnorm and norm to be NaN.
! Result could be +Inf if Inf somewhere later in x(*).
            cnorm = cnorm + (tp*fac)**2 ! Compensated summation with scaling
            tp = norm
            norm = norm + cnorm
            cnorm = (tp-norm) + cnorm
          END DO
          norm = sqrt(norm)/fac
        END IF
!*
        scnrm2 = norm
        RETURN
!*
!*     End of SCNRM2.
!*
      CONTAINS
        SUBROUTINE newxtest(xp)
          REAL lp, xp

          xtest = xp
!  As long as a new x is less than the xtest computed, we won't get overflows.
          IF (xtest>big) THEN ! Results from an overflow
            norm = xtest
            RETURN
          END IF
          iscale = exponent(xtest) + isadj
          lp = fac
          fac = scale(one, -iscale)
! fac scales numbers so allowed big numbers don't overflow
          lp = (fac/lp)
          cnorm = lp*(cnorm*lp)
          norm = lp*(norm*lp)
          RETURN
        END SUBROUTINE newxtest
      END FUNCTION scnrm2

      DOUBLE PRECISION FUNCTION dznrm2(n, x, incx)
        IMPLICIT NONE
!*     .. Scalar Arguments ..
        INTEGER incx, n
!*     .. Array Arguments ..
        COMPLEX (kind(1.D0)) x(*)
!*     ..
!*
!*  DZNRM2 returns the Euclidean norm of a vector via the function
!*  name, so that
!*
!*     DZNRM2 := sqrt( conjg( x' )*x ) = sqrt(dot_product(x,x))
!*
!*     .. Parameters ..
        REAL (kind(1.D0)) one, zero
        PARAMETER (one=1.0E+0, zero=0.0E+0)
!*     .. Local Scalars ..
        INTEGER i, iscale, isadj
        REAL (kind(1.D0)) big, cnorm, fac, norm, sp, tp, xtest
!*     .. Intrinsic Functions ..
        INTRINSIC abs, aimag, real, sqrt
!*     ..
!*     .. Executable Statements ..
        IF (n<1 .OR. incx<1) THEN
          norm = zero
        ELSE
          xtest = zero
          cnorm = zero
          norm = zero
          fac = one
          big = huge(one)
! Adjustment to fac that avoids underflows    
          isadj = exponent(huge(1)/sqrt(big))

          DO i = 1, 1 + (n-1)*incx, incx
            tp = abs(real(x(i),kind(1.D0)))
            IF (tp>xtest) THEN ! Need to set scaling
              xtest = tp
!  As long as a new x is less than the xtest computed, we won't get overflows.
              IF (xtest>big) THEN ! Results from an overflow
                norm = xtest
                EXIT
              END IF
              iscale = exponent(xtest) + isadj
              sp = fac
              fac = scale(one, -iscale)
! fac scales numbers so allowed big numbers don't overflow
              sp = (fac/sp)
              cnorm = sp*(cnorm*sp)
              norm = sp*(norm*sp)
            END IF
! NaN in x(i) causes cnorm and norm to be NaN.
! Result could be +Inf if Inf somewhere later in x(*).
            cnorm = cnorm + (tp*fac)**2 ! Compensated summation with scaling
            sp = norm
            norm = norm + cnorm
            cnorm = (sp-norm) + cnorm

            tp = abs(aimag(x(i)))
            IF (tp>xtest) THEN ! Need to set scaling
              CALL newxtest(tp)
              IF (xtest>big) THEN ! Results from an overflow
                norm = xtest
                EXIT
              END IF
            END IF
! NaN in x(i) causes cnorm and norm to be NaN.
! Result could be +Inf if Inf somewhere later in x(*).
            cnorm = cnorm + (tp*fac)**2 ! Compensated summation with scaling
            tp = norm
            norm = norm + cnorm
            cnorm = (tp-norm) + cnorm
          END DO
          norm = sqrt(norm)/fac
        END IF
!*
        dznrm2 = norm
        RETURN
!*
!*     End of DZNRM2.
!*
      CONTAINS
        SUBROUTINE newxtest(xp)
          REAL (kind(1.D0)) lp, xp

          xtest = xp
!  As long as a new x is less than the xtest computed, we won't get overflows.
          IF (xtest>big) THEN ! Results from an overflow
            norm = xtest
            RETURN
          END IF
          iscale = exponent(xtest) + isadj
          lp = fac
          fac = scale(one, -iscale)
! fac scales numbers so allowed big numbers don't overflow
          lp = (fac/lp)
          cnorm = lp*(cnorm*lp)
          norm = lp*(norm*lp)
          RETURN
        END SUBROUTINE newxtest
      END FUNCTION dznrm2

    END MODULE nrm2_other
