    MODULE nrm2_other
      USE set_precision
      CHARACTER (LEN=*), PARAMETER :: descript = &
        'nrm2 routines supplied with Lapack version 3.5.0 using compensated sum to collect the sum of squares'
        
    CONTAINS
! This module contains an updated version of the routines
! supplied with Lapack (version 3.4.2).

      REAL FUNCTION snrm2(n, x, incx)
!*     .. 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 )
!*
!*
!*
!*  -- This version written on 25-October-1982.
!*     Modified on 14-October-1993 to inline the call to SLASSQ.
!*     Sven Hammarling, Nag Ltd.
!*
!*
!*     .. Parameters ..
        REAL one, zero
        PARAMETER (one=1.0E+0, zero=0.0E+0)
!*     .. Local Scalars ..
        INTEGER ix
        REAL absxi, norm, scaleFac, ssq, comp, t
!*     .. 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
          scaleFac = zero
          comp = zero
          ssq = one
!*        The following loop is equivalent to this call to the LAPACK
!*        auxiliary routine:
!*        CALL SLASSQ( N, X, INCX, SCALE, SSQ )
!*
          DO, ix = 1, 1 + (n-1)*incx, incx
            IF (x(ix)/=zero) THEN
              absxi = abs(x(ix))
              IF (scaleFac<absxi) THEN
                ssq = ssq*(scaleFac/absxi)*(scaleFac/absxi)
                comp = comp*(scaleFac/absxi)*(scaleFac/absxi)
                comp = comp + one
                t = ssq
                ssq = t + comp
                comp = (t-ssq) + comp
                scaleFac = absxi
              ELSE
                comp = comp + (absxi/scaleFac)*(absxi/scaleFac)
                t = ssq
                ssq = t + comp
                comp = (t-ssq) + comp
              END IF
            END IF
          END DO
          norm = scaleFac*sqrt(ssq)
        END IF
!*
        snrm2 = norm
        RETURN
!*
!*     End of SNRM2.
!*
      END FUNCTION snrm2

      DOUBLE PRECISION FUNCTION dnrm2(n, x, incx)
!*     .. Scalar Arguments ..
        INTEGER incx, n
!*     ..
!*     .. Array Arguments ..
        DOUBLE PRECISION x(*)
!*     ..
!*
!*  Purpose
!*  =======
!*
!*  DNRM2 returns the Euclidean norm of a vector via the function
!*  name, so that
!*
!*     DNRM2 := sqrt( x'*x )
!*
!*  Further Details
!*  ===============
!*
!*  -- This version written on 25-October-1982.
!*     Modified on 14-October-1993 to inline the call to DLASSQ.
!*     Sven Hammarling, Nag Ltd.
!*
!*  =====================================================================
!*
!*     .. Parameters ..
        DOUBLE PRECISION one, zero
        PARAMETER (one=1.0D+0, zero=0.0D+0)
!*     ..
!*     .. Local Scalars ..
        DOUBLE PRECISION absxi, norm, scaleFac, ssq, comp, t
        INTEGER ix
!*     ..
!*     .. Intrinsic Functions ..
        INTRINSIC abs, sqrt
!*     ..
        IF (n<1 .OR. incx<1) THEN
          norm = zero
        ELSE IF (n==1) THEN
          norm = abs(x(1))
        ELSE
          scaleFac = zero
          comp = zero
          ssq = one
!*        The following loop is equivalent to this call to the LAPACK
!*        auxiliary routine:
!*        CALL DLASSQ( N, X, INCX, SCALE, SSQ )
!*
          DO ix = 1, 1 + (n-1)*incx, incx
            IF (x(ix)/=zero) THEN
              absxi = abs(x(ix))
              IF (scaleFac<absxi) THEN
                ssq = ssq*(scaleFac/absxi)*(scaleFac/absxi)
                comp = comp*(scaleFac/absxi)*(scaleFac/absxi)
                comp = comp + one
                t = ssq
                ssq = t + comp
                comp = (t-ssq) + comp
                scaleFac = absxi
              ELSE
                comp = comp + (absxi/scaleFac)*(absxi/scaleFac)
                t = ssq
                ssq = t + comp
                comp = (t-ssq) + comp
              END IF
            END IF
          END DO
          norm = scaleFac*sqrt(ssq)
        END IF
!*
        dnrm2 = norm
        RETURN
!*
!*     End of DNRM2.
!*
      END FUNCTION dnrm2

      REAL FUNCTION scnrm2(n, x, incx)
!*     .. 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 )
!*
!*
!*
!*  -- This version written on 25-October-1982.
!*     Modified on 14-October-1993 to inline the call to CLASSQ.
!*     Sven Hammarling, Nag Ltd.
!*
!*
!*     .. Parameters ..
        REAL one, zero
        PARAMETER (one=1.0E+0, zero=0.0E+0)
