! Use meaningful names for the indices used to access the relevant
! IEEE status flags
        INTEGER, PARAMETER :: overflow = 1, underflow = 2, inexact = 3
! Use an array to store  the inherited halting mode flags which
! are reset by the routine and then reset to their original values
        LOGICAL :: haltingFlags(5)
   
        LOGICAL :: infInInput, nanInInput
        INTEGER :: i, sc

! We deal with two special cases immediately.
! In both cases we mimic the bahaviour of the original BLAS
! Level 1 routine (Lawson et al, Algorithm 539: Basic Linear 
! Algebra Subprograms for Fortran Usage, ACM TOMS, 5(3), Sept 1979,
! pp 324--325.)
!
! n<=0 is taken to define a null vector. We return a norm
!      value of zero and we do not set any of the IEEE status
!      flags. This condition is tested first
!
! incx<=0 also returns a norm value of zero in line with
!      other implementations. 
!
! NOTE: If both n<=0 and incx<=0 on input only n<=0 may be tested.
!
      y = zero
      IF (n<=0 .OR. incx<=0) THEN
        RETURN
      END IF

! Save the current IEEE halting mode flags.
      CALL ieee_get_halting_mode(ieee_all, haltingFlags)

      infInInput = .FALSE.
      nanInInput = .FALSE.

! Set the value used to determine if scaling is required
! due to the presence of large elements. This calculation
! may cause the inexact flag to be set so we reset all
! the flags after this calculation to allow us to determine 
! whether or not the norm computation was exact.
      big = hugel/sqrt(real(2*n,kind=kind(zero)))

! This loop forces a single RETURN after the EXIT from the loop.
! Some compilers may complain about a DO loop that does not loop!
block:  DO

! Turn on non-stop arithmetic and set all the status flags to
! FALSE (we reset the state we inherited on exit)
      CALL ieee_set_halting_mode(ieee_all, .FALSE.)
      CALL ieee_set_flag(ieee_all, .FALSE.)

      ahat = zero
      norm = zero
      s = zero
! The cases n <= 0 or incx <= 0 have already been dealt with
      DO i = 1, (n-1)*incx + 1, incx
        xr = real(x(i), kind=kind(zero))
        IF (ieee_is_finite(xr)) THEN
! May need to scale the vector to prevent destructive
! overflow or underflow.
          ahat = max(ahat, abs(xr))
        ELSE
! Either Inf or NaN can trigger .FALSE. in the above IF test.
          IF (ieee_is_nan(xr)) THEN
            s = ieee_value(s, ieee_quiet_nan)
! Even though a NaN was seen there may still be Infs in the
! input vector so we to continue the scan
            CYCLE
          ELSE
! If any element is infinite then the result is infinite.
! Return with a positive infinite result.
            y = ieee_value(y, ieee_positive_inf)
            infInInput = .TRUE.
            EXIT block
          END IF
        END IF

! If we have already seen a Nan in the input vector
! we need to keep looking in case we find an Inf which
! overrides the Nan. However we don't need to compute
! the compensated summation.
        IF (nanInInput) CYCLE

        IF (ahat>=big) THEN
! Scaling is used if ahat is large enough -- we continue to
! scan the input vector for NaN and Inf values.
! Note that this strategy prevents an overflow being triggered
! when collecting the unscaled sum
          CYCLE
        ELSE
! Otherwise update sum using compensated summation
          s = s + xr*xr
          t = norm
          norm = t + s
          s = (t-norm) + s
        END IF
! The imaginary component of x(i) is dealt with in the same way
! as the real component
        xi = aimag(x(i))
        IF (ieee_is_finite(xi)) THEN
          ahat = max(ahat, abs(xi))
        ELSE
          IF (ieee_is_nan(xi)) THEN
            s = ieee_value(s, ieee_quiet_nan)
            CYCLE
          ELSE
            y = ieee_value(y, ieee_positive_inf)
            infInInput = .TRUE.
            EXIT block
          END IF
        END IF
        IF (ahat>=big) THEN
          CYCLE
        ELSE
          s = s + xi*xi
          t = norm
          norm = t + s
          s = (t-norm) + s
        END IF

      END DO

! Filter out NaN result.  This may occur if there were any 
! NaNs (signaling or quiet) in the input vector.
! Note: this test will not be reached if any Inf values
!       were detected in the input vector.
      IF (ieee_is_nan(s)) THEN
        y = s
        EXIT block
      END IF
! Test whether scaling by  sc /= 1  has been triggered
      IF (ahat>=big) THEN
        sc = tinyl
      ELSE IF (ahat<=tinyu) THEN
! Maximum element small enough to require scaling to prevent
! destructive underflow.
        sc = hugeU
      ELSE
! No scaling required; set result and return.
        y = sqrt(norm)
        EXIT block
      END IF

! Scaling is required and another pass over the data is made.
! This may be a third pass, thanks to using the naive loop first.
      norm = zero
      s = zero

! Reset any flags that may have been triggered in the computation
! up to this point. Overflow is not a problem here see comments
! above. 
      CALL ieee_set_flag(ieee_underflow, .FALSE.)
      CALL ieee_set_flag(ieee_inexact, .FALSE.)

! Form the scaled sum, compute the final result and return.
      DO i = 1, (n-1)*incx + 1, incx
! Add in scaled real component
        xr = real(x(i), kind=kind(zero))
        s = s + SCALE(xr,sc)*SCALE(xr,sc)
        t = norm
        norm = t + s
        s = (t-norm) + s
! Add in scaled imaginary component
        xi = aimag(x(i))
        s = s + SCALE(xi,sc)*SCALE(xi,sc)
        t = norm
        norm = t + s
        s = (t-norm) + s
      END DO
      y = sqrt(norm)*SCALE(one,-sc)
      EXIT block
    END DO block
