    PROGRAM sdbenchmark
! This program compares the performance (execution
! time and accuracy) of the proposed hybrid method with an
! alternative implementation of the four BLAS Level 1 routines,
! snrm2, dnrm2, scnrm2 and dznrm2, used for computing the l2
! (Euclidean) norm of a given (real or complex) vector.
! 
! The output from the program provides both timing and accuracy
! comparisons on random data. By default this data is random in
! the range (0,1).
! 
! The number of routines used in the comparison, the range of
! values used in the data vectors, the length of the data vectors
! and the the number of vectors used to obtain the results may
! all be easily changed. Please see section 3 of the user manual
! accompanying the software bundle for further details.
! 
! Advice on how to compare new implementations are also given in
! the user manual. If the comparison routines are provided in
! source form and wrapped within a module, then only the makefile
! needs to be altered. If the routines need to be provided in
! either a precompiled library or as a set of standalone routines
! (in source file or as .o files) then this code needs changing
! as well as the make file. In all cases see the user manual for
! details.

      USE set_precision, ONLY: skind, dkind
      USE nrm2hybridmod, ONLY: snrm2Hybrid=>snrm2, &
            dnrm2Hybrid=>dnrm2, scnrm2Hybrid=>scnrm2,&
            dznrm2Hybrid=>dznrm2
      USE oracle, ONLY: Errors, initialize
      USE GenerateTestVectors, ONLY: GenNrm2DataVec, &
          outputSignDesc, noChangeSigns, zeroOneRandom, &
          userDefRandom, userDefAscending, userDefDescending, &
          spUsrMaxexp, spUsrMinexp, dpUsrMinexp, dpUsrMaxexp, &
          outputVecHeading, outputRanges

      USE iso_fortran_env, ONLY: output_unit
! Should the code be required to run against routines supplied
! as either a precompiled library or as separate routines (i.e.,
! not in a module), then the following four changes need to be
! made to this program code:
!
! Change 1: Comment out the next statement (over two lines)
      USE nrm2_Other, ONLY: dnrm2, snrm2, &
          scnrm2, dznrm2,descript
!
! Change 2: NOT A CHANGE! Leave the IMPLICIT statement alone.
!
! Change 3: Remove the comment character in the six statements
!           following the IMPLICIT statement.
!
! Change 4: Change the text in the string assigned to the
!           parameter constant, descript, to identify the 
!           supplied implementation
!
      IMPLICIT NONE
!     EXTERNAL :: snrm2, dnrm2, scnrm2, dznrm2
!     REAL (skind) :: snrm2
!     COMPLEX (skind) :: scnrm2
!     REAL (dkind) :: dnrm2
!     COMPLEX (dkind) :: dznrm2
!     CHARACTER (LEN=*), PARAMETER :: descript = &
!                  'Library routines'

      INTEGER :: codes, j, k, kases(4), ncodes
! The following statements set up the sizes of n-vectors to be
! generated for testing the two sets of routines and how many
! of each size will be used to obtains average execution times
! and maximum relative errors.
! 
! The default is to use a sequence of values that increase
! by a factor of ten in size and decrease by a factor of
! ten in repeats. Any values may be used.
      INTEGER, PARAMETER :: nsizes = 5
      INTEGER :: sizes(nsizes) = [ (10**k,k=1,nsizes) ]
      INTEGER :: repeats(nsizes) = &
        [ (50*10**k, k=nsizes,1,-1) ]
!
      REAL (skind) :: minmaxulp(nsizes, 3), secspercall(nsizes)
      REAL (skind) :: minmaxulpOther(nsizes,3), &
        secspercallOther(nsizes)

      REAL (skind), PARAMETER :: one_sp = 1.0E0_skind, &
        maxv = huge(one_sp), zero_sp=0.0E0_skind, &
        thousand = 1000.0E0_skind
        

! Parameters used to alter the type of input used and the
! benchmarks performed.

! Set default data choice to be random values in the range
! (0,1) with the sign of each element unchanged. This is
! equivalent to option 2 (all signs positive)
      INTEGER :: dataDesc = zeroOneRandom, &
                 signElts = noChangeSigns
