      REAL (wp), PARAMETER :: two = 2.0E0_wp, one = 1.0E0_wp, &
        zero = 0.0E0_wp, sixtyFive = 65.0E0_wp, three = 3.0E0_wp, &
        four = 4.0E0_wp, five = 5.0E0_wp, six = 6.0E0_wp, &
        seven = 7.0E0_wp, nine = 9.0E0_wp, ten = 10.0E0_wp, &
        eleven = 11.0E0_wp, twelve = 12.0E0_wp, &
        thirteen = 13.0E0_wp, fourteen = 14.0E0_wp, &
        seventeen = 17.0E0_wp, eighteen = 18.0E0_wp, &
        twentythree = 23.0E0_wp, &
        twentyfour = 24.0E0_wp, twentyfive = 25.0E0_wp, &
        twentynine = 29.0E0_wp, thirty= 30.0E0_wp, &
        thirtyeight = 38.0E0_wp, &
        fortythree = 43.0E0_wp, fortyseven = 47.0E0_wp, &
        fortyeight = 48.0E0_wp, threeSixFive = 365.0E0_wp

! Logical to control when headings are to be printed
! in the case of minimal output request
      LOGICAL :: headingsOutput = .FALSE.

! The data type testInfoType is used to store the definition
! of a test, the expected computed value and returned IEEE
! status flags, the returned computed value and the returned IEEE
! status flags, and a title/short description of the test which
! is available for output.
!
! A short description of each component follows:
!
! testNo is the test number associated with the test. This is used
!        to identify the particular test in the output. To add 
!        extra tests consult the user manual.
!
! testDescript contains a short description of the test and is
!        output at some levels of output; see user manual for
!        details.
!
! The next three components define the data to be used in the test.
! The call to an nrm2 routine is of the form
!        returnedNorm = *nrm2(nVal, inVector, incxVal)
!
! inVector is the data for the real array -- for details of how the
!        equivalent complex vector is generated see the user manual.
!
! nVal is the number of elements to be used in computing the norm
!
! incx is the gap to be used between elements; elements used are
!        (1, incx+1, 2*incx+1, ..., (nVal-1)*incx + 1)      
!
! initialStatus defines the IEEE status flags on entry to the nrm2
!        routine. These may be used for two purposes:
!
!         1) set to all FALSE to test that the nrm2 implementation
!         under test only signals the correct flags,
!
!         2) The flags can also be set to test that the correct union
!         of flags is returned after executing the nrm2 routine,
!         i.e., the call to the nrm2 routine does not adversely
!         affect any existing settings
!
! expectedNorm defines the expected return value from the call to
!        the *nrm2 routine. This will be the same value for the
!        real and complex calls for a given precision. This should
!        be the correctly rounded representation of the exact value.
!        
! expectedStatus defines the expected values of the IEEE status flags
!        on exit from the nrm2 routine. This should take account of
!        the initial setting.
!
! returnedNorm is the computed value returned by the call
!        to the nrm2 routine.
!
! returnedStatus is the vector of IEEE status flags following the
!        call to the nrm2 routine.
! 
      TYPE testInfoType
        INTEGER :: testNo
        CHARACTER(LEN=:), ALLOCATABLE :: testDescript
        REAL(wp), POINTER :: inVector(:)
        INTEGER :: nVal, incxVal
        LOGICAL :: initialStatus(5)
        REAL (wp) :: expectedNorm
        LOGICAL :: expectedStatus(5)
        REAL (wp) :: returnedNorm
        LOGICAL :: returnedStatus(5)
      END TYPE testInfoType

! Parameters defining machine arithmetic.
! Huge = 2**omega (actually slightly greater than huge)
! epsilon = 2**eps (machine epsilon)
      
      INTEGER, PARAMETER :: omega=EXPONENT(HUGE(zero)), &
                            eps=EXPONENT(EPSILON(zero))-1
      INTEGER, PARAMETER :: nvalPow = 10