!*     .. Local Scalars ..
        INTEGER ix, j
        REAL norm, scaleFac, ssq, comp, t, absxi
!*     .. Intrinsic Functions ..
        INTRINSIC abs, aimag, real, sqrt
!*     ..
!*     .. Executable Statements ..
        IF (n<1 .OR. incx<1) THEN
          norm = zero
        ELSE
          scaleFac = zero
          comp = zero
          ssq = one
!*        The following loop is equivalent to this call to the LAPACK
!*        auxiliary routine:
!*        CALL CLASSQ( N, X, INCX, SCALE, SSQ )
!*
          DO, ix = 1, 1 + (n-1)*incx, incx
            absxi = abs(real(x(ix)))
            DO, j = 1, 2
              IF (absxi/=zero) THEN
                IF (scaleFac<absxi) THEN
                  ssq = ssq*(scaleFac/absxi)*(scaleFac/absxi)
                  comp = comp*(scaleFac/absxi)*(scaleFac/absxi)
                  comp = comp + one
                  t = ssq
                  ssq = t + comp
                  comp = (t-ssq) + comp
                  scaleFac = absxi
                ELSE
                  comp = comp + (absxi/scaleFac)*(absxi/scaleFac)
                  t = ssq
                  ssq = t + comp
                  comp = (t-ssq) + comp
                END IF
              END IF
              absxi = abs(aimag(x(ix)))
              END DO
          END DO
          norm = scaleFac*sqrt(ssq)
        END IF
!*
        scnrm2 = norm
        RETURN
!*
!*     End of SCNRM2.
!*
      END FUNCTION scnrm2

      DOUBLE PRECISION FUNCTION dznrm2(n, x, incx)
!*     .. Scalar Arguments ..
        INTEGER incx, n
!*     .. Array Arguments ..
        COMPLEX (KIND=dkind) x(*)
!*     ..
!*
!*  DZNRM2 returns the Euclidean norm of a vector via the function
!*  name, so that
!*
!*     DZNRM2 := sqrt( conjg( x' )*x )
!*
!*
!*
!*  -- This version written on 25-October-1982.
!*     Modified on 14-October-1993 to inline the call to ZLASSQ.
!*     Sven Hammarling, Nag Ltd.
!*
!*
!*     .. Parameters ..
        DOUBLE PRECISION one, zero
        PARAMETER (one=1.0D+0, zero=0.0D+0)
!*     .. Local Scalars ..
        INTEGER ix, j
        DOUBLE PRECISION norm, scaleFac, ssq, comp, t, absxi
!*     .. Intrinsic Functions ..
        INTRINSIC abs, aimag, sqrt
!*     ..
!*     .. Executable Statements ..
        IF (n<1 .OR. incx<1) THEN
          norm = zero
        ELSE
          scaleFac = zero
          comp = zero
          ssq = one
!*        The following loop is equivalent to this call to the LAPACK
!*        auxiliary routine:
!*        CALL ZLASSQ( N, X, INCX, SCALE, SSQ )
!*
          DO, ix = 1, 1 + (n-1)*incx, incx
            absxi = abs(real(x(ix)))
            DO, j = 1, 2
              IF (absxi/=zero) THEN
                IF (scaleFac<absxi) THEN
                  ssq = ssq*(scaleFac/absxi)*(scaleFac/absxi)
                  comp = comp*(scaleFac/absxi)*(scaleFac/absxi)
                  comp = comp + one
                  t = ssq
                  ssq = t + comp
                  comp = (t-ssq) + comp
                  scaleFac = absxi
                ELSE
                  comp = comp + (absxi/scaleFac)*(absxi/scaleFac)
                  t = ssq
                  ssq = t + comp
                  comp = (t-ssq) + comp
                END IF
              END IF
              absxi = abs(aimag(x(ix)))
            END DO
          END DO
          norm = scaleFac*sqrt(ssq)
        END IF
!*
        dznrm2 = norm
        RETURN
!*
!*     End of DZNRM2.
!*
      END FUNCTION dznrm2

    END MODULE nrm2_other