! Apply the bench mark test to both precisions 
! or just the single or just the double. Default is both
      INTEGER, PARAMETER :: bothSandD=0, singleOnly=1, &
                            doubleOnly=2
! Apply the bench mark test to both types 
! or just real or just complex. Default is both
      INTEGER, PARAMETER :: bothRandC=0, realOnly=1, &
                            complexOnly=2
! Perform both accuracy and timing tests or just accuracy or
! just timing. Default is to do both
      INTEGER, PARAMETER :: bothTandA=0, timingsOnly=1,&
                            accuracyOnly=2
! Set defaults; these may be overridden by providing the 
! preferences via a datafile -- see bdDataFile below and
! the example file provided with the package.
      INTEGER :: precs=bothSandD, timeAcc=bothTandA, &
                   types=bothRandC
      LOGICAL :: dpSet
      INTEGER :: i, nRanges

      LOGICAL :: dataFileExists

! Filename and input channel for data file
      CHARACTER(LEN=*), PARAMETER :: bdDataFile='BenchData.dat'
      INTEGER, PARAMETER :: dataChan=5
      
      WRITE (output_unit, '(A)') &
        'Benchmark BLAS-1 Euclidean Norm Routines.', &
        'Compare the new hybrid version with ',&
        descript

! If a data file is present (as bdDataFile) then use it
      INQUIRE(file=bdDataFile, exist=dataFileExists)
      IF (dataFileExists) THEN
        OPEN(unit=dataChan, file=bdDataFile, status='old',&
             access='sequential', position='rewind')
        READ(dataChan, *) precs
        READ(dataChan, *) types
        READ(dataChan, *) timeAcc
        READ(dataChan, *) signElts
        READ(dataChan, *) dataDesc

! There will only be extra data if the request is for a 
! user defined range.
        IF (dataDesc == userDefRandom .OR. &
            dataDesc == userDefAscending .OR. &
            dataDesc == userDefDescending) THEN
! For each precision requested:
! Extra data consists of the number of user defined intervals
! required. These are defined by a pair of integers (minExp,
! maxExp) which define an exponent interval; a random variable
! in the range (0,1) is then transformed to (1,2) and scaled
! by 2^r where r is a random integer in the range [minExp,
! maxExp].
! More than one interval may be defined but no checks are
! performed on the interval definitions which do not need to
! be disjoint. Values outside of the range of the floating
! point system being used may cause problems. 
! The number of elements in each range is
! floor(SIZE(x)/nRanges) for the first (nRanges-1) intervals
! and n-(nRanges-1)*floor(SIZE(x)/nRanges) in the final one.
          IF (precs == bothSandD .OR. precs == singleOnly) THEN
! Get left and right ranges for single precision
            READ(dataChan, *) nRanges
            ALLOCATE(spUsrMinExp(nRanges), spUsrMaxExp(nRanges))
            READ(dataChan, *) &
                (spUsrMinExp(i), spUsrMaxExp(i), i=1, nRanges)
          END IF
          IF (precs == bothSandD .OR. precs == doubleOnly) THEN
! Get left and right ranges for single precision
            READ(dataChan, *) nRanges
            ALLOCATE(dpUsrMinExp(nRanges),dpUsrMaxExp(nRanges))
            READ(dataChan, *) &
                (dpUsrMinExp(i), dpUsrMaxExp(i), i=1, nRanges)
          END IF
        END IF
      END IF
      dpSet = (precs == bothSandD) .OR. (precs == doubleOnly)
      CALL initialize(dpSet)
! kases array determines which routines get executed
! 1: snrm2;   2: dnrm2;   3: scnrm2;     4: dznrm2
!    sp/real     dp/real     sp/complex     dp/complex
      SELECT CASE (precs)
! set up kases array to only execute what's requested (sp/dp/both)
      CASE (bothSandD)
        kases = [1,2,3,4]
        ncodes = 4
      CASE (singleOnly)
        kases = [1,3,0,0]
        ncodes = 2
      CASE (doubleOnly)
        kases = [2,4,0,0]
        ncodes = 2
      END SELECT
      SELECT CASE (types)