! Parameters used for boundary cases with Blue's algorithm
      integer,parameter :: Dig=digits(two)
      integer,parameter :: Emin=minexponent(two), Emax=maxexponent(two)
      integer,parameter :: LCb = ceiling(REAL((Emin-1),KIND=wp)/two)
      integer,parameter :: UCb = floor(REAL((Emax-Dig+1),KIND=wp)/two)
      REAL(wp) :: capB = scale(one, UCb), lowB = scale(one, LCb)

      INTEGER :: ex

        TYPE (testInfoType) :: testInfo
        REAL (wp) :: pow, pow2, a, v, infVal
        INTEGER :: n, e1, e2, halfeps, i, intv, intv1, intv2
        LOGICAL :: gradual
        REAL(wp), ALLOCATABLE, TARGET :: x(:)
      LOGICAL, PARAMETER :: allFalse(5) = [(.FALSE., i=1,5)]

        ASSOCIATE(testNo=>testInfo%testNo, &
                  expStat=>testInfo%expectedStatus, &
                  expRes =>testInfo%expectedNorm, &
                  nVal => testInfo%nVal, &
                  incxVal => testInfo%incxVal, &
                  initStat => testInfo%initialStatus)

        CALL ieee_set_halting_mode(ieee_all, .FALSE.)

        testNo = 0
        halfeps = FLOOR(REAL(eps/2))
        CALL getVals(intv1, intv2)
        infVal = ieee_value(zero, ieee_positive_inf)

! Null array -- should return zero.
! No element of x should be accessed
        ALLOCATE (x(0))
        testInfo%inVector=>x
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat = [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.]
        expRes = zero
        testNo = testNo + 1
        testInfo%testdescript = 'null array'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Illegal value of incx -- should return zero
! No element of x should be accessed
        ALLOCATE (x(1))
        testInfo%inVector=>x
        nVal = SIZE(x)
        incxVal = 0
        initStat = allFalse
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.]
        expRes = zero
        testNo = testNo + 1
        testInfo%testdescript = 'Illegal value of incx'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Simple data generating representable result
        ALLOCATE (x(1))
        testInfo%inVector=>x
        x = [ three ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.]
        expRes = three 
        testNo = testNo + 1
        testInfo%testdescript = 'n=1: simple positive value'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Simple data generating representable result