! update kases array to only execute types requested 
!(real/complex/both)
      CASE (bothRandC)
! Leave as is
        CONTINUE
      CASE (realOnly)
        IF (ncodes == 4) THEN
! Both precisions requested but only real required 
          kases = [1,2,0,0]
          ncodes = 2
        ELSE
! Only one precision requested -- lose the complex benchmark
          kases(2) = 0
          ncodes = 1
        END IF
      CASE (complexOnly)
        IF (ncodes == 4) THEN
! Both precisions requested but only complex required 
          kases = [3,4,0,0]
          ncodes = 2
        ELSE
! Only one precision requested -- lose the real benchmark
! which is the first element
          kases(1) = kases(2)
          kases(2) = 0
          ncodes = 1
        END IF
      END SELECT
          
      CALL outputSettings
          
      DO codes = 1, ncodes
        minmaxulp(:, 1) = maxv
        minmaxulp(:, 2) = -maxv
        minmaxulp(:, 3) = zero_sp
        minmaxulpOther(:, 1) = maxv
        minmaxulpOther(:, 2) = -maxv
        minmaxulpOther(:, 3) = zero_sp
        SELECT CASE (kases(codes))
        CASE (1)
          IF (timeAcc==bothTandA .OR. timeAcc==accuracyOnly) THEN
            CALL acc_snrm2
            CALL print_accuracy_results('snrm2 of Remark', minmaxulp)
            CALL print_accuracy_results('snrm2Other', minmaxulpOther)
          END IF

          IF (timeAcc==bothTandA .OR. timeAcc==timingsOnly) THEN
            CALL perform_snrm2
            CALL print_performance_results('snrm2', secspercall, &
                                         secspercallOther)
          END IF

        CASE (2)
          IF (timeAcc==bothTandA .OR. timeAcc==accuracyOnly) THEN
            CALL acc_dnrm2
            CALL print_accuracy_results('dnrm2 of Remark', minmaxulp)
            CALL print_accuracy_results('dnrm2Other', minmaxulpOther)
          END IF

          IF (timeAcc==bothTandA .OR. timeAcc==timingsOnly) THEN
            CALL perform_dnrm2
            CALL print_performance_results('dnrm2', secspercall, &
                                         secspercallOther)
          END IF
        CASE (3)
          IF (timeAcc==bothTandA .OR. timeAcc==accuracyOnly) THEN
            CALL acc_scnrm2
            CALL print_accuracy_results('scnrm2 of Remark', minmaxulp)
            CALL print_accuracy_results('scnrm2Other', minmaxulpOther)
          END IF

          IF (timeAcc==bothTandA .OR. timeAcc==timingsOnly) THEN
            CALL perform_scnrm2
            CALL print_performance_results('scnrm2', secspercall, &
                                         secspercallOther)
          END IF
        CASE (4)
          IF (timeAcc==bothTandA .OR. timeAcc==accuracyOnly) THEN
            CALL acc_dznrm2
            CALL print_accuracy_results('dznrm2 of Remark', minmaxulp)
            CALL print_accuracy_results('dznrm2Other', minmaxulpOther)
          END IF

          IF (timeAcc==bothTandA .OR. timeAcc==timingsOnly) THEN
            CALL perform_dznrm2
            CALL print_performance_results('dznrm2', secspercall, &
                                         secspercallOther)
          END IF
        END SELECT
      END DO
    CONTAINS

      SUBROUTINE print_performance_results(name, rem_times, la_times)
        CHARACTER (LEN=*) :: name
        REAL (skind) :: rem_times(:), la_times(:)

        WRITE (output_unit, '(A)')  &
          ' ', 'Time per Call in Milliseconds for '// name
        WRITE (output_unit, '(6X,A,4X,A,3X,A,3(2X,A))') &
          'Size', 'Samples', 'Remark Time', 'Other Time', &
          'Remark/Other', 'Other/Remark'

        DO j = 1, nsizes
          WRITE (output_unit, '(2X,I8,3X,I8,3X,F8.4,5X,F8.4,2(7X,F6.2))') &
            sizes(j), repeats(j), rem_times(j)*thousand, la_times(j)*thousand, &
            rem_times(j)/la_times(j), la_times(j)/rem_times(j)
        END DO

      END SUBROUTINE print_performance_results

      SUBROUTINE print_accuracy_results(name, errors)
        CHARACTER (LEN=*) :: name
        REAL (skind) :: errors(:, :)

        WRITE (output_unit, '(A)') ' ', &
          'Relative Error Range/Machine Eps. for ' // name
        WRITE (output_unit, '(6X,A,4X,A,7X,3(A,7X))') &
          'Size', 'Samples', 'Min', 'Max', 'Avg'

        DO j = 1, nsizes
          WRITE (output_unit, '(2X,I8,3X,I8,2(3X,F7.0),3X,E12.4)') & 
            sizes(j), repeats(j), errors(j, 1:2), errors(j, 3)/repeats(j)
        END DO
      END SUBROUTINE print_accuracy_results

      SUBROUTINE acc_snrm2
        REAL (skind), ALLOCATABLE :: x(:)
        REAL (skind) :: s, t, relErr, ulps

        ALLOCATE (x(sizes(nsizes)))

        DO k = 1, nsizes
          DO j = 1, repeats(k)
! Use available higher accuracy routine for relative error.              
            CALL GenNrm2DataVec(x(1:sizes(k)),dataDesc,signElts)

            s = snrm2Hybrid(sizes(k), x, 1)
            t = snrm2(sizes(k), x, 1)

            CALL Errors(s, RelErr, Ulps)
            minmaxulp(k, 1) = min(minmaxulp(k,1), Ulps)
            minmaxulp(k, 2) = max(minmaxulp(k,2), Ulps)
            minmaxulp(k, 3) = minmaxulp(k,3) + ABS(Ulps)

            CALL Errors(t, RelErr, Ulps)
            minmaxulpOther(k, 1) = min(minmaxulpOther(k,1), &
              Ulps)
            minmaxulpOther(k, 2) = max(minmaxulpOther(k,2), &
              Ulps)
            minmaxulpOther(k, 3) = minmaxulpOther(k,3) + ABS(Ulps)
          END DO
        END DO

        DEALLOCATE(x)

      END SUBROUTINE acc_snrm2

      SUBROUTINE perform_snrm2
        REAL (skind), ALLOCATABLE :: x(:)
        REAL (skind), volatile :: s
        REAL (skind) :: timeend

        ALLOCATE (x(sizes(nsizes)))

        DO k = 1, nsizes
          CALL GenNrm2DataVec(x(1:sizes(k)),dataDesc,signElts)
          CALL cpu_time(secspercall(k))
          DO j = 1, repeats(k)
            s = snrm2Hybrid(sizes(k), x, 1)
          END DO
          CALL cpu_time(timeend)
          secspercall(k) = (timeend-secspercall(k))/real(repeats(k), skind)
          CALL cpu_time(secspercallOther(k))
          DO j = 1, repeats(k)
            s = snrm2(sizes(k), x, 1)
          END DO
          CALL cpu_time(timeend)
          secspercallOther(k) = (timeend-secspercallOther(k))/ &
            real(repeats(k), skind)
        END DO

        DEALLOCATE(x)
      END SUBROUTINE perform_snrm2

      SUBROUTINE acc_dnrm2
        REAL (dkind), ALLOCATABLE :: x(:)
        REAL (dkind) :: s, t
        REAL (skind) :: RelErr, Ulps

        ALLOCATE (x(sizes(nsizes)))

        DO k = 1, nsizes
          DO j = 1, repeats(k)