! with incx = 2 which not have any effect since
! there is only one element.
        ALLOCATE (x(1))
        testInfo%inVector=>x
        x = [ -three ]
        nVal = SIZE(x)
        incxVal = 2
        initStat = allFalse
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.]
        expRes = three 
        testNo = testNo + 1
        testInfo%testdescript = 'n=1: simple negative value'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Simple data generating representable result -- boundary case
        ALLOCATE (x(1))
        testInfo%inVector=>x
        x = [ HUGE(zero) ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
! The exact value for the next two tests may be represented as
! an IEEE f-p number in both single and double precision; hence,
! we set the expected inexact flag to FALSE.
! However, the inexact flag may trigger due to scaling,
! squaring and the square root operations in Kahan as 
! HUGE is not an exact power of 2
! Other methods, for example, those that treat n=1 as a
! special case should get an exact result
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.]
        expRes = HUGE(zero)  
        testNo = testNo + 1
        testInfo%testdescript = 'n=1: boundary Huge'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Simple data generating representable result -- boundary case
        ALLOCATE (x(1))
        testInfo%inVector=>x
        x = [ -HUGE(zero) ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.]
        expRes = HUGE(zero)  
        testNo = testNo + 1
        testInfo%testdescript = 'n=1: boundary -Huge'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Simple data generating representable result -- boundary case
        ALLOCATE (x(1))
        testInfo%inVector=>x
        x = [ TINY(zero) ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.]
        expRes = TINY(zero)  
        testNo = testNo + 1
        testInfo%testdescript = 'n=1: boundary Tiny'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Simple data generating representable result -- boundary case
        ALLOCATE (x(1))
        testInfo%inVector=>x
        x = [ -TINY(zero) ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.]
        expRes = TINY(zero)  
        testNo = testNo + 1
        testInfo%testdescript = 'n=1: boundary -Tiny'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Vector of length 1 -- positive infinity
        ALLOCATE (x(1))
        testInfo%inVector=>x
        x = [ ieee_value(one,ieee_positive_inf) ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat = [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.]
        expRes = ieee_value(one,ieee_positive_inf) 
        testNo = testNo + 1
        testInfo%testdescript = 'n=1; x(1)=Inf'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Vector of length 1 -- negative infinity
        ALLOCATE (x(1))
        testInfo%inVector=>x
        x = [ ieee_value(one,ieee_negative_inf) ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat = [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.]
        expRes = ieee_value(one,ieee_positive_inf) 
        testNo = testNo + 1
        testInfo%testdescript = 'n=1; x(1)=-Inf'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Vector of length 1 -- signaling NaN
        ALLOCATE (x(1))
        testInfo%inVector=>x
        x = [ ieee_value(one,ieee_signaling_nan) ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat = [.FALSE.,.FALSE.,.TRUE.,.FALSE.,.FALSE.]
        expRes = ieee_value(one,ieee_quiet_nan) 
        testNo = testNo + 1
        testInfo%testdescript = 'n=1; x(1)=sNan'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Vector of length 1 -- quiet NaN
        ALLOCATE (x(1))
        testInfo%inVector=>x
        x = [ ieee_value(one,ieee_quiet_nan) ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat = [.FALSE.,.FALSE.,.TRUE.,.FALSE.,.FALSE.]
        expRes = ieee_value(one,ieee_quiet_nan) 
        testNo = testNo + 1
        testInfo%testdescript = 'n=1; x(1)=qNan'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! All data values zero and n>1. This may pick up problems in some
! implementation if scaling is used on all elements
        ALLOCATE (x(10))
        testInfo%inVector=>x
        x =  zero
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.]
        expRes = zero  
        testNo = testNo + 1
        testInfo%testdescript = 'n=10: All elements zero'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Simple data generating representable result -- boundary case
        ALLOCATE (x(5))
        testInfo%inVector=>x
        x = [ zero, zero, HUGE(zero), zero, zero ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.TRUE.]
        expRes = HUGE(zero)  
        testNo = testNo + 1
        testInfo%testdescript = 'n=5: Huge element with rest zero'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Vector of length > 1 -- positive infinity
        ALLOCATE (x(3))
        testInfo%inVector=>x
        x = [ two, -one, ieee_value(one,ieee_positive_inf) ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat = [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.]
        expRes = ieee_value(one,ieee_positive_inf) 
        testNo = testNo + 1
        testInfo%testdescript = 'n>1; Inf element'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Vector of length >1 -- negative infinity
        ALLOCATE (x(3))
        testInfo%inVector=>x
        x = [ two, ieee_value(one,ieee_negative_inf), -one ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat = [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.]
        expRes = ieee_value(one,ieee_positive_inf) 
        testNo = testNo + 1
        testInfo%testdescript = 'n>1; -Inf element'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Vector of length >1 -- negative infinity wins with sNaN
        ALLOCATE (x(3))
        testInfo%inVector=>x
        x = [ two, ieee_value(one,ieee_negative_inf), &
                   ieee_value(one, ieee_signaling_nan)]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat = [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.]
        expRes = ieee_value(one,ieee_positive_inf) 
        testNo = testNo + 1
        testInfo%testdescript = 'n>1; -Inf element with sNaN also present'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Vector of length >1 -- signaling NaN
        ALLOCATE (x(3))
        testInfo%inVector=>x
        x = [ two, ieee_value(one,ieee_signaling_nan), -one ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat = [.FALSE.,.FALSE.,.TRUE.,.FALSE.,.FALSE.]
        expRes = ieee_value(one,ieee_quiet_nan) 
        testNo = testNo + 1
        testInfo%testdescript = 'n>1; x(1)= signalling NaN'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Vector of length >1 -- quiet NaN
        ALLOCATE (x(3))
        testInfo%inVector=>x
        x = [ ieee_value(one,ieee_quiet_nan), two, -one ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat = [.FALSE.,.FALSE.,.TRUE.,.FALSE.,.FALSE.]
        expRes = ieee_value(one,ieee_quiet_nan) 
        testNo = testNo + 1
        testInfo%testdescript = 'n>1; x(1)= quiet NaN'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Vector of length >1 -- mixed -- inf wins
        ALLOCATE (x(4))
        testInfo%inVector=>x
        x = [ ieee_value(one,ieee_quiet_nan), &
               ieee_value(one,ieee_signaling_nan), &
               ieee_value(one,ieee_negative_inf), &
               ieee_value(one,ieee_signaling_nan) ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat = [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.]
        expRes = ieee_value(one,ieee_positive_inf) 
        testNo = testNo + 1
        testInfo%testdescript = 'n>1; mixed Nans and Infs'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Obvious overflow -- both values maxReal
        ALLOCATE (x(2))
        testInfo%inVector=>x
        x = [ HUGE(zero), HUGE(zero) ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat =  [.TRUE.,.FALSE.,.FALSE.,.FALSE.,.TRUE.]
        expRes = infVal
        testNo = testNo + 1
        testInfo%testdescript = 'Obvious overflow'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Boundary overflow value -- this should just trip
        ALLOCATE (x(2))
        testInfo%inVector=>x
        x = [ HUGE(zero), ieee_scalb(one,omega+halfeps) ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat =  [.TRUE.,.FALSE.,.FALSE.,.FALSE.,.TRUE.]
        expRes = infVal
        testNo = testNo + 1
        testInfo%testdescript = 'Boundary value causing overflow'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Boundary overflow value -- this should just not trip an overflow
! but the inexact flag should get set
        ALLOCATE (x(2))
        testInfo%inVector=>x
        x = [ HUGE(zero), ieee_scalb(one,omega+halfeps-1) ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.TRUE.]
        expRes = HUGE(zero) 
        testNo = testNo + 1
        testInfo%testdescript = 'Boundary value not causing overflow'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Check underflow doesn't occur for very small values
        ALLOCATE (x(4))
        testInfo%inVector=>x
        v = TINY(zero)
        x = [ v,v,v,v ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.]
        expRes = two*v 
        testNo = testNo + 1
        testInfo%testdescript = 'No underflow when dealing with very small values'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Simple data generating representable result
        ALLOCATE (x(3))
        testInfo%inVector=>x
        x = [ nine, eighteen, thirtyeight ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.]
        expRes = fortythree 
        testNo = testNo + 1
        testInfo%testdescript = 'Simple data for exact result'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Simple data generating inexact result, n>2
        ALLOCATE (x(3))
        testInfo%inVector=>x
        x = [ ten, eleven, twelve ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.TRUE.]
        expRes = SQRT(threeSixFive)
        testNo = testNo + 1
        testInfo%testdescript = 'Simple data for inexact result'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Simple data generating representable result (n>>3)
        intv = intv1
        v = REAL(intv, KIND(zero))
        ALLOCATE (x(intv*intv))
        testInfo%inVector=>x
        a = (v**4 - twentyfour*v*v -twentyfive)/fortyeight
        x = [ (a+REAL(i,KIND(zero)),  i= 0,intv*intv-1)]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.]
        expRes = ((v**5 + fortyseven*v)/fortyeight) 
        testNo = testNo + 1
        testInfo%testdescript = 'Simple data for representable result (exact)'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Simple data generating representable result (inexact flag set)
        intv = intv2
        v = REAL(intv, KIND(zero))
        ALLOCATE (x(intv*intv))
        testInfo%inVector=>x
        a = (v**4 - twentyfour*v*v -twentyfive)/fortyeight
        x = [ (a+REAL(i,KIND(zero)),  i= 0,intv*intv-1)]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.TRUE.]
        expRes = ((v**5 + fortyseven*v)/fortyeight) 
        testNo = testNo + 1
        testInfo%testdescript = 'Simple data for representable result (inexact)'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Simple loop will overflow -- Kahan gives exact result
        ALLOCATE (x(4))
        testInfo%inVector=>x
        pow = ieee_scalb(one, (omega/2 - 1))
        x = [ pow, pow, pow, pow ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.]
        expRes = two*pow
        testNo = testNo + 1
        testInfo%testdescript = 'Simple loop overflow; Kahan exact'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Underflow for simple loop -- Kahan exact
        ALLOCATE (x(4))
        testInfo%inVector=>x
        pow = ieee_scalb(one, -(omega/2))
        x = [ pow, pow, pow, pow ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.]
        expRes = two*pow
        testNo = testNo + 1
        testInfo%testdescript = 'Underflow for simple loop -- Kahan exact'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Simple loop will overflow -- Kahan gives exact result
        ALLOCATE (x(4))
        testInfo%inVector=>x
        pow = ieee_scalb(one, (omega/2 - 1))
        x = [ nine*pow, eleven*pow, thirteen*pow, twentythree*pow ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.]
        expRes = thirty*pow
        testNo = testNo + 1
        testInfo%testdescript = 'Simple loop overflow; tests scaling'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Underflow for simple loop -- Kahan exact
        ALLOCATE (x(4))
        testInfo%inVector=>x
        pow = ieee_scalb(one, -(omega/2))
        x = [ nine*pow, eleven*pow, thirteen*pow, twentythree*pow ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.]
        expRes = thirty*pow
        testNo = testNo + 1
        testInfo%testdescript = 'Underflow for simple loop -- tests scaling'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Simple loop will overflow -- Kahan gives inexact result
        ALLOCATE (x(5))
        testInfo%inVector=>x
        pow = ieee_scalb(one, (omega/2 - 1))
        pow2 = ieee_scalb(one, (omega/2 - 3))
        x = [ pow, pow, pow, pow, pow2 ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.TRUE.]
        expRes = SQRT(sixtyFive)*pow2
        testNo = testNo + 1
        testInfo%testdescript = 'Simple loop overflow; Kahan inexact'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Underflow for simple loop -- Kahan inexact
        ALLOCATE (x(5))
        testInfo%inVector=>x
        pow = ieee_scalb(one, -(omega/2))
        x = [ pow, pow, pow, pow, two*pow ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.TRUE.]
        expRes = SQRT(two)*pow*two
        testNo = testNo + 1
        testInfo%testdescript = &
          'Underflow for simple loop -- Kahan inexact'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Underflow test -- underflow caused by loss of accuracy as the tiny
! condition has been met
        n = 4
        ALLOCATE (x(n))
        testInfo%inVector=>x
        pow = ieee_scalb(NEAREST(one,-one), -(omega/2))
        x = [ pow, pow, pow, pow ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.TRUE.]
        expRes = two*pow
        testNo = testNo + 1
        testInfo%testdescript = &
          'Array elements, intermediate gradual underflow, inexact result'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! In this test a simple, naive loop will suffer since
! the element in x(1) is large enough to ensure that all
! following elements will not contribute to the partial
! sum, although the total contribution from these elements
! is significant.  The use of Kahan's compensated summation
! means that the result is computed exactly.
        n = 2**nvalPow + 1
        ALLOCATE (x(n))
        testInfo%inVector=>x
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        e1 = 0
        e2 = halfeps - 2
        pow = ieee_scalb(one, e1)
        pow2 = ieee_scalb(one, e2)
        x(1) = pow
        x(2:n) = pow2
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.TRUE.]
        expRes = pow*SQRT(one+ieee_scalb(one,2*e2+nvalPow))
        testNo = testNo + 1
        testInfo%testdescript = &
          'Large first element followed by many smaller elements'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! This is the same as the previous test except that by reversing
! the order of the elements the naive algorithm first accumulates
! the sum of the squares of the smaller elements.
        n = 2**nvalPow + 1
        ALLOCATE (x(n))
        testInfo%inVector=>x
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        e1 = 0
        e2 = halfeps - 2
        pow = ieee_scalb(one, e1)
        pow2 = ieee_scalb(one, e2)
        x(1:n-1) = pow2
        x(n) = pow
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.TRUE.]
        expRes = pow*SQRT(one+ieee_scalb(one,2*e2+nvalPow))
        testNo = testNo + 1
        testInfo%testdescript = &
          'Large last element following  many smaller elements'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Vector of length = 5 -- incx = 2, n=3 -- exact result
        ALLOCATE (x(5))
        testInfo%inVector=>x
        x = [two, five, three, nine, six ]
        nVal = 3
        incxVal = 2
        initStat = allFalse
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.]
        expRes = seven
        testNo = testNo + 1
        testInfo%testdescript = 'incx = 2, exact result'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Vector of length = 4 -- incx = 3, n=2 -- inexact result
        ALLOCATE (x(4))
        testInfo%inVector=>x
        x = [two, three, four, five]
        nVal = 2
        incxVal = 3
        initStat = allFalse
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.TRUE.]
        expRes = SQRT(twentynine)
        testNo = testNo + 1
        testInfo%testdescript = 'incx = 3, inexact result'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Vector of length =5 -- incx=2, n=3 -- vector contains
! Inf and NaN but such elements should not be accessed
        ALLOCATE (x(5))
        testInfo%inVector=>x
        x = [two,ieee_value(one,ieee_positive_inf) , three, &
             ieee_value(one,ieee_quiet_nan) , six ]
        nVal = 3
        incxVal = 2
        initStat = allFalse
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.]
        expRes = seven
        testNo = testNo + 1
        testInfo%testdescript = 'incx = 2, Inf and qNan present in input vector'&
                       // ' but should not be accessed'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! The next two tests are included to check the correct functioning
! of Blue's algorithm at the break points between medium and big 
! values and between small and medium values
        ALLOCATE (x(2))
        testInfo%inVector=>x
        ex = EXPONENT(capB)
        x = [scale(one, ex-1), scale(one,ex+1)]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.TRUE.]
        expRes = SQRT(seventeen)*x(1)
        testNo = testNo + 1
        testInfo%testdescript = 'Test on medium/big scaling boundary of Blue''s algorithm'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

        ALLOCATE (x(2))
        testInfo%inVector=>x
        ex = EXPONENT(lowB)
        x = [scale(one, ex-1), scale(one,ex+1)]
        nVal = SIZE(x)
        incxVal = 1
        initStat = allFalse
        expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.TRUE.]
        expRes = SQRT(seventeen)*x(1)
        testNo = testNo + 1
        testInfo%testdescript = 'Test on small/medium scaling boundary of Blue''s algorithm'
        CALL indivtest(testInfo)
        DEALLOCATE (x)
     
! Simple data generating exact result
! Set all IEEE status flags true on entry; all should be true
! on return.
        ALLOCATE (x(2))
        testInfo%inVector=>x
        x = [ five, twelve ]
        nVal = SIZE(x)
        incxVal = 1
        initStat =  [.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.]
        expStat =  [.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.]
        expRes = thirteen 
        testNo = testNo + 1
        testInfo%testdescript = 'Status flags check -- simple, exact'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Simple data generating inexact result
! Set all IEEE status flags true on entry; all should be true
! on return.
        ALLOCATE (x(2))
        testInfo%inVector=>x
        x = [ seven, nine ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = [.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.]
        expStat =  [.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.]
        expRes = SQRT(two*sixtyfive)
        testNo = testNo + 1
        testInfo%testdescript = 'Status flags check -- simple, inexact'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Simple data generating inexact result
! Set all IEEE status flags but inexact true on entry;
! all should be true on return.
        ALLOCATE (x(2))
        testInfo%inVector=>x
        x = [ seven, nine ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = [.TRUE.,.TRUE.,.TRUE.,.TRUE.,.FALSE.]
        expStat =  [.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.]
        expRes = SQRT(two*sixtyfive)
        testNo = testNo + 1
        testInfo%testdescript = 'Status flags check -- simple, inexact, overwrite'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Simple loop will overflow -- Kahan gives exact result
! Set all IEEE status flags true on entry;
! all should be true on return.
        ALLOCATE (x(4))
        testInfo%inVector=>x
        pow = ieee_scalb(one, (omega/2 - 1))
        x = [ pow, pow, pow, pow ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = [.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.]
        expStat =  [.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.]
        expRes = two*pow
        testNo = testNo + 1
        testInfo%testdescript = 'Status flags check -- Kahan, exact'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Simple loop will overflow -- Kahan gives inexact result
! Set all IEEE status flags true on entry; all should be true
! on return.
        ALLOCATE (x(5))
        testInfo%inVector=>x
        pow = ieee_scalb(one, (omega/2 - 1))
        pow2 = ieee_scalb(one, (omega/2 - 3))
        x = [ pow, pow, pow, pow, pow2 ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = [.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.]
        expStat =  [.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.]
        expRes = SQRT(sixtyFive)*pow2
        testNo = testNo + 1
        testInfo%testdescript = 'Status flags check -- Kahan, inexact'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! Simple loop will overflow -- Kahan gives inexact result
! Set all IEEE status flags except inexact true on entry;
! all should be true on return.
        ALLOCATE (x(5))
        testInfo%inVector=>x
        pow = ieee_scalb(one, (omega/2 - 1))
        pow2 = ieee_scalb(one, (omega/2 - 3))
        x = [ pow, pow, pow, pow, pow2 ]
        nVal = SIZE(x)
        incxVal = 1
        initStat = [.TRUE.,.TRUE.,.TRUE.,.TRUE.,.FALSE.]
        expStat =  [.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.]
        expRes = SQRT(sixtyFive)*pow2
        testNo = testNo + 1
        testInfo%testdescript = 'Status flags check -- Kahan, inexact, overwrite'
        CALL indivtest(testInfo)
        DEALLOCATE (x)

! The final tests require denormalized numbers and are only
! carried out if the compiler/hardware allows for gradual underflow
        
        IF (ieee_support_underflow_control(one)) THEN
          CALL ieee_get_underflow_mode(gradual)
          IF (.NOT. gradual) THEN
            CALL ieee_set_underflow_mode(.TRUE.)
          END IF

          ALLOCATE (x(4))
          testInfo%inVector=>x
          v = TINY(zero)/four
          x = [ v,v,v,v ]
          nVal = SIZE(x)
          incxVal = 1
          initStat = allFalse
          expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.]
          expRes = two*v 
          testNo = testNo + 1
          testInfo%testdescript = 'Simple test for denormalized numbers'
          CALL indivtest(testInfo)
          DEALLOCATE (x)

          ALLOCATE (x(4))
          testInfo%inVector=>x
! Set v to the smallest representable real number
          v = ieee_scalb(one, (minexponent(one)-digits(one)))
          x = [ v,v,v,v ]
          nVal = SIZE(x)
          incxVal = 1
          initStat = allFalse
          expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.]
          expRes = two*v 
          testNo = testNo + 1
          testInfo%testdescript = 'Harder test for denormalized numbers'
          CALL indivtest(testInfo)
          DEALLOCATE (x)

          ALLOCATE (x(4))
          testInfo%inVector=>x
          v = ieee_next_after(TINY(x), two)
          x = [ v,v,v,v ]
          nVal = SIZE(x)
          incxVal = 1
          initStat = allFalse
          expStat =  [.FALSE.,.FALSE.,.FALSE.,.FALSE.,.TRUE.]
          expRes = two*v 
          testNo = testNo + 1
          testInfo%testdescript = 'Simple test for denormalized numbers'
          CALL indivtest(testInfo)
          DEALLOCATE (x)
        ELSE
          WRITE(*, '(''Gradual underflow not supported'')')
        END IF
! Set number of tests executed
        nTests = testNo
        END ASSOCIATE

! Any new tests should be added here in the first instance to
! prevent misaligning test numbers with the descriptions given
! in the user manual.

      CONTAINS
        SUBROUTINE getVals(intv1, intv2)
        INTEGER, INTENT(OUT) :: intv1, intv2
  ! Determine the values, intv1 and intv2, such that for 
  ! x={(a+i), i=0,intv-1} the then integer value returned
  ! by nrm2 can be computed exactly for intv=intv1 while
  ! intv=intv2 will cause an inexact value to be generated.
  ! 
  ! We determine these values by calculating the exact
  ! result and choosing intv1 and intv2 to be the consecutive
  ! valid parameters that generate values with less/more
  ! digits than will fit into the f-p representation defined
  ! by wp.
  !
  
        REAL(wp) :: b, val2, x
  
        x = set_exponent(nearest(one, -one), digits(one))
        intv2 = 5
        intv1 = intv2
  
        DO 
          val2 = REAL(intv2, wp)
          b = val2*(fortyseven + val2*val2*val2*val2)/fortyeight
          IF (b*b>x) EXIT
          intv1 = intv2
          intv2 = intv2 + 2
  ! The value for intv2 must not be divisible by either 2 or 3
  ! If it is divisible by 3 go to the next odd value
          IF (MOD(intv2,3) == 0) intv2 = intv2 + 2
        ENDDO

      END SUBROUTINE getVals
  
        SUBROUTINE detailedOutput(testInfo, dataType)
        USE checkTests, ONLY:nFailedTests, outputRes, compareRes, &
            outputError, outputFlagChars, checkStatusFlags, &
            getJustValues
        TYPE(testInfoType), INTENT(IN) :: testInfo
        CHARACTER, INTENT(IN) :: dataType
      ! Routine to perform detailed output of the test results
      ! This is invoked by setting the outputLevel to 3
        LOGICAL :: okval, okflags, justValues

        justValues = getJustValues()
      ! Output header
        WRITE(*,'(''Test '',i3,'': '',a)') testInfo%testNo, testInfo%testDescript
        IF (dataType == 'R') THEN
          WRITE(*, '(''Using REAL input vector'')')
        ELSE
          WRITE(*, '(''Using COMPLEX input vector'')')
        END IF
      ! Output information regarding the returned result
        WRITE(*,'(''Result returned ='')', ADVANCE='NO')
        CALL outputRes(testInfo%returnedNorm)
        okval = compareRes(testInfo%expectedNorm, testInfo%returnedNorm)
        IF (okval) THEN
          WRITE(*, '(5X,''  Correct  '')')
        ELSE
          WRITE(*, '(5X,'' **Incorrect**'')')
          WRITE(*,'(''Expected result ='')', ADVANCE='NO')
          CALL outputRes(testInfo%expectedNorm)
          WRITE(*,'(''  Error ='')', ADVANCE='NO')
          CALL outputError(testInfo%expectedNorm, testInfo%returnedNorm)
          WRITE(*,'()')
        ENDIF
        IF (justValues) THEN
          okflags = .TRUE.
        ELSE
      ! Output information regarding the returned ieee status flags
          WRITE(*,'(''IEEE status flags returned: '')', ADVANCE='NO')
          CALL outputFlagChars(testInfo%expectedStatus)
          okflags = checkStatusFlags(testInfo%expectedStatus, &
                                     testInfo%returnedStatus)
          IF (okflags) THEN
            WRITE(*, '(5X,''  Correct  '')')
          ELSE
            WRITE(*, '(5X,'' **Incorrect**'')')
            WRITE(*,'(18x,''expected: '')', ADVANCE='NO')
            CALL outputFlagChars(testInfo%returnedStatus)
            WRITE(*,'()')
          END IF
        END IF
      
        IF (.NOT.(okval .AND. okflags)) THEN
          nFailedTests = nFailedTests + 1
          WRITE(*, '(''********* TEST FAILED **************'')')
        END IF

        WRITE(*,'(''-----------------------------'')')
        WRITE(*,'()')
      
        END SUBROUTINE detailedOutput
  
        SUBROUTINE intermediateOutput(testInfo, dataType)
        USE, INTRINSIC :: ieee_arithmetic
        USE checkTests, ONLY:nFailedTests, outputRes, compareRes, &
            outputError, outputFlagChars, checkStatusFlags, &
            getJustValues, outputNone, outputHead, outputFlagsSpace
        TYPE(testInfoType), INTENT(IN) :: testInfo
        CHARACTER, INTENT(IN) :: dataType
      ! Routine to perform detailed output of the test results
      ! This is invoked by setting the outputLevel to 3
        LOGICAL :: okval, okflags, justValues

        justValues = getJustValues()
      ! Real tests are done first output header just once
        IF (testinfo%testNo == 1 .AND. dataType == 'R') THEN
          CALL outputHead(0.0E0_wp, justValues)
        END IF
      ! Output information regarding the returned result
      ! Output the test number only for the real case
      ! Use R for real test and C for complex
        IF (dataType == 'R') THEN
          WRITE(*,'(i4,1x,a1,2x)', ADVANCE='NO')testInfo%testNo, &
            dataType
        ELSE
          WRITE(*,'(5x,a1,2x)', ADVANCE='NO')dataType
        END IF
        CALL outputRes(testInfo%returnedNorm)
        okval = compareRes(testInfo%expectedNorm, testInfo%returnedNorm)
        IF (okval) THEN
          CALL outputNone(0.0E0_wp)
        ELSE
          IF (ieee_is_finite(testInfo%expectedNorm) .AND. &
              ieee_is_finite(testInfo%returnedNorm)) THEN
            CALL outputError(testInfo%expectedNorm, testInfo%returnedNorm)
          ELSE
            CALL outputRes(testInfo%expectedNorm)
          END IF
        ENDIF
        IF (justValues) THEN
! Only values -- denote pass or fail
          IF (okval) THEN
            WRITE(*, '(''   Correct  '')')
          ELSE
            WRITE(*, '('' **Incorrect**'')')
            nFailedTests = nFailedTests + 1
          END IF

        ELSE
! Output information regarding the returned ieee status flags
          CALL outputFlagChars(testInfo%expectedStatus)
          okflags = checkStatusFlags(testInfo%expectedStatus, &
                                     testInfo%returnedStatus)
          IF (okflags .AND. okval) THEN
            WRITE(*, '(''   Correct  '')')
          ELSE
            WRITE(*, '('' **Incorrect**'')')
            IF (.NOT. okflags) THEN
! If flags are incorrect print expected as comparison
              CALL outputFlagsSpace(0.0E0_wp)
              CALL outputFlagChars(testInfo%returnedStatus)
              WRITE(*,'()')
            END IF
            nFailedTests = nFailedTests + 1
          END IF
        END IF
      
        END SUBROUTINE intermediateOutput
  
        SUBROUTINE minimalOutput(testInfo, dataType)
        USE, INTRINSIC :: ieee_arithmetic
        USE checkTests, ONLY:nFailedTests, outputRes, compareRes, &
            outputError, outputFlagChars, checkStatusFlags, &
            getJustValues, outputNone, outputHead, outputFlagsSpace
        TYPE(testInfoType), INTENT(IN) :: testInfo
        CHARACTER, INTENT(IN) :: dataType
      ! Routine to perform minimal output of the test results
      ! This is invoked by setting the outputLevel to 1
        LOGICAL :: okval, okflags, justValues

        justValues = getJustValues()
! Do the comparisons first
        okval = compareRes(testInfo%expectedNorm, testInfo%returnedNorm)
        IF (justvalues) THEN
          okflags = .TRUE.
        ELSE
          okflags = checkStatusFlags(testInfo%expectedStatus, &
                                   testInfo%returnedStatus)
        END IF

! Only print anything if there is a problem
        IF (.NOT. (okval .AND. okflags)) THEN
          IF (.NOT. headingsOutput) THEN
            headingsOutput = .TRUE.
      ! Output header 
            CALL outputHead(0.0E0_wp, justValues)
          ENDIF
      ! Output information regarding the returned result
          WRITE(*,'(i4,1x,a1,2x)', ADVANCE='NO')testInfo%testNo, &
            dataType
          CALL outputRes(testInfo%returnedNorm)
          IF (okval) THEN
            CALL outputNone(0.0E0_wp)
          ELSE
            IF (ieee_is_finite(testInfo%expectedNorm) .AND. &
                ieee_is_finite(testInfo%returnedNorm)) THEN
              CALL outputError(testInfo%expectedNorm, testInfo%returnedNorm)
            ELSE 
              CALL outputRes(testInfo%expectedNorm)
            END IF
          ENDIF
          IF (.NOT. justValues) THEN
      ! Output information regarding the returned ieee status flags
            CALL outputFlagChars(testInfo%expectedStatus)
            WRITE(*, '('' **Incorrect**'')')
            IF (.NOT. okflags) THEN
! If flags are incorrect print expected as comparison
              CALL outputFlagsSpace(0.0E0_wp)
              CALL outputFlagChars(testInfo%returnedStatus)
            END IF
          END IF 
          WRITE(*,'()')
          nFailedTests = nFailedTests + 1
        END IF
      
        END SUBROUTINE minimalOutput