! Use available higher accuracy routine for relative error.
            CALL GenNrm2DataVec(x(1:sizes(k)),dataDesc,signElts)

            s = dnrm2Hybrid(sizes(k), x, 1)
            t = dnrm2(sizes(k), x, 1)

            CALL Errors(s, RelErr, Ulps)
            minmaxulp(k, 1) = min(minmaxulp(k,1), Ulps)
            minmaxulp(k, 2) = max(minmaxulp(k,2), Ulps)
            minmaxulp(k, 3) = minmaxulp(k,3) + ABS(Ulps)

            CALL Errors(t, RelErr, Ulps)
            minmaxulpOther(k, 1) = min(minmaxulpOther(k,1), &
              Ulps)
            minmaxulpOther(k, 2) = max(minmaxulpOther(k,2), &
              Ulps)
            minmaxulpOther(k, 3) = minmaxulpOther(k,3) + ABS(Ulps)

          END DO
        END DO

        DEALLOCATE(x)

      END SUBROUTINE acc_dnrm2

      SUBROUTINE perform_dnrm2
        REAL (dkind), ALLOCATABLE :: x(:)
        REAL (dkind), volatile :: s
        REAL (skind) :: timeend

        ALLOCATE (x(sizes(nsizes)))

        DO k = 1, nsizes
          CALL GenNrm2DataVec(x(1:sizes(k)),dataDesc,signElts)
          CALL cpu_time(secspercall(k))
          DO j = 1, repeats(k)
            s = dnrm2Hybrid(sizes(k), x, 1)
          END DO
          CALL cpu_time(timeend)
          secspercall(k) = (timeend-secspercall(k))/real(repeats(k), skind)
          CALL cpu_time(secspercallOther(k))
          DO j = 1, repeats(k)
            s = dnrm2(sizes(k), x, 1)
          END DO
          CALL cpu_time(timeend)
          secspercallOther(k) = (timeend-secspercallOther(k))/ &
            real(repeats(k), skind)
        END DO

        DEALLOCATE(x)

      END SUBROUTINE perform_dnrm2

      SUBROUTINE acc_scnrm2
        COMPLEX (skind), ALLOCATABLE :: x(:)
        REAL (skind) :: s, t, RelErr, Ulps
        INTEGER :: j, k

        ALLOCATE (x(sizes(nsizes)))

        DO k = 1, nsizes
          DO j = 1, repeats(k)

            CALL GenNrm2DataVec(x(1:sizes(k)),dataDesc,signElts)

            s = scnrm2Hybrid(sizes(k), x, 1)
            t = scnrm2(sizes(k), x, 1)

            CALL Errors(s, RelErr, Ulps)
            minmaxulp(k, 1) = min(minmaxulp(k,1), Ulps)
            minmaxulp(k, 2) = max(minmaxulp(k,2), Ulps)
            minmaxulp(k, 3) = minmaxulp(k,3) + ABS(Ulps)

            CALL Errors(t, RelErr, Ulps)
            minmaxulpOther(k, 1) = min(minmaxulpOther(k,1), &
              Ulps)
            minmaxulpOther(k, 2) = max(minmaxulpOther(k,2), &
              Ulps)
            minmaxulpOther(k, 3) = minmaxulpOther(k,3) + ABS(Ulps)
          END DO
        END DO

        DEALLOCATE(x)

      END SUBROUTINE acc_scnrm2

      SUBROUTINE perform_scnrm2
        COMPLEX (skind), ALLOCATABLE :: x(:)
        REAL (skind), volatile :: s
        REAL (skind) :: timeend
        INTEGER :: j, k

        ALLOCATE (x(sizes(nsizes)))

        DO k = 1, nsizes
          CALL GenNrm2DataVec(x(1:sizes(k)),dataDesc,signElts)
          CALL cpu_time(secspercall(k))
          DO j = 1, repeats(k)
            s = scnrm2Hybrid(sizes(k), x, 1)
          END DO
          CALL cpu_time(timeend)
          secspercall(k) = (timeend-secspercall(k))/real(repeats(k), skind)

          CALL cpu_time(secspercallOther(k))
          DO j = 1, repeats(k)
            s = scnrm2(sizes(k), x, 1)
          END DO
          CALL cpu_time(timeend)
          secspercallOther(k) = (timeend-secspercallOther(k))/ &
            real(repeats(k), skind)
        END DO

        DEALLOCATE(x)

      END SUBROUTINE perform_scnrm2

      SUBROUTINE acc_dznrm2
        COMPLEX (dkind), ALLOCATABLE :: x(:)
        REAL (dkind) :: s, t
        REAL (skind) :: RelErr, Ulps
        INTEGER :: j, k

        ALLOCATE (x(sizes(nsizes)))
        DO k = 1, nsizes
          DO j = 1, repeats(k)
            CALL GenNrm2DataVec(x(1:sizes(k)),dataDesc,signElts)
            s = dznrm2Hybrid(sizes(k), x, 1)
            t = dznrm2(sizes(k), x, 1)

            CALL Errors(s, RelErr, Ulps)
            minmaxulp(k, 1) = min(minmaxulp(k,1), Ulps)
            minmaxulp(k, 2) = max(minmaxulp(k,2), Ulps)
            minmaxulp(k, 3) = minmaxulp(k,3) + ABS(Ulps)

            CALL Errors(t, RelErr, Ulps)
            minmaxulpOther(k, 1) = min(minmaxulpOther(k,1), &
              Ulps)
            minmaxulpOther(k, 2) = max(minmaxulpOther(k,2), &
              Ulps)
            minmaxulpOther(k, 3) = minmaxulpOther(k,3) + ABS(Ulps)
          END DO
        END DO

        DEALLOCATE(x)

      END SUBROUTINE acc_dznrm2

      SUBROUTINE perform_dznrm2
        COMPLEX (dkind), ALLOCATABLE :: x(:)
        REAL (skind), volatile :: s
        REAL (skind) :: timeend
        INTEGER :: j, k

        ALLOCATE (x(sizes(nsizes)))

        DO k = 1, nsizes
          CALL GenNrm2DataVec(x(1:sizes(k)),dataDesc,signElts)
          CALL cpu_time(secspercall(k))
          DO j = 1, repeats(k)
            s = dznrm2Hybrid(sizes(k), x, 1)
          END DO
          CALL cpu_time(timeend)
          secspercall(k) = (timeend-secspercall(k))/real(repeats(k), skind)

          CALL cpu_time(secspercallOther(k))
          DO j = 1, repeats(k)
            s = dznrm2(sizes(k), x, 1)
          END DO
          CALL cpu_time(timeend)
          secspercallOther(k) = (timeend-secspercallOther(k))/ &
            real(repeats(k), skind)
        END DO

        DEALLOCATE(x)

      END SUBROUTINE perform_dznrm2

      SUBROUTINE outputSettings
      SELECT CASE (precs)
      CASE (bothSandD)
        WRITE(output_unit, &
          '(''Benchmarking both single and double precision routines'')')
      CASE (singleOnly)
        WRITE(output_unit, &
          '(''Benchmarking only single precision routines'')')
      CASE (doubleOnly)
        WRITE(output_unit, &
          '(''Benchmarking only double precision routines'')')
      END SELECT

      SELECT CASE (types)
      CASE (bothRandC)
        WRITE(output_unit, &
          '(''Benchmarking both real and complex routines'')')
      CASE (realOnly)
        WRITE(output_unit, &
          '(''Benchmarking only real routines'')')
      CASE (complexOnly)
        WRITE(output_unit, &
          '(''Benchmarking only complex routines'')')
      END SELECT

      SELECT CASE (timeAcc)
      CASE (bothTandA)
        WRITE(output_unit, &
          '(''Benchmarking both execution times and accuracy'')')
      CASE (timingsOnly)
        WRITE(output_unit, &
          '(''Benchmarking only execution times'')')
      CASE (accuracyOnly)
        WRITE(output_unit, &
          '(''Benchmarking only accuracy'')')
      END SELECT

      CALL outputVecHeading(dataDesc)

!
! If user defined data then output the ranges of values
! selected for either or both precisions.
      IF (dataDesc == userDefRandom .OR. &
          dataDesc == userDefAscending .OR. &
          dataDesc == userDefDescending ) THEN

        IF (precs == bothSandD .OR. precs == singleOnly) THEN
          CALL outputRanges('S', spUsrMinExp, spUsrMaxExp)
        ELSE IF (precs == bothSandD .OR. precs == doubleOnly) THEN
          CALL outputRanges('D', dpUsrMinExp, dpUsrMaxExp)
        END IF
      END IF

      CALL outputSignDesc(signElts)
        
      END SUBROUTINE outputSettings
    END PROGRAM sdbenchmark

