module mesh_m

    implicit none

    type boundary_condition_t

        character :: type ! N for Neumann, D for Dirichlet
        real(kind=8) :: a, b, c ! Boundary condition formulated as a+b*x+c*x^2

    end type boundary_condition_t

    type mesh_t

        integer :: n_rows, n_cols, N_cp, max_iter
        integer,allocatable,dimension(:) :: W_ind, E_ind, S_ind, N_ind
        real(kind=8) :: x_min, x_max, y_min, y_max
        real(kind=8) :: dx, dy, gamma, omega
        real(kind=8),allocatable,dimension(:) :: x_cp, y_cp, AP, AW, AS, AE, AN, Sp, Su, phi
        type(boundary_condition_t) :: W_bc, S_bc, E_bc, N_bc

    end type mesh_t

    integer allocated

contains

subroutine mesh_allocate(t)
    type(mesh_t) :: t
    if(allocated.eq.1) call mesh_deallocate(t)

    allocate(t%W_ind(t%N_cp))
    allocate(t%E_ind(t%N_cp))
    allocate(t%S_ind(t%N_cp))
    allocate(t%N_ind(t%N_cp))
    allocate(t%x_cp(t%n_cols))
    allocate(t%y_cp(t%n_rows))
    allocate(t%AP(t%N_cp))
    allocate(t%AW(t%N_cp))
    allocate(t%AS(t%N_cp))
    allocate(t%AE(t%N_cp))
    allocate(t%AN(t%N_cp))
    allocate(t%Su(t%N_cp))
    allocate(t%Sp(t%N_cp))
    allocate(t%phi(t%N_cp))

    allocated = 1

end subroutine mesh_allocate

subroutine mesh_deallocate(t)
    type(mesh_t) :: t

    deallocate(t%W_ind)
    deallocate(t%E_ind)
    deallocate(t%S_ind)
    deallocate(t%N_ind)
    deallocate(t%x_cp)
    deallocate(t%y_cp)
    deallocate(t%AP)
    deallocate(t%AW)
    deallocate(t%AS)
    deallocate(t%AE)
    deallocate(t%AN)
    deallocate(t%Su)
    deallocate(t%Sp)
    deallocate(t%phi)

    allocated = 0
end subroutine mesh_deallocate

subroutine mesh_load_input(t, inp)

    type(mesh_t) :: t
    character(100) :: inp
    integer :: i,j

    ! Read input file
    open(1,file=inp)
        read(1,*)
        read(1,*)
        read(1,*) t%x_min, t%x_max, t%y_min, t%y_max
        read(1,*)
        read(1,*) t%n_rows, t%n_cols
        read(1,*)
        read(1,*) t%gamma
        read(1,*)
        read(1,*)
        read(1,*) t%W_bc%type, t%W_bc%a, t%W_bc%b, t%W_bc%c
        read(1,*)
        read(1,*) t%S_bc%type, t%S_bc%a, t%S_bc%b, t%S_bc%c
        read(1,*)
        read(1,*) t%E_bc%type, t%E_bc%a, t%E_bc%b, t%E_bc%c
        read(1,*)
        read(1,*) t%N_bc%type, t%N_bc%a, t%N_bc%b, t%N_bc%c
        read(1,*)
        read(1,*)
        read(1,*) t%omega, t%max_iter
    close(1)

    ! Parse some derived quantities
    t%dx = (t%x_max-t%x_min)/t%n_cols
    t%dy = (t%y_max-t%y_min)/t%n_rows
    t%N_cp = t%n_rows*t%n_cols

    ! Allocate
    call mesh_allocate(t)

    ! Initialize control point locations
    do i = 1, t%n_rows
        t%y_cp(i) = t%y_min+(i-0.5)*t%dx
    end do
    do j = 1, t%n_cols
        t%x_cp(j) = t%x_min+(j-0.5)*t%dx
    end do

    write(*,*) "Successfully initialized mesh."

end subroutine mesh_load_input

subroutine mesh_set_up_matrices(t)
    ! Sets up the matrices for actually solving the problem

    implicit none
    type(mesh_t) :: t
    integer :: i, j, ind
    real(kind=8) :: phi_bc, dphi_dn

    ! Loop through control points
    ind = 0
    do i = 1, t%n_rows
        do j = 1, t%n_cols

            ! Calculate indices for this point
            ind = ind + 1
            t%W_ind(ind) = ind-1
            t%E_ind(ind) = ind+1
            t%S_ind(ind) = ind-t%n_cols
            t%N_ind(ind) = ind+t%n_cols

            ! Initialize solution
            t%phi(ind) = 0.0

            ! Calculate central coefficients
            t%AW(ind) = t%gamma*t%dy/t%dx
            t%AE(ind) = t%gamma*t%dy/t%dx
            t%AS(ind) = t%gamma*t%dx/t%dy
            t%AN(ind) = t%gamma*t%dx/t%dy
            t%Su(ind) = 0
            t%Sp(ind) = 0

            ! Handle west boundary
            if (j .eq. 1) then
                if (t%W_bc%type .eq. 'D') then
                    phi_bc = t%W_bc%a+t%W_bc%b*t%y_cp(i)+t%W_bc%c*t%y_cp(i)**2.0
                    t%Su(ind) = t%Su(ind) + 2.0*t%gamma*t%dy*phi_bc/t%dx
                    t%Sp(ind) = t%Sp(ind) - 2.0*t%gamma*t%dy/t%dx
                else
                    dphi_dn = t%W_bc%a+t%W_bc%b*t%y_cp(i)+t%W_bc%c*t%y_cp(i)**2.0
                    t%Sp(ind) = t%Sp(ind) - t%dy*t%gamma*dphi_dn
                end if
                t%AW(ind) = 0.0
                t%W_ind(ind) = 1 ! Not needed in this case
            end if

            ! Handle east boundary
            if (j .eq. t%n_cols) then
                if (t%E_bc%type .eq. 'D') then
                    phi_bc = t%E_bc%a+t%E_bc%b*t%y_cp(i)+t%E_bc%c*t%y_cp(i)**2.0
                    t%Su(ind) = t%Su(ind) + 2.0*t%gamma*t%dy*phi_bc/t%dx
                    t%Sp(ind) = t%Sp(ind) - 2.0*t%gamma*t%dy/t%dx
                else
                    dphi_dn = t%E_bc%a+t%E_bc%b*t%y_cp(i)+t%E_bc%c*t%y_cp(i)**2.0
                    t%Sp(ind) = t%Sp(ind) + t%dy*t%gamma*dphi_dn
                end if
                t%AE(ind) = 0.0
                t%E_ind(ind) = 1 ! Not needed in this case
            end if

            ! Handle south boundary
            if (i .eq. 1) then
                if (t%S_bc%type .eq. 'D') then
                    phi_bc = t%S_bc%a+t%S_bc%b*t%x_cp(j)+t%S_bc%c*t%x_cp(j)**2.0
                    t%Su(ind) = t%Su(ind) + 2.0*t%gamma*t%dx*phi_bc/t%dy
                    t%Sp(ind) = t%Sp(ind) - 2.0*t%gamma*t%dx/t%dy
                else
                    dphi_dn = t%S_bc%a+t%S_bc%b*t%x_cp(j)+t%S_bc%c*t%x_cp(j)**2.0
                    t%Sp(ind) = t%Sp(ind) - t%dx*t%gamma*dphi_dn
                end if
                t%AS(ind) = 0.0
                t%S_ind(ind) = 1 ! Not needed in this case
            end if

            ! Handle north boundary
            if (i .eq. t%n_rows) then
                if (t%N_bc%type .eq. 'D') then
                    phi_bc = t%N_bc%a+t%N_bc%b*t%x_cp(j)+t%N_bc%c*t%x_cp(j)**2.0
                    t%Su(ind) = t%Su(ind) + 2.0*t%gamma*t%dx*phi_bc/t%dy
                    t%Sp(ind) = t%Sp(ind) - 2.0*t%gamma*t%dx/t%dy
                else
                    dphi_dn = t%N_bc%a+t%N_bc%b*t%x_cp(j)+t%N_bc%c*t%x_cp(j)**2.0
                    t%Sp(ind) = t%Sp(ind) + t%dx*t%gamma*dphi_dn
                end if
                t%AN(ind) = 0.0
                t%N_ind(ind) = 1 ! Not needed in this case
            end if

            ! Calculate P coefficient
            t%AP(ind) = t%AW(ind) + t%AE(ind) + t%AN(ind) + t%AS(ind) - t%Sp(ind)

        end do
    end do

end subroutine mesh_set_up_matrices

subroutine mesh_sor(t)

    type(mesh_t) :: t
    real(kind=8) :: max_corr, corr
    integer :: i, iteration

    write(*,*)
    write(*,*) "Running SOR..."

    ! Iterative SOR
    iteration = 0
    max_corr = 1.0
    do while (max_corr>1d-15 .and. iteration<t%max_iter)

        max_corr = 0.0

        ! Loop through control points
        iteration = iteration + 1
        do i = 1, t%N_cp

            ! Calculate correction
            corr = t%AW(i)*t%phi(t%W_ind(i)) + t%AE(i)*t%phi(t%E_ind(i))
            corr = corr + t%AS(i)*t%phi(t%S_ind(i)) + t%AN(i)*t%phi(t%N_ind(i))
            corr = corr + t%Su(i) - t%AP(i)*t%phi(i)
            corr = corr*t%omega/t%AP(i)

            ! Check magnitude
            if (abs(corr)>max_corr) then
                max_corr  = abs(corr)
            end if

            ! Apply correction
            t%phi(i) = t%phi(i) + corr

        end do

        ! Output progress
        write(*,*) iteration, max_corr

    end do
    write(*,*) "Complete! Final maximum correction: ", max_corr

end subroutine mesh_sor

subroutine mesh_write_results_to_csv(t, filename)

    type(mesh_t) :: t
    character(100) :: filename
    integer :: i, j, ind
    real(kind=8) :: x, y, phi

    ! Open file
    open(1,file=filename)

        ! Header
        write(1,*) 'x,y,z,phi'

        ! Control points
        ind = 0
        do i = 1,t%n_rows
            do j =1,t%n_cols
                ind = ind + 1
                write(1,*) t%x_cp(j), ',', t%y_cp(i), ',', 0.0, ',', t%phi(ind)
            end do
        end do

        ! West and east boundaries
        do i = 1,t%n_rows
            y = t%y_cp(i)
            phi = t%W_bc%a+t%W_bc%b*y+t%W_bc%c*y**2
            write(1,*) t%x_min, ',', y, ',', 0.0, ',', phi
            phi = t%E_bc%a+t%E_bc%b*y+t%E_bc%c*y**2
            write(1,*) t%x_max, ',', y, ',', 0.0, ',', phi
        end do

        ! North and south boundaries
        do i = 1,t%n_cols
            x = t%x_cp(i)
            phi = t%N_bc%a+t%N_bc%b*x+t%N_bc%c*x**2
            write(1,*) x, ',', t%y_max, ',', 0.0, ',', phi
            phi = t%S_bc%a+t%S_bc%b*x+t%S_bc%c*x**2
            write(1,*) x, ',', t%y_min, ',', 0.0, ',', phi
        end do

        ! Corners
        phi = t%W_bc%a+t%W_bc%b*t%y_min+t%W_bc%c*t%y_min**2 ! SW
        write(1,*) t%x_min, ',', t%y_min, ',', 0.0, ',', phi
        phi = t%W_bc%a+t%W_bc%b*t%y_max+t%W_bc%c*t%y_max**2 ! NW
        write(1,*) t%x_min, ',', t%y_max, ',', 0.0, ',', phi
        phi = t%E_bc%a+t%E_bc%b*t%y_min+t%E_bc%c*t%y_min**2 ! SE
        write(1,*) t%x_max, ',', t%y_min, ',', 0.0, ',', phi
        phi = t%E_bc%a+t%E_bc%b*t%y_max+t%E_bc%c*t%y_max**2 ! NE
        write(1,*) t%x_max, ',', t%y_max, ',', 0.0, ',', phi

    close(1)

end subroutine mesh_write_results_to_csv

end module mesh_m


begin-suite

s" +"    { 1 2 +   -> 3 }
s" +"    { -2 3 +  -> 1 }
s" -"    { 1 2 -   -> -1 }
s" -"    { -3 2 -  -> -5 }
s" *"    { 2 3 *   -> 6 }
s" *"    { -2 3 *  -> -6 }
s" /"    { 6 3 /   -> 2 }
s" /"    { 6 -3 /  -> -2 }
s" 1+"   { 2 1+    -> 3 }
s" 1-"   { 2 1-    -> 1 }
s" dup"  { 2 dup   -> 2 2 }
s" swap" { 2 3 swap -> 3 2 }
s" nip"  { 2 3 nip  -> 3 }
s" 2nip" { 2 3 4 2nip -> 4 }
s" 2dup" { 2 3 2dup -> 2 3 2 3 }
s" ?dup" { 1 ?dup -> 1 1 }
s" ?dup" { 0 ?dup -> 0 }
s" swapdup" { 2 3 swapdup -> 3 2 2 }
s" over" { 4 5 over  -> 4 5 4 }
s" tuck" { 4 5 1 tuck -> 4 1 5 1 }
s" drop" { 4 5 drop -> 4 }
s" rot"  { 4 5 6 rot -> 5 6 4 }
s" -rot" { 4 5 6 -rot -> 6 4 5 }
s" 2drop" { 5 6 3 2drop -> 5 }
s" bi+" { 4 5 6 bi+ -> 15 }
s" invert" { 0 invert -> -1 }
s" invert" { -1 invert -> 0 }

test-report

\ jatka!


! Copyright (c) 2015 Alex Kramer <kramer.alex.kramer@gmail.com>
! See the LICENSE.txt file at the top-level directory of this distribution.

! Basic statistics functionality
module stats
  use globvars, only: dp, sp, ip
  use array, only: array_quicksort, array_pack

  implicit none

  private

  public :: stats_residuals
  interface stats_residuals
     module procedure stats_residuals_dp
     module procedure stats_residuals_sp
  end interface stats_residuals

  public :: stats_residuals_rel
  interface stats_residuals_rel
     module procedure stats_residuals_rel_dp
     module procedure stats_residuals_rel_sp
  end interface stats_residuals_rel

  public :: stats_mean
  interface stats_mean
     module procedure stats_mean_dp
     module procedure stats_mean_sp
  end interface

  public :: stats_fivenum
  interface stats_fivenum
     module procedure stats_fivenum_dp
     module procedure stats_fivenum_sp
  end interface stats_fivenum

  public :: stats_max
  interface stats_max
     module procedure stats_max_dp
     module procedure stats_max_sp
  end interface stats_max

  public :: stats_min
  interface stats_min
     module procedure stats_min_dp
     module procedure stats_min_sp
  end interface stats_min

  public :: stats_median
  interface stats_median
     module procedure stats_median_dp
     module procedure stats_median_sp
  end interface stats_median

  public :: stats_lower_quartile
  interface stats_lower_quartile
     module procedure stats_lower_quartile_dp
     module procedure stats_lower_quartile_sp
  end interface stats_lower_quartile

  public :: stats_upper_quartile
  interface stats_upper_quartile
     module procedure stats_upper_quartile_dp
     module procedure stats_upper_quartile_sp
  end interface stats_upper_quartile

  public :: stats_mean_sq_err
  interface stats_mean_sq_err
     module procedure stats_mean_sq_err_dp
     module procedure stats_mean_sq_err_sp
  end interface stats_mean_sq_err

  public :: stats_mean_abs_err
  interface stats_mean_abs_err
     module procedure stats_mean_abs_err_dp
     module procedure stats_mean_abs_err_sp
  end interface stats_mean_abs_err

  public :: stats_variance
  interface stats_variance
     module procedure stats_variance_dp
     module procedure stats_variance_sp
  end interface stats_variance

  public :: stats_stdev
  interface stats_stdev
     module procedure stats_stdev_dp
     module procedure stats_stdev_sp
  end interface stats_stdev

contains

  subroutine stats_residuals_rel_dp(data_arr, theor_arr, resid_rel_arr)
    ! Calculate relative residuals for double precision real values
    !
    ! data_arr :: array of experimental data values
    ! theor_arr :: arry of theoretical values, parallel to data_arr
    ! resid_rel_arr :: array to populate with relative residuals
    real(dp), intent(in) :: data_arr(:), theor_arr(:)
    real(dp), intent(inout) :: resid_rel_arr(:)

    include "./stats_src/residuals_rel.src"
  end subroutine stats_residuals_rel_dp

  subroutine stats_residuals_rel_sp(data_arr, theor_arr, resid_rel_arr)
    ! Duplicate of stats_residuals_rel_dp, but for single precision reals
    real(sp), intent(in) :: data_arr(:), theor_arr(:)
    real(sp), intent(inout) :: resid_rel_arr(:)

    include "./stats_src/residuals_rel.src"
  end subroutine stats_residuals_rel_sp

  subroutine stats_residuals_dp(data_arr, theor_arr, resid_arr)
    ! Calculate residuals, for double precision real arrays
    !
    ! data_arr :: array of experimental data values
    ! theor_arr :: array of theoretical values, parallel to data_arr
    ! resid_arr :: array to populate with residuals
    real(dp), intent(in) :: data_arr(:), theor_arr(:)
    real(dp), intent(inout) :: resid_arr(:)

    include "./stats_src/residuals.src"
  end subroutine stats_residuals_dp

  subroutine stats_residuals_sp(data_arr, theor_arr, resid_arr)
    ! Duplicate of stats_residuals, but for single precision real arrays
    real(sp), intent(in) :: data_arr(:), theor_arr(:)
    real(sp), intent(inout) :: resid_arr(:)

    include "./stats_src/residuals.src"
  end subroutine stats_residuals_sp

  pure real(dp) function stats_mean_dp(data_arr, mask) result(val)
    ! Calculate mean of array of double precision values
    !
    ! data_arr :: array of data values
    ! mask :: logical masking array
    real(dp), intent(in) :: data_arr(:)
    logical, intent(in), optional :: mask(:)

    include "./stats_src/mean.src"
  end function stats_mean_dp

  pure real(sp) function stats_mean_sp(data_arr, mask) result(val)
    ! Duplicate of stats_mean_dp, but for single precision reals
    real(sp), intent(in) :: data_arr(:)
    logical, intent(in), optional :: mask(:)

    include "./stats_src/mean.src"
  end function stats_mean_sp

  subroutine stats_fivenum_dp(data_arr, summary_arr, mask, sorted)
    ! Generate five-number summary statistics, for double precision real arrays
    !
    ! data_arr :: array of data values
    ! summary_arr :: 5-element array for summary values, with entries:
    !  [min, lower_quartile, median, upper_quartile, max]
    ! mask :: logical masking array
    ! sorted :: whether data_arr is already sorted
    real(dp), intent(in) :: data_arr(:)
    real(dp), intent(out) :: summary_arr(5)
    logical, intent(in), optional :: mask(:)
    logical, intent(in), optional :: sorted

    real(dp) :: min, lq, med, uq, max

    include "./stats_src/fivenum.src"

    summary_arr = [min, lq, med, uq, max]

  end subroutine stats_fivenum_dp

  subroutine stats_fivenum_sp(data_arr, summary_arr, mask, sorted)
    ! Duplicate of stats_fivenum_dp, but for single precision real arrays
    real(sp), intent(in) :: data_arr(:)
    real(sp), intent(out) :: summary_arr(5)
    logical, intent(in), optional :: mask(:)
    logical, intent(in), optional :: sorted

    real(sp) :: min, lq, med, uq, max

    include "./stats_src/fivenum.src"

    summary_arr = [min, lq, med, uq, max]

  end subroutine stats_fivenum_sp

  real(dp) function stats_lower_quartile_dp(data_arr, mask, sorted) result(val)
    ! Calculate lower quartile value
    !
    ! data_arr :: array of data values
    ! mask :: logical masking array
    ! sorted :: whether data_arr is already sorted
    real(dp), intent(in) :: data_arr(:)
    logical, intent(in), optional :: mask(:)
    logical, intent(in), optional :: sorted

    integer(ip), parameter :: fp = dp

    include "./stats_src/quartile.src"
    include "./stats_src/lower_quartile.src"
  end function stats_lower_quartile_dp

  real(sp) function stats_lower_quartile_sp(data_arr, mask, sorted) result(val)
    ! Duplicate of stats_lower_quartile_dp, but for single precision reals
    real(sp), intent(in) :: data_arr(:)
    logical, intent(in), optional :: mask(:)
    logical, intent(in), optional :: sorted

    integer(ip), parameter :: fp = sp

    include "./stats_src/quartile.src"
    include "./stats_src/lower_quartile.src"
  end function stats_lower_quartile_sp

  real(dp) function stats_upper_quartile_dp(data_arr, mask, sorted) result(val)
    ! Calculate upper quartile value
    !
    ! data_arr :: array of data values
    ! mask :: logical masking array
    ! sorted :: whether data_arr is already sorted
    real(dp), intent(in) :: data_arr(:)
    logical, intent(in), optional :: mask(:)
    logical, intent(in), optional :: sorted

    integer(ip), parameter :: fp = dp

    include "./stats_src/quartile.src"
    include "./stats_src/upper_quartile.src"
  end function stats_upper_quartile_dp

  real(sp) function stats_upper_quartile_sp(data_arr, mask, sorted) result(val)
    ! Duplicate of stats_upper_quartile_dp, but for single precision reals
    real(sp), intent(in) :: data_arr(:)
    logical, intent(in), optional :: mask(:)
    logical, intent(in), optional :: sorted

    integer(ip), parameter :: fp = sp

    include "./stats_src/quartile.src"
    include "./stats_src/upper_quartile.src"
  end function stats_upper_quartile_sp

  pure real(dp) function stats_max_dp(data_arr, mask) result(val)
    ! Find max value, for double precision real arrays
    real(dp), intent(in) :: data_arr(:)
    logical, intent(in), optional :: mask(:)

    include "./stats_src/max.src"
  end function stats_max_dp

  pure real(sp) function stats_max_sp(data_arr, mask) result(val)
    ! Duplicate of stats_max_dp, but for single precision reals
    real(sp), intent(in) :: data_arr(:)
    logical, intent(in), optional :: mask(:)

    include "./stats_src/max.src"
  end function stats_max_sp

  pure real(dp) function stats_min_dp(data_arr, mask) result(val)
    ! Find min value, for double precision real arrays
    !
    ! data_arr :: array of data values
    ! mask :: logical masking array
    real(dp), intent(in) :: data_arr(:)
    logical, intent(in), optional :: mask(:)

    include "./stats_src/min.src"
  end function stats_min_dp

  pure real(sp) function stats_min_sp(data_arr, mask) result(val)
    ! Duplicate of stats_min_sp, but for single precision reals
    real(sp), intent(in) :: data_arr(:)
    logical, intent(in), optional :: mask(:)

    include "./stats_src/min.src"
  end function stats_min_sp

  real(dp) function stats_median_dp(data_arr, mask, sorted) result(val)
    ! Calculate median of double precision real array
    !
    ! data_arr :: array of data values
    ! mask :: logical masking array
    ! sorted :: whether data_arr is already sorted
    real(dp), intent(in) :: data_arr(:)
    logical, intent(in), optional :: mask(:)
    logical, intent(in), optional :: sorted

    real(dp), allocatable :: data_work_arr(:)

    include "./stats_src/median.src"

    deallocate(data_work_arr)

  end function stats_median_dp

  real(sp) function stats_median_sp(data_arr, mask, sorted) result(val)
    real(sp), intent(in) :: data_arr(:)
    logical, intent(in), optional :: mask(:)
    logical, intent(in), optional :: sorted

    real(sp), allocatable :: data_work_arr(:)

    include "./stats_src/median.src"

    deallocate(data_work_arr)

  end function stats_median_sp

  real(dp) function stats_mean_abs_err_dp(resid_arr, mask) result(val)
    ! Calculate mean absolute error from residuals
    !
    ! resid_arr :: residual array
    ! mask :: logical masking array
    real(dp), intent(in) :: resid_arr(:)
    logical, intent(in), optional :: mask(:)

    include "./stats_src/mean_abs_err.src"
  end function stats_mean_abs_err_dp

  real(sp) function stats_mean_abs_err_sp(resid_arr, mask) result(val)
    ! Calculate mean absolute error from residuals
    !
    ! resid_arr :: residual array
    ! mask :: logical masking array
    real(sp), intent(in) :: resid_arr(:)
    logical, intent(in), optional :: mask(:)

    include "./stats_src/mean_abs_err.src"
  end function stats_mean_abs_err_sp

  pure real(dp) function stats_mean_sq_err_dp(resid_arr, mask) result(val)
    ! Calculate mean squared error from residuals
    !
    ! resid_arr :: residual array
    ! mask :: logical masking array
    real(dp), intent(in) :: resid_arr(:)
    logical, intent(in), optional :: mask(:)

    include "./stats_src/mean_sq_err.src"
  end function stats_mean_sq_err_dp

  pure real(sp) function stats_mean_sq_err_sp(resid_arr, mask) result(val)
    ! Calculate mean squared error from residuals
    !
    ! resid_arr :: residual array
    ! mask :: logical masking array
    real(sp), intent(in) :: resid_arr(:)
    logical, intent(in), optional :: mask(:)

    include "./stats_src/mean_sq_err.src"
  end function stats_mean_sq_err_sp

  pure real(dp) function stats_variance_dp(data_arr, mask) result(val)
    ! Calculate variance
    !
    ! data_arr :: array of data values
    ! mask :: logical masking array
    real(dp), intent(in) :: data_arr(:)
    logical, intent(in), optional :: mask(:)

    real(dp) :: mean

    include "./stats_src/variance.src"
  end function stats_variance_dp

  pure real(sp) function stats_variance_sp(data_arr, mask) result(val)
    ! Duplicate of stats_variance_dp, but for single precision reals
    real(sp), intent(in) :: data_arr(:)
    logical, intent(in), optional :: mask(:)

    real(sp) :: mean

    include "./stats_src/variance.src"
  end function stats_variance_sp

  pure real(dp) function stats_stdev_dp(data_arr, mask) result(val)
    ! Compute standard deviation, for double precision real arrays
    !
    ! data :: array of data values
    ! mask :: logical masking array
    real(dp), intent(in) :: data_arr(:)
    logical, intent(in), optional :: mask(:)

    include "./stats_src/stdev.src"
  end function stats_stdev_dp

  pure real(sp) function stats_stdev_sp(data_arr, mask) result(val)
    ! Duplicate of stats_stdev_dp, but for single precision reals
    real(sp), intent(in) :: data_arr(:)
    logical, intent(in), optional :: mask(:)

    include "./stats_src/stdev.src"
  end function stats_stdev_sp

  pure logical function stats_to_sort(sorted) result(val)
    ! Private helper function to determine if an array needs to be sorted baesd
    ! on input arguments. This is here to reduce code duplication.
    logical, optional, intent(in) :: sorted
    logical :: to_sort

    to_sort = .true.
    ! This can't be a single if statement since Fortran doesn't have short-
    ! circuit evaluation
    if (present(sorted)) then
       if (sorted) then
          to_sort = .false.
       end if
    end if

    val = to_sort
  end function stats_to_sort

end module stats


*DECK DCHFCM
      INTEGER FUNCTION DCHFCM (D1, D2, DELTA)
C***BEGIN PROLOGUE  DCHFCM
C***SUBSIDIARY
C***PURPOSE  Check a single cubic for monotonicity.
C***LIBRARY   SLATEC (PCHIP)
C***TYPE      DOUBLE PRECISION (CHFCM-S, DCHFCM-D)
C***AUTHOR  Fritsch, F. N., (LLNL)
C***DESCRIPTION
C
C *Usage:
C
C        DOUBLE PRECISION  D1, D2, DELTA
C        INTEGER  ISMON, DCHFCM
C
C        ISMON = DCHFCM (D1, D2, DELTA)
C
C *Arguments:
C
C     D1,D2:IN  are the derivative values at the ends of an interval.
C
C     DELTA:IN  is the data slope over that interval.
C
C *Function Return Values:
C     ISMON : indicates the monotonicity of the cubic segment:
C             ISMON = -3  if function is probably decreasing;
C             ISMON = -1  if function is strictly decreasing;
C             ISMON =  0  if function is constant;
C             ISMON =  1  if function is strictly increasing;
C             ISMON =  2  if function is non-monotonic;
C             ISMON =  3  if function is probably increasing.
C           If ABS(ISMON)=3, the derivative values are too close to the
C           boundary of the monotonicity region to declare monotonicity
C           in the presence of roundoff error.
C
C *Description:
C
C          DCHFCM:  Cubic Hermite Function -- Check Monotonicity.
C
C    Called by  DPCHCM  to determine the monotonicity properties of the
C    cubic with boundary derivative values D1,D2 and chord slope DELTA.
C
C *Cautions:
C     This is essentially the same as old DCHFMC, except that a
C     new output value, -3, was added February 1989.  (Formerly, -3
C     and +3 were lumped together in the single value 3.)  Codes that
C     flag nonmonotonicity by "IF (ISMON.EQ.2)" need not be changed.
C     Codes that check via "IF (ISMON.GE.3)" should change the test to
C     "IF (IABS(ISMON).GE.3)".  Codes that declare monotonicity via
C     "IF (ISMON.LE.1)" should change to "IF (IABS(ISMON).LE.1)".
C
C   REFER TO  DPCHCM
C
C***ROUTINES CALLED  D1MACH
C***REVISION HISTORY  (YYMMDD)
C   820518  DATE WRITTEN
C   820805  Converted to SLATEC library version.
C   831201  Changed from  ISIGN  to SIGN  to correct bug that
C           produced wrong sign when -1 .LT. DELTA .LT. 0 .
C   890206  Added SAVE statements.
C   890209  Added sign to returned value ISMON=3 and corrected
C           argument description accordingly.
C   890306  Added caution about changed output.
C   890407  Changed name from DCHFMC to DCHFCM, as requested at the
C           March 1989 SLATEC CML meeting, and made a few other
C           minor modifications necessitated by this change.
C   890407  Converted to new SLATEC format.
C   890407  Modified DESCRIPTION to LDOC format.
C   891214  Moved SAVE statements.  (WRB)
C***END PROLOGUE  DCHFCM
C
C  Fortran intrinsics used:  DSIGN.
C  Other routines used:  D1MACH.
C
C ----------------------------------------------------------------------
C
C  Programming notes:
C
C     TEN is actually a tuning parameter, which determines the width of
C     the fuzz around the elliptical boundary.
C
C     To produce a single precision version, simply:
C        a. Change DCHFCM to CHFCM wherever it occurs,
C        b. Change the double precision declarations to real, and
C        c. Change the constants ZERO, ONE, ... to single precision.
C
C  DECLARE ARGUMENTS.
C
      DOUBLE PRECISION  D1, D2, DELTA, D1MACH
C
C  DECLARE LOCAL VARIABLES.
C
      INTEGER ISMON, ITRUE
      DOUBLE PRECISION  A, B, EPS, FOUR, ONE, PHI, TEN, THREE, TWO,
     * ZERO
      SAVE ZERO, ONE, TWO, THREE, FOUR
      SAVE TEN
C
C  INITIALIZE.
C
      DATA ZERO /0.D0/, ONE/1.D0/, TWO/2.D0/, THREE/3.D0/, FOUR/4.D0/,
     1      TEN /10.D0/
C
C        MACHINE-DEPENDENT PARAMETER -- SHOULD BE ABOUT 10*UROUND.
C***FIRST EXECUTABLE STATEMENT  DCHFCM
      EPS = TEN*D1MACH(4)
C
C  MAKE THE CHECK.
C
      IF (DELTA .EQ. ZERO)  THEN
C        CASE OF CONSTANT DATA.
         IF ((D1.EQ.ZERO) .AND. (D2.EQ.ZERO))  THEN
            ISMON = 0
         ELSE
            ISMON = 2
         ENDIF
      ELSE
C        DATA IS NOT CONSTANT -- PICK UP SIGN.
         ITRUE = DSIGN (ONE, DELTA)
         A = D1/DELTA
         B = D2/DELTA
         IF ((A.LT.ZERO) .OR. (B.LT.ZERO))  THEN
            ISMON = 2
         ELSE IF ((A.LE.THREE-EPS) .AND. (B.LE.THREE-EPS))  THEN
C           INSIDE SQUARE (0,3)X(0,3)  IMPLIES   OK.
            ISMON = ITRUE
         ELSE IF ((A.GT.FOUR+EPS) .AND. (B.GT.FOUR+EPS))  THEN
C           OUTSIDE SQUARE (0,4)X(0,4)  IMPLIES   NONMONOTONIC.
            ISMON = 2
         ELSE
C           MUST CHECK AGAINST BOUNDARY OF ELLIPSE.
            A = A - TWO
            B = B - TWO
            PHI = ((A*A + B*B) + A*B) - THREE
            IF (PHI .LT. -EPS)  THEN
               ISMON = ITRUE
            ELSE IF (PHI .GT. EPS)  THEN
               ISMON = 2
            ELSE
C              TO CLOSE TO BOUNDARY TO TELL,
C                  IN THE PRESENCE OF ROUND-OFF ERRORS.
               ISMON = 3*ITRUE
            ENDIF
         ENDIF
      ENDIF
C
C  RETURN VALUE.
C
      DCHFCM = ISMON
      RETURN
C------------- LAST LINE OF DCHFCM FOLLOWS -----------------------------
      END


! Copyright (c) 2018 Etienne Descamps
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
!    this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation and/or
!    other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its contributors may be
!    used to endorse or promote products derived from this software without specific prior
!    written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
! IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
! INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
! EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Module mlf_sobol1111
  Use ieee_arithmetic
  Use iso_c_binding
  Use mlf_sobol1111_table
  IMPLICIT NONE
  PRIVATE

  ! Generator of quasirandom Sobol sequences based on:
  ! Algorithm 659: Implementing Sobol's Quasirandom Sequence Generator
  ! from Paul Bratley and Bennett Fox
  ! ACM Transactions on Mathematical Software, Volume 14, Number 1, March 1988
  !
  ! Using improvements from Stephen Joe and Frances Kuo described in
  ! Remark on Algorithm 659: Impelmenting Sobol's Quasirandom
  ! Sequence Generator
  ! ACM Transations on Mathematical Software, Vol 29, No. 1, March 2003
  !
  ! More details on this method can be found at the address:
  ! http://web.science.unsw.edu.au/~fkuo/sobol/
  !
  ! The init procedure of the module has been inspired by the method i8_sobol,
  ! from the file sobol.f90 that can be found here:
  ! https://people.sc.fsu.edu/~jburkardt/f_src/sobol/sobol.html

  Integer, Parameter :: s_dimMax = 1111
  Integer, Parameter :: s_logMax = 62
  Integer(8), Parameter :: s_mask = SHIFTR(-1_8,2)

  Type, Public :: mlf_sobol1111_sampler
    integer :: numDim
    integer(8) :: seed
    integer(8), allocatable :: table(:,:), last(:)
  Contains
    procedure :: init => mlf_sobol1111_init
    procedure :: mlf_sobol1111_sampleReal, mlf_sobol1111_sampleInt
    procedure :: mlf_sobol1111_sampleMatrix
    generic :: sample => mlf_sobol1111_sampleReal, mlf_sobol1111_sampleInt, &
      mlf_sobol1111_sampleMatrix
  End Type mlf_sobol1111_sampler
Contains

  Subroutine SetVect1(V, S, B)
    integer(8), intent(inout) :: V(:)
    integer, intent(in) :: B
    integer(1), dimension(B:), intent(in) :: S
    integer :: N
    N = SIZE(V)
    If(B > N) RETURN
    V(B:) = INT(S(B:N), KIND = 8)
  End Subroutine SetVect1

  Subroutine SetVect2(V, S, B)
    integer(8), intent(inout) :: V(:)
    integer, intent(in) :: B
    integer(2), dimension(B:), intent(in) :: S
    integer :: N
    N = SIZE(V)
    If(B > N) RETURN
    V(B:) = INT(S(B:N), KIND = 8)
  End Subroutine SetVect2

  Integer Function mlf_sobol1111_init(this, numDim) Result(info)
    class(mlf_sobol1111_sampler), intent(inout) :: this
    integer, intent(in) :: numDim
    integer(8) :: newV
    integer :: i, j, m, k
    integer(2) :: poly
    info = -1
    If(numDim > s_dimMax .OR. numDim <= 0) RETURN
    ALLOCATE(this%table(numDim, s_logMax))
    ASSOCIATE(V => this%table)
      V = 0
      v(1,:) = 1
      V(2:,1) = 1
      CALL SetVect1(V(:,2), Sobol1111_V2, LBOUND(Sobol1111_V2, 1))
      CALL SetVect1(V(:,3), Sobol1111_V3, LBOUND(Sobol1111_V3, 1))
      CALL SetVect1(V(:,4), Sobol1111_V4, LBOUND(Sobol1111_V4, 1))
      CALL SetVect1(V(:,5), Sobol1111_V5, LBOUND(Sobol1111_V5, 1))
      CALL SetVect1(V(:,6), Sobol1111_V6, LBOUND(Sobol1111_V6, 1))
      CALL SetVect1(V(:,7), Sobol1111_V7, LBOUND(Sobol1111_V7, 1))
      CALL SetVect2(V(:,8), Sobol1111_V8, LBOUND(Sobol1111_V8, 1))
      CALL SetVect2(V(:,9), Sobol1111_V9, LBOUND(Sobol1111_V9, 1))
      CALL SetVect2(V(:,10), Sobol1111_V10, LBOUND(Sobol1111_V10, 1))
      CALL SetVect2(V(:,11), Sobol1111_V11, LBOUND(Sobol1111_V11, 1))
      CALL SetVect2(V(:,12), Sobol1111_V12, LBOUND(Sobol1111_V12, 1))
      CALL SetVect2(V(:,13), Sobol1111_V13, LBOUND(Sobol1111_V13, 1))
      Do i = 1, numDim
        poly = Sobol1111_Poly(i)
        m = BIT_SIZE(poly)-LEADZ(poly)-1
        Do j = m+1, s_logMax
          newV = V(i, j-m)
          Do k = 1, m
            If(BTEST(poly, m-k)) newV = IEOR(newV, SHIFTL(V(i, j-k), k))
          End Do
          V(i,j) = newV
        End Do
      End Do
      FORALL(i=1:s_logMax-1) V(:,i) = SHIFTL(V(:,i), s_logMax-i)
    END ASSOCIATE
    info = 0
  End Function mlf_sobol1111_init

  Elemental Real(c_double) Function ConvToReal(X) Result(Y)
    integer(8), intent(in) :: X
    integer(8), parameter :: Z = TRANSFER(1d0, 1_8)
    Y = TRANSFER(IOR(Z, SHIFTR(X, 10)), 1d0)-1d0
  End Function ConvToReal

  Subroutine Sobol1111NextSample(this)
    class(mlf_sobol1111_sampler), intent(inout) :: this
    integer :: l, numDim
    numDim = SIZE(this%table, 1)
    If(.NOT. ALLOCATED(this%last)) Then
      ALLOCATE(this%last(numDim))
      this%last = 0
      this%seed = 0
    Else
      l = TRAILZ(NOT(this%seed))+1
      this%last = IEOR(this%last, this%table(:,l))
      this%seed = IAND(this%seed+1, s_mask)
    Endif
  End Subroutine Sobol1111NextSample

  Integer Function mlf_sobol1111_sampleInt(this, X) Result(info)
    class(mlf_sobol1111_sampler), intent(inout) :: this
    integer(c_int64_t), intent(out) :: X(:)
    CALL Sobol1111NextSample(this)
    X = SHIFTL(this%last, 1)
    info = 0
  End Function mlf_sobol1111_sampleInt

  Integer Function mlf_sobol1111_sampleReal(this, X) Result(info)
    class(mlf_sobol1111_sampler), intent(inout) :: this
    real(c_double), intent(out) :: X(:)
    CALL Sobol1111NextSample(this)
    X = ConvToReal(this%last)
    info = 0
  End Function mlf_sobol1111_sampleReal

  Integer Function mlf_sobol1111_sampleMatrix(this, X) Result(info)
    class(mlf_sobol1111_sampler), intent(inout) :: this
    real(c_double), intent(out) :: X(:,:)
    integer :: i
    Do i = 1, SIZE(X,2)
      info = mlf_sobol1111_sampleReal(this, X(:,i))
    End Do
    info = 0
  End Function mlf_sobol1111_sampleMatrix
End Module mlf_sobol1111


*DECK DNBCO
      SUBROUTINE DNBCO (ABE, LDA, N, ML, MU, IPVT, RCOND, Z)
C***BEGIN PROLOGUE  DNBCO
C***PURPOSE  Factor a band matrix using Gaussian elimination and
C            estimate the condition number.
C***LIBRARY   SLATEC
C***CATEGORY  D2A2
C***TYPE      DOUBLE PRECISION (SNBCO-S, DNBCO-D, CNBCO-C)
C***KEYWORDS  BANDED, LINEAR EQUATIONS, MATRIX FACTORIZATION,
C             NONSYMMETRIC
C***AUTHOR  Voorhees, E. A., (LANL)
C***DESCRIPTION
C
C     DNBCO factors a double precision band matrix by Gaussian
C     elimination and estimates the condition of the matrix.
C
C     If RCOND is not needed, DNBFA is slightly faster.
C     To solve  A*X = B , follow DNBCO by DNBSL.
C     To compute  INVERSE(A)*C , follow DNBCO by DNBSL.
C     To compute  DETERMINANT(A) , follow DNBCO by DNBDI.
C
C     On Entry
C
C        ABE     DOUBLE PRECISION(LDA, NC)
C                contains the matrix in band storage.  The rows
C                of the original matrix are stored in the rows
C                of ABE and the diagonals of the original matrix
C                are stored in columns 1 through ML+MU+1 of ABE.
C                NC must be .GE. 2*ML+MU+1 .
C                See the comments below for details.
C
C        LDA     INTEGER
C                the leading dimension of the array ABE.
C                LDA must be .GE.  N .
C
C        N       INTEGER
C                the order of the original matrix.
C
C        ML      INTEGER
C                number of diagonals below the main diagonal.
C                0 .LE. ML .LT.  N .
C
C        MU      INTEGER
C                number of diagonals above the main diagonal.
C                0 .LE. MU .LT.  N .
C                More efficient if ML .LE. MU .
C
C     On Return
C
C        ABE     an upper triangular matrix in band storage
C                and the multipliers which were used to obtain it.
C                The factorization can be written  A = L*U  where
C                L is a product of permutation and unit lower
C                triangular matrices and  U  is upper triangular.
C
C        IPVT    INTEGER(N)
C                an integer vector of pivot indices.
C
C        RCOND   DOUBLE PRECISION
C                an estimate of the reciprocal condition of  A .
C                For the system  A*X = B , relative perturbations
C                in  A  and  B  of size  EPSILON  may cause
C                relative perturbations in  X  of size  EPSILON/RCOND .
C                If  RCOND  is so small that the logical expression
C                         1.0 + RCOND .EQ. 1.0
C                is true, then  A  may be singular to working
C                precision.  In particular,  RCOND  is zero  if
C                exact singularity is detected or the estimate
C                underflows.
C
C        Z       DOUBLE PRECISION(N)
C                a work vector whose contents are usually unimportant.
C                If  A  is close to a singular matrix, then  Z  is
C                an approximate null vector in the sense that
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C
C     Band Storage
C
C           If  A  is a band matrix, the following program segment
C           will set up the input.
C
C                   ML = (band width below the diagonal)
C                   MU = (band width above the diagonal)
C                   DO 20 I = 1, N
C                      J1 = MAX(1, I-ML)
C                      J2 = MIN(N, I+MU)
C                      DO 10 J = J1, J2
C                         K = J - I + ML + 1
C                         ABE(I,K) = A(I,J)
C                10    CONTINUE
C                20 CONTINUE
C
C           This uses columns  1  through  ML+MU+1  of ABE .
C           Furthermore,  ML  additional columns are needed in
C           ABE  starting with column  ML+MU+2  for elements
C           generated during the triangularization.  The total
C           number of columns needed in  ABE  is  2*ML+MU+1 .
C
C     Example:  If the original matrix is
C
C           11 12 13  0  0  0
C           21 22 23 24  0  0
C            0 32 33 34 35  0
C            0  0 43 44 45 46
C            0  0  0 54 55 56
C            0  0  0  0 65 66
C
C      then  N = 6, ML = 1, MU = 2, LDA .GE. 5  and ABE should contain
C
C            * 11 12 13  +     , * = not used
C           21 22 23 24  +     , + = used for pivoting
C           32 33 34 35  +
C           43 44 45 46  +
C           54 55 56  *  +
C           65 66  *  *  +
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  DASUM, DAXPY, DDOT, DNBFA, DSCAL
C***REVISION HISTORY  (YYMMDD)
C   800728  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DNBCO
      INTEGER LDA,N,ML,MU,IPVT(*)
      DOUBLE PRECISION ABE(LDA,*),Z(*)
      DOUBLE PRECISION RCOND
C
      DOUBLE PRECISION DDOT,EK,T,WK,WKM
      DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM
      INTEGER I,INFO,J,JU,K,KB,KP1,L,LDB,LM,LZ,M,ML1,MM,NL,NU
C***FIRST EXECUTABLE STATEMENT  DNBCO
      ML1=ML+1
      LDB = LDA - 1
      ANORM = 0.0D0
      DO 10 J = 1, N
        NU = MIN(MU,J-1)
        NL = MIN(ML,N-J)
        L = 1 + NU + NL
        ANORM = MAX(ANORM,DASUM(L,ABE(J+NL,ML1-NL),LDB))
   10 CONTINUE
C
C     FACTOR
C
      CALL DNBFA(ABE,LDA,N,ML,MU,IPVT,INFO)
C
C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND TRANS(A)*Y = E .
C     TRANS(A)  IS THE TRANSPOSE OF A .  THE COMPONENTS OF  E  ARE
C     CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF  W WHERE
C     TRANS(U)*W = E .  THE VECTORS ARE FREQUENTLY RESCALED TO AVOID
C     OVERFLOW.
C
C     SOLVE TRANS(U)*W = E
C
      EK = 1.0D0
      DO 20 J = 1, N
        Z(J) = 0.0D0
   20 CONTINUE
      M = ML + MU + 1
      JU = 0
      DO 100 K = 1, N
        IF (Z(K) .NE. 0.0D0) EK = SIGN(EK,-Z(K))
        IF (ABS(EK-Z(K)) .LE. ABS(ABE(K,ML1))) GO TO 30
          S = ABS(ABE(K,ML1))/ABS(EK-Z(K))
          CALL DSCAL(N,S,Z,1)
          EK = S*EK
   30   CONTINUE
        WK = EK - Z(K)
        WKM = -EK - Z(K)
        S = ABS(WK)
        SM = ABS(WKM)
        IF (ABE(K,ML1) .EQ. 0.0D0) GO TO 40
          WK = WK/ABE(K,ML1)
          WKM = WKM/ABE(K,ML1)
        GO TO 50
   40   CONTINUE
          WK = 1.0D0
          WKM = 1.0D0
   50   CONTINUE
        KP1 = K + 1
        JU = MIN(MAX(JU,MU+IPVT(K)),N)
        MM = ML1
        IF (KP1 .GT. JU) GO TO 90
          DO 60 I = KP1, JU
            MM = MM + 1
            SM = SM + ABS(Z(I)+WKM*ABE(K,MM))
            Z(I) = Z(I) + WK*ABE(K,MM)
            S = S + ABS(Z(I))
   60     CONTINUE
          IF (S .GE. SM) GO TO 80
            T = WKM -WK
            WK = WKM
            MM = ML1
            DO 70 I = KP1, JU
              MM = MM + 1
              Z(I) = Z(I) + T*ABE(K,MM)
   70       CONTINUE
   80     CONTINUE
   90   CONTINUE
      Z(K) = WK
  100 CONTINUE
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
C
C     SOLVE TRANS(L)*Y = W
C
      DO 120 KB = 1, N
        K = N + 1 - KB
        NL = MIN(ML,N-K)
        IF (K .LT. N) Z(K) = Z(K) + DDOT(NL,ABE(K+NL,ML1-NL),-LDB,Z(K+1)
     1  ,1)
        IF (ABS(Z(K)) .LE. 1.0D0) GO TO 110
          S = 1.0D0/ABS(Z(K))
          CALL DSCAL(N,S,Z,1)
  110   CONTINUE
        L = IPVT(K)
        T = Z(L)
        Z(L) = Z(K)
        Z(K) = T
  120 CONTINUE
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
C
      YNORM = 1.0D0
C
C     SOLVE L*V = Y
C
      DO 140 K = 1, N
        L = IPVT(K)
        T = Z(L)
        Z(L) = Z(K)
        Z(K) = T
        NL = MIN(ML,N-K)
        IF (K .LT. N) CALL DAXPY(NL,T,ABE(K+NL,ML1-NL),-LDB,Z(K+1),1)
        IF (ABS(Z(K)) .LE. 1.0D0) GO TO 130
          S = 1.0D0/ABS(Z(K))
          CALL DSCAL(N,S,Z,1)
          YNORM = S*YNORM
  130   CONTINUE
  140 CONTINUE
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
C     SOLVE  U*Z = V
C
      DO 160 KB = 1, N
        K = N + 1 - KB
        IF (ABS(Z(K)) .LE. ABS(ABE(K,ML1))) GO TO 150
          S = ABS(ABE(K,ML1))/ABS(Z(K))
          CALL DSCAL(N,S,Z,1)
          YNORM = S*YNORM
  150   CONTINUE
        IF (ABE(K,ML1) .NE. 0.0D0) Z(K) = Z(K)/ABE(K,ML1)
        IF (ABE(K,ML1) .EQ. 0.0D0) Z(K) = 1.0D0
        LM = MIN(K,M) - 1
        LZ = K - LM
        T = -Z(K)
        CALL DAXPY(LM,T,ABE(K-1,ML+2),-LDB,Z(LZ),1)
  160 CONTINUE
C     MAKE ZNORM = 1.0D0
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
      IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM
      IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0
      RETURN
      END


      subroutine getindx(n,min,siz,loc,index,inflag)
c-----------------------------------------------------------------------
c
c     Gets the coordinate index location of a point within a grid
c     ***********************************************************
c
c
c n       number of "nodes" or "cells" in this coordinate direction
c min     origin at the center of the first cell
c siz     size of the cells
c loc     location of the point being considered
c index   output index within [1,n]
c inflag  true if the location is actually in the grid (false otherwise
c         e.g., if the location is outside then index will be set to
c         nearest boundary
c
c
c
c-----------------------------------------------------------------------
      integer   n,index
      real      min,siz,loc
      logical   inflag
c
c Compute the index of "loc":
c
      index = int( (loc-min)/siz + 1.5 )
c
c Check to see if in or out:
c
      if(index.lt.1) then
            index  = 1
            inflag = .false.
      else if(index.gt.n) then
            index  = n
            inflag = .false.
      else
            inflag = .true.
      end if
c
c Return to calling program:
c
      return
      end


program sort_energies
   use sorting_subroutines
implicit none
integer, parameter :: dp = SELECTED_REAL_KIND(15)

integer, allocatable, dimension(:) :: jobs, jobs1
real(dp), allocatable, dimension(:) :: energies, energies1
integer :: i, njobs, io, var1
real(dp) :: var2

!-------------------------------------------------
!count the number of jobs - energies
!-------------------------------------------------

open(unit=1, file='energies.txt', status='old', action='read')
njobs = 0
do
   read(1,*,iostat=io) var1, var2
   if (io /= 0) exit
   njobs = njobs + 1
end do
write(*,*) 'njobs', njobs
close(1)

allocate( jobs(njobs), jobs1(njobs), energies(njobs), energies1(njobs) )

!-----------------------------------------------------------------
!read the job number and the energy
!-----------------------------------------------------------------

open(unit=2, file='energies.txt', status='old', action='read')

do i = 1, njobs
   read(2,*) jobs(i), energies(i)
end do

!--------------------------------------------------
!perform the sorting:
!-------------------------------------------------

open(unit=3, file='output.txt', status='replace', action='write')

energies1 = energies
jobs1 = jobs

call bubble_sort(jobs, energies, njobs)

call first_and_last(jobs1, energies1, njobs)

end program sort_energies


!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
PROGRAM testConversions
#include "UnitTest.h"
USE ISO_FORTRAN_ENV
USE UnitTest
USE IntrType
USE Constants_Conversion

IMPLICIT NONE

CREATE_TEST("Conversions")

REGISTER_SUBTEST('Temperatures',testTemperatures)

FINALIZE_TEST()
!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
SUBROUTINE testTemperatures()
  REAL(SRK) :: in_temp(4),out_temp(4)

  COMPONENT_TEST('K_to_C')
  in_temp = (/0.0_SRK,273.15_SRK,565.0_SRK,1200.0_SRK/)
  out_temp = K_to_C(in_temp)
  ASSERT_APPROXEQ(out_temp(1),-273.15_SRK,'0 K_to_C (1D)')
  ASSERT_APPROXEQ(out_temp(2),0.0_SRK,'273.15 K_to_C (1D)')
  ASSERT_APPROXEQ(out_temp(3),291.85_SRK,'565 K_to_C (1D)')
  ASSERT_APPROXEQ(out_temp(4),926.85_SRK,'1200 K_to_C (1D)')
  ASSERT_APPROXEQ(K_to_C(0.0_SRK),-273.15_SRK,'0 K_to_C')
  ASSERT_APPROXEQ(K_to_C(273.15_SRK),0.0_SRK,'273.15 K_to_C')
  ASSERT_APPROXEQ(K_to_C(565.0_SRK),291.85_SRK,'565 K_to_C')
  ASSERT_APPROXEQ(K_to_C(1200.0_SRK),926.85_SRK,'1200 K_to_C')

  COMPONENT_TEST('C_to_K')
  in_temp = (/-273.15_SRK,0.0_SRK,291.85_SRK,926.85_SRK/)
  out_temp = C_to_K(in_temp)
  ASSERT_APPROXEQ(out_temp(1),0.0_SRK,'-273.15 C_to_K (1D)')
  ASSERT_APPROXEQ(out_temp(2),273.15_SRK,'0 C_to_K (1D)')
  ASSERT_APPROXEQ(out_temp(3),565.0_SRK,'291.85 C_to_K (1D)')
  ASSERT_APPROXEQ(out_temp(4),1200.0_SRK,'926.85 C_to_K (1D)')
  ASSERT_APPROXEQ(C_to_K(-273.15_SRK),0.0_SRK,'-273.15 C_to_K')
  ASSERT_APPROXEQ(C_to_K(0.0_SRK),273.15_SRK,'0 C_to_K')
  ASSERT_APPROXEQ(C_to_K(291.85_SRK),565.0_SRK,'291.85 C_to_K')
  ASSERT_APPROXEQ(C_to_K(926.85_SRK),1200.0_SRK,'926.85 C_to_K')

  COMPONENT_TEST('F_to_C')
  in_temp = (/32.0_SRK,68.0_SRK,212.0_SRK,557.33_SRK/)
  out_temp = F_to_C(in_temp)
  ASSERT_APPROXEQ(out_temp(1),0.0_SRK,'32 F_to_C (1D)')
  ASSERT_APPROXEQ(out_temp(2),20.0_SRK,'68 F_to_C (1D)')
  ASSERT_APPROXEQ(out_temp(3),100.0_SRK,'212 F_to_C (1D)')
  ASSERT_APPROXEQ(out_temp(4),291.85_SRK,'557.33 F_to_C (1D)')
  ASSERT_APPROXEQ(F_to_C(32.0_SRK),0.0_SRK,'32 F_to_C')
  ASSERT_APPROXEQ(F_to_C(68.0_SRK),20.0_SRK,'68 F_to_C')
  ASSERT_APPROXEQ(F_to_C(212.0_SRK),100.0_SRK,'212 F_to_C')
  ASSERT_APPROXEQ(F_to_C(557.33_SRK),291.85_SRK,'557.33 F_to_C')

  COMPONENT_TEST('C_to_F')
  in_temp = (/0.0_SRK,20.0_SRK,100.0_SRK,291.85_SRK/)
  out_temp = C_to_F(in_temp)
  ASSERT_APPROXEQ(out_temp(1),32.0_SRK,'0 C_to_F (1D)')
  ASSERT_APPROXEQ(out_temp(2),68.0_SRK,'20 C_to_F (1D)')
  ASSERT_APPROXEQ(out_temp(3),212.0_SRK,'100 C_to_F (1D)')
  ASSERT_APPROXEQ(out_temp(4),557.33_SRK,'291.85 C_to_F (1D)')
  ASSERT_APPROXEQ(C_to_F(0.0_SRK),32.0_SRK,'0 C_to_F')
  ASSERT_APPROXEQ(C_to_F(20.0_SRK),68.0_SRK,'20 C_to_F')
  ASSERT_APPROXEQ(C_to_F(100.0_SRK),212.0_SRK,'100 C_to_F')
  ASSERT_APPROXEQ(C_to_F(291.85_SRK),557.33_SRK,'291.85 C_to_F')

  COMPONENT_TEST('F_to_K')
  in_temp = (/32.0_SRK,68.0_SRK,212.0_SRK,557.33_SRK/)
  out_temp = F_to_K(in_temp)
  ASSERT_APPROXEQ(out_temp(1),273.15_SRK,'32 F_to_K (1D)')
  ASSERT_APPROXEQ(out_temp(2),293.15_SRK,'68 F_to_K (1D)')
  ASSERT_APPROXEQ(out_temp(3),373.15_SRK,'212 F_to_K (1D)')
  ASSERT_APPROXEQ(out_temp(4),565.0_SRK,'557.33 F_to_K (1D)')
  ASSERT_APPROXEQ(F_to_K(32.0_SRK),273.15_SRK,'32 F_to_K')
  ASSERT_APPROXEQ(F_to_K(68.0_SRK),293.15_SRK,'68 F_to_K')
  ASSERT_APPROXEQ(F_to_K(212.0_SRK),373.15_SRK,'212 F_to_K')
  ASSERT_APPROXEQ(F_to_K(557.33_SRK),565.0_SRK,'557.33 F_to_K')

  COMPONENT_TEST('K_to_F')
  in_temp = (/273.15_SRK,293.15_SRK,373.15_SRK,565.0_SRK/)
  out_temp = K_to_F(in_temp)
  ASSERT_APPROXEQ(out_temp(1),32.0_SRK,'273.15 K_to_F (1D)')
  ASSERT_APPROXEQ(out_temp(2),68.0_SRK,'293.15 K_to_F (1D)')
  ASSERT_APPROXEQ(out_temp(3),212.0_SRK,'373.15 K_to_F (1D)')
  ASSERT_APPROXEQ(out_temp(4),557.33_SRK,'565 K_to_F (1D)')
  ASSERT_APPROXEQ(K_to_F(273.15_SRK),32.0_SRK,'273.15 K_to_F')
  ASSERT_APPROXEQ(K_to_F(293.15_SRK),68.0_SRK,'293.15 K_to_F')
  ASSERT_APPROXEQ(K_to_F(373.15_SRK),212.0_SRK,'373.15 K_to_F')
  ASSERT_APPROXEQ(K_to_F(565.0_SRK),557.33_SRK,'565 K_to_F')

  COMPONENT_TEST('tempTo_C')
  !To Celsius from Kelvin
  in_temp = (/0.0_SRK,273.15_SRK,565.0_SRK,1200.0_SRK/)
  out_temp = tempTo_C(in_temp,'K')
  ASSERT_APPROXEQ(out_temp(1),-273.15_SRK,'0 K_to_C (1D)')
  ASSERT_APPROXEQ(out_temp(2),0.0_SRK,'273.15 K_to_C (1D)')
  ASSERT_APPROXEQ(out_temp(3),291.85_SRK,'565 K_to_C (1D)')
  ASSERT_APPROXEQ(out_temp(4),926.85_SRK,'1200 K_to_C (1D)')
  !To Celsius from Fahrenheit
  in_temp = (/32.0_SRK,68.0_SRK,212.0_SRK,557.33_SRK/)
  out_temp = tempTo_C(in_temp,'F')
  ASSERT_APPROXEQ(out_temp(1),0.0_SRK,'32 F_to_C (1D)')
  ASSERT_APPROXEQ(out_temp(2),20.0_SRK,'68 F_to_C (1D)')
  ASSERT_APPROXEQ(out_temp(3),100.0_SRK,'212 F_to_C (1D)')
  ASSERT_APPROXEQ(out_temp(4),291.85_SRK,'557.33 F_to_C (1D)')
  !To Celsius from Rankine
  in_temp = (/0.0_SRK,273.15_SRK,546.3_SRK,1475.01_SRK/)
  out_temp = tempTo_C(in_temp,'R')
  ASSERT_APPROXEQF(out_temp(1),-273.15_SRK,'0 R_to_C (1D)')
  ASSERT_APPROXEQF(out_temp(2),-121.4_SRK,'273.15 R_to_C (1D)')
  ASSERT_APPROXEQF(out_temp(3),30.35_SRK,'565 R_to_C (1D)')
  ASSERT_APPROXEQF(out_temp(4),546.3_SRK,'1200 R_to_C (1D)')

  COMPONENT_TEST('tempTo_K')
  !To Kelvin from Celsius
  in_temp = (/-273.15_SRK,0.0_SRK,291.85_SRK,926.85_SRK/)
  out_temp = tempTo_K(in_temp,'C')
  ASSERT_APPROXEQ(out_temp(1),0.0_SRK,'-273.15 C_to_K (1D)')
  ASSERT_APPROXEQ(out_temp(2),273.15_SRK,'0 C_to_K (1D)')
  ASSERT_APPROXEQ(out_temp(3),565.0_SRK,'291.85 C_to_K (1D)')
  ASSERT_APPROXEQ(out_temp(4),1200.0_SRK,'926.85 C_to_K (1D)')
  !To Kelvin from Fahrenheit
  in_temp = (/32.0_SRK,68.0_SRK,212.0_SRK,557.33_SRK/)
  out_temp = tempTo_K(in_temp,'F')
  ASSERT_APPROXEQ(out_temp(1),273.15_SRK,'32 F_to_K (1D)')
  ASSERT_APPROXEQ(out_temp(2),293.15_SRK,'68 F_to_K (1D)')
  ASSERT_APPROXEQ(out_temp(3),373.15_SRK,'212 F_to_K (1D)')
  ASSERT_APPROXEQ(out_temp(4),565.0_SRK,'557.33 F_to_K (1D)')
  !To Kelvin from Rankine
  in_temp = (/0.0_SRK,491.67_SRK,983.34_SRK,1475.01_SRK/)
  out_temp = tempTo_K(in_temp,'R')
  ASSERT_APPROXEQF(out_temp(1),0.0_SRK,'0 R_to_K (1D)')
  ASSERT_APPROXEQF(out_temp(2),273.15_SRK,'491.67 R_to_K (1D)')
  ASSERT_APPROXEQF(out_temp(3),546.3_SRK,'565 R_to_K (1D)')
  ASSERT_APPROXEQF(out_temp(4),819.45_SRK,'1200 R_to_K (1D)')

  COMPONENT_TEST('tempTo_F')
  !To Fahrenheit from Celsius
  in_temp = (/0.0_SRK,20.0_SRK,100.0_SRK,291.85_SRK/)
  out_temp = tempTo_F(in_temp,'C')
  ASSERT_APPROXEQ(out_temp(1),32.0_SRK,'0 C_to_F (1D)')
  ASSERT_APPROXEQ(out_temp(2),68.0_SRK,'20 C_to_F (1D)')
  ASSERT_APPROXEQ(out_temp(3),212.0_SRK,'100 C_to_F (1D)')
  ASSERT_APPROXEQ(out_temp(4),557.33_SRK,'291.85 C_to_F (1D)')
  !To Fahrenheit from Kelvin
  in_temp = (/273.15_SRK,293.15_SRK,373.15_SRK,565.0_SRK/)
  out_temp = tempTo_F(in_temp,'K')
  ASSERT_APPROXEQ(out_temp(1),32.0_SRK,'273.15 K_to_F (1D)')
  ASSERT_APPROXEQ(out_temp(2),68.0_SRK,'293.15 K_to_F (1D)')
  ASSERT_APPROXEQ(out_temp(3),212.0_SRK,'373.15 K_to_F (1D)')
  ASSERT_APPROXEQ(out_temp(4),557.33_SRK,'565 K_to_F (1D)')
  !To Fahrenheit from Rankine
  in_temp = (/0.0_SRK,459.67_SRK,919.34_SRK,1379.01_SRK/)
  out_temp = tempTo_F(in_temp,'R')
  ASSERT_APPROXEQF(out_temp(1),-459.67_SRK,'0 R_to_K (1D)')
  ASSERT_APPROXEQF(out_temp(2),0.0_SRK,'491.67 R_to_K (1D)')
  ASSERT_APPROXEQF(out_temp(3),459.67_SRK,'565 R_to_K (1D)')
  ASSERT_APPROXEQF(out_temp(4),919.34_SRK,'1200 R_to_K (1D)')

  COMPONENT_TEST('tempTo_R')
  !To Celsius from Rankine
  in_temp = (/-273.15_SRK,-121.4_SRK,30.35_SRK,546.3_SRK/)
  out_temp = tempTo_R(in_temp,'C')
  ASSERT_APPROXEQF(out_temp(1),0.0_SRK,'0 C_to_R (1D)')
  ASSERT_APPROXEQF(out_temp(2),273.15_SRK,'273.15 C_to_R (1D)')
  ASSERT_APPROXEQF(out_temp(3),546.3_SRK,'565 C_to_R (1D)')
  ASSERT_APPROXEQF(out_temp(4),1475.01_SRK,'1200 C_to_R (1D)')
  !To Kelvin from Rankine
  in_temp = (/0.0_SRK,273.15_SRK,546.3_SRK,819.45_SRK/)
  out_temp = tempTo_R(in_temp,'K')
  ASSERT_APPROXEQF(out_temp(1),0.0_SRK,'0 K_to_R (1D)')
  ASSERT_APPROXEQF(out_temp(2),491.67_SRK,'491.67 K_to_R (1D)')
  ASSERT_APPROXEQF(out_temp(3),983.34_SRK,'565 K_to_R (1D)')
  ASSERT_APPROXEQF(out_temp(4),1475.01_SRK,'1200 K_to_R (1D)')
  !To Rankine from Fahrenheit
  in_temp = (/-459.67_SRK,0.0_SRK,459.67_SRK,919.34_SRK/)
  out_temp = tempTo_R(in_temp,'F')
  ASSERT_APPROXEQF(out_temp(1),0.0_SRK,'0 F_to_R (1D)')
  ASSERT_APPROXEQF(out_temp(2),459.67_SRK,'491.67 F_to_R (1D)')
  ASSERT_APPROXEQF(out_temp(3),919.34_SRK,'565 F_to_R (1D)')
  ASSERT_APPROXEQF(out_temp(4),1379.01_SRK,'1200 F_to_R (1D)')

  COMPONENT_TEST('convertTemp')
  !To Kelvin from Celsius
  in_temp = (/-273.15_SRK,0.0_SRK,291.85_SRK,926.85_SRK/)
  out_temp = convertTemp(in_temp,'C','K')
  ASSERT_APPROXEQ(out_temp(1),0.0_SRK,'-273.15 C_to_K (1D)')
  ASSERT_APPROXEQ(out_temp(2),273.15_SRK,'0 C_to_K (1D)')
  ASSERT_APPROXEQ(out_temp(3),565.0_SRK,'291.85 C_to_K (1D)')
  ASSERT_APPROXEQ(out_temp(4),1200.0_SRK,'926.85 C_to_K (1D)')
  !To Kelvin from Fahrenheit
  in_temp = (/32.0_SRK,68.0_SRK,212.0_SRK,557.33_SRK/)
  out_temp = convertTemp(in_temp,'F','K')
  ASSERT_APPROXEQ(out_temp(1),273.15_SRK,'32 F_to_K (1D)')
  ASSERT_APPROXEQ(out_temp(2),293.15_SRK,'68 F_to_K (1D)')
  ASSERT_APPROXEQ(out_temp(3),373.15_SRK,'212 F_to_K (1D)')
  ASSERT_APPROXEQ(out_temp(4),565.0_SRK,'557.33 F_to_K (1D)')
  !To Kelvin from Rankine
  in_temp = (/0.0_SRK,491.67_SRK,983.34_SRK,1475.01_SRK/)
  out_temp = convertTemp(in_temp,'R','K')
  ASSERT_APPROXEQF(out_temp(1),0.0_SRK,'0 R_to_K (1D)')
  ASSERT_APPROXEQF(out_temp(2),273.15_SRK,'491.67 R_to_K (1D)')
  ASSERT_APPROXEQF(out_temp(3),546.3_SRK,'565 R_to_K (1D)')
  ASSERT_APPROXEQF(out_temp(4),819.45_SRK,'1200 R_to_K (1D)')
  !To Fahrenheit from Celsius
  in_temp = (/0.0_SRK,20.0_SRK,100.0_SRK,291.85_SRK/)
  out_temp = convertTemp(in_temp,'C','F')
  ASSERT_APPROXEQ(out_temp(1),32.0_SRK,'0 C_to_F (1D)')
  ASSERT_APPROXEQ(out_temp(2),68.0_SRK,'20 C_to_F (1D)')
  ASSERT_APPROXEQ(out_temp(3),212.0_SRK,'100 C_to_F (1D)')
  ASSERT_APPROXEQ(out_temp(4),557.33_SRK,'291.85 C_to_F (1D)')
  !To Fahrenheit from Kelvin
  in_temp = (/273.15_SRK,293.15_SRK,373.15_SRK,565.0_SRK/)
  out_temp = convertTemp(in_temp,'K','F')
  ASSERT_APPROXEQ(out_temp(1),32.0_SRK,'273.15 K_to_F (1D)')
  ASSERT_APPROXEQ(out_temp(2),68.0_SRK,'293.15 K_to_F (1D)')
  ASSERT_APPROXEQ(out_temp(3),212.0_SRK,'373.15 K_to_F (1D)')
  ASSERT_APPROXEQ(out_temp(4),557.33_SRK,'565 K_to_F (1D)')
  !To Fahrenheit from Rankine
  in_temp = (/0.0_SRK,459.67_SRK,919.34_SRK,1379.01_SRK/)
  out_temp = convertTemp(in_temp,'R','F')
  ASSERT_APPROXEQF(out_temp(1),-459.67_SRK,'0 R_to_K (1D)')
  ASSERT_APPROXEQF(out_temp(2),0.0_SRK,'491.67 R_to_K (1D)')
  ASSERT_APPROXEQF(out_temp(3),459.67_SRK,'565 R_to_K (1D)')
  ASSERT_APPROXEQF(out_temp(4),919.34_SRK,'1200 R_to_K (1D)')
  !To Celsius from Rankine
  in_temp = (/-273.15_SRK,-121.4_SRK,30.35_SRK,546.3_SRK/)
  out_temp = convertTemp(in_temp,'C','R')
  ASSERT_APPROXEQF(out_temp(1),0.0_SRK,'0 C_to_R (1D)')
  ASSERT_APPROXEQF(out_temp(2),273.15_SRK,'273.15 C_to_R (1D)')
  ASSERT_APPROXEQF(out_temp(3),546.3_SRK,'565 C_to_R (1D)')
  ASSERT_APPROXEQF(out_temp(4),1475.01_SRK,'1200 C_to_R (1D)')
  !To Kelvin from Rankine
  in_temp = (/0.0_SRK,273.15_SRK,546.3_SRK,819.45_SRK/)
  out_temp = convertTemp(in_temp,'K','R')
  ASSERT_APPROXEQF(out_temp(1),0.0_SRK,'0 K_to_R (1D)')
  ASSERT_APPROXEQF(out_temp(2),491.67_SRK,'491.67 K_to_R (1D)')
  ASSERT_APPROXEQF(out_temp(3),983.34_SRK,'565 K_to_R (1D)')
  ASSERT_APPROXEQF(out_temp(4),1475.01_SRK,'1200 K_to_R (1D)')
  !To Rankine from Fahrenheit
  in_temp = (/-459.67_SRK,0.0_SRK,459.67_SRK,919.34_SRK/)
  out_temp = convertTemp(in_temp,'F','R')
  ASSERT_APPROXEQF(out_temp(1),0.0_SRK,'0 F_to_R (1D)')
  ASSERT_APPROXEQF(out_temp(2),459.67_SRK,'491.67 F_to_R (1D)')
  ASSERT_APPROXEQF(out_temp(3),919.34_SRK,'565 F_to_R (1D)')
  ASSERT_APPROXEQF(out_temp(4),1379.01_SRK,'1200 F_to_R (1D)')

ENDSUBROUTINE testTemperatures
!
ENDPROGRAM testConversions


MODULE Basis_m
  USE NumParameters_m

  IMPLICIT NONE

  PRIVATE
  PUBLIC :: Basis_t,Read_Basis,Write_Basis,Basis_IS_allocated

  TYPE :: Basis_t
    integer                         :: nb         = 0
    integer                         :: nq         = 0

    character (len=:),  allocatable :: Basis_name

    real(kind=Rk),   allocatable :: x(:)
    real(kind=Rk),   allocatable :: w(:)
    real(kind=Rk),   allocatable :: d0gb(:,:)      ! basis functions d0gb(nq,nb)
    real(kind=Rk),   allocatable :: d1gb(:,:,:)    ! basis functions d2gb(nq,nb,1)
    real(kind=Rk),   allocatable :: d2gb(:,:,:,:)  ! basis functions d2gb(nq,nb,1,1)

  END TYPE Basis_t

CONTAINS
  FUNCTION Basis_IS_allocated(Basis) RESULT(alloc)

    TYPE(Basis_t),   intent(in)  :: Basis
    logical                      :: alloc

    alloc =             allocated(Basis%x)
    alloc = alloc .AND. allocated(Basis%w)
    alloc = alloc .AND. allocated(Basis%d0gb)
    alloc = alloc .AND. allocated(Basis%d1gb)
    alloc = alloc .AND. allocated(Basis%d2gb)

  END FUNCTION Basis_IS_allocated
  RECURSIVE SUBROUTINE Write_Basis(Basis)
  USE UtilLib_m

    TYPE(Basis_t),       intent(in)  :: Basis

    write(out_unitp,*) '-------------------------------------------------'
    write(out_unitp,*) 'Write_Basis'
    write(out_unitp,*) 'nb,nq',Basis%nb,Basis%nq
    IF (Basis_IS_allocated(Basis)) THEN
      CALL Write_RVec(Basis%x,out_unitp,5,name_info='x')
      write(out_unitp,*)
      CALL Write_RVec(Basis%w,out_unitp,5,name_info='w')
      write(out_unitp,*)
      CALL Write_RMat(Basis%d0gb,out_unitp,5,name_info='d0gb')
      write(out_unitp,*)
      CALL Write_RMat(Basis%d1gb(:,:,1),out_unitp,5,name_info='d1gb')
      write(out_unitp,*)
      CALL Write_RMat(Basis%d2gb(:,:,1,1),out_unitp,5,name_info='d2gb')
    ELSE
      write(out_unitp,*) ' Basis tables (x, w, dngb) are not allocated.'
    END IF

    write(out_unitp,*) '-------------------------------------------------'

  END SUBROUTINE Write_Basis
  RECURSIVE SUBROUTINE Read_Basis(Basis,nio)
    USE UtilLib_m

    TYPE(Basis_t),       intent(inout)  :: Basis
    integer,             intent(in)     :: nio

    integer                         :: err_io

    integer                         :: nb,nq,i,j
    character (len=Name_len)        :: name
    real(kind=Rk)                   :: A,B,scaleQ,Q0

    NAMELIST /basis_nD/ name,nb,nq,A,B,scaleQ,Q0

    nb        = 0
    nq        = 0
    A         = ZERO
    B         = ZERO
    Q0        = ZERO
    scaleQ    = ONE
    name      = '0'

    read(nio,nml=basis_nD,IOSTAT=err_io)
    write(out_unitp,nml=basis_nD)
    IF (err_io < 0) THEN
      write(out_unitp,basis_nD)
      write(out_unitp,*) ' ERROR in Read_Basis'
      write(out_unitp,*) '  while reading the namelist "basis_nD"'
      write(out_unitp,*) ' end of file or end of record'
      write(out_unitp,*) ' Probably, you forget a basis set ...'
      write(out_unitp,*) ' Check your data !!'
      STOP ' ERROR in Read_Basis: problems with the namelist.'
    END IF
    IF (err_io > 0) THEN
      write(out_unitp,basis_nD)
      write(out_unitp,*) ' ERROR in Read_Basis'
      write(out_unitp,*) '  while reading the namelist "basis_nD"'
      write(out_unitp,*) ' Probably, some arguments of namelist are wrong.'
      write(out_unitp,*) ' Check your data !!'
      STOP ' ERROR in Read_Basis: problems with the namelist.'
    END IF

    Basis%nb        = nb
    Basis%nq        = nq
    Basis%Basis_name      = trim(adjustl(name))
    CALL string_uppercase_TO_lowercase(Basis%Basis_name)

    SELECT CASE (Basis%Basis_name)
    CASE ('boxab')
     CALL Construct_Basis_Sin(Basis)
      Q0      = A
      scaleQ  = pi/(B-A)
      CASE ('herm','Ho')
     CALL Construct_Basis_Ho(Basis)
    CASE default
      STOP 'ERROR in Read_Basis: no default basis.'
    END SELECT

    CALL Scale_Basis(Basis,Q0,scaleQ)
    CALL CheckOrtho_Basis(Basis,nderiv=2)

    CALL Write_Basis(Basis)

  END SUBROUTINE Read_Basis
  SUBROUTINE Construct_Basis_Sin(Basis) ! sin : boxAB with A=0 and B=pi
  USE UtilLib_m

    TYPE(Basis_t),       intent(inout)  :: Basis

    real(kind=Rk)          :: dx
    integer                :: ib,iq,nb,nq

    nb = Basis%nb
    nq = Basis%nq
    dx = pi/nq

    ! grid and weight
    Basis%x = [(dx*(iq-HALF),iq=1,nq)]
    Basis%w = [(dx,iq=1,nq)]

    allocate(Basis%d0gb(nq,nb))
    allocate(Basis%d1gb(nq,nb,1))
    allocate(Basis%d2gb(nq,nb,1,1))

    DO ib=1,nb
      Basis%d0gb(:,ib)     =          sin(Basis%x(:)*ib) / sqrt(pi*HALF)
      Basis%d1gb(:,ib,1)   =  ib    * cos(Basis%x(:)*ib) / sqrt(pi*HALF)
      Basis%d2gb(:,ib,1,1) = -ib**2 * Basis%d0gb(:,ib)
    END DO

    IF (nb == nq) THEN
      Basis%d0gb(:,nb)      = Basis%d0gb(:,nb)      / sqrt(TWO)
      Basis%d1gb(:,nb,:)    = Basis%d1gb(:,nb,:)    / sqrt(TWO)
      Basis%d2gb(:,nb,:,:)  = Basis%d2gb(:,nb,:,:)  / sqrt(TWO)
    END IF

  END SUBROUTINE Construct_Basis_Sin

!!!!! la modification de Robert!!!!!!!!!!
 SUBROUTINE Construct_Basis_Ho(Basis) ! HO :
  USE UtilLib_m

    TYPE(Basis_t),       intent(inout)  :: Basis

    integer                :: i,j,nb,nq

    nb = Basis%nb
    nq = Basis%nq
    allocate(Basis%x(nq))
    allocate(Basis%w(nq))

    call hercom(nq, Basis%x(:), Basis%w(:))

    allocate(Basis%d0gb(nq,nb))
    allocate(Basis%d1gb(nq,nb,1))
    allocate(Basis%d2gb(nq,nb,1,1))

    DO i = 1, nq
          DO j = 1, nb
           CALL Construct_Basis_poly_Hermite_exp(Basis%x(i),Basis%d0gb(i,j), Basis%d1gb(i,j,1),Basis%d2gb(i,j,1,1), j-1,.TRUE.)
          END DO
      END DO

  END SUBROUTINE Construct_Basis_Ho

FUNCTION poly_Hermite(x,l)
    Implicit none
    real(kind = Rk):: poly_Hermite
    real(kind = Rk):: pl0,pl1,pl2,norme,x
    integer        :: i,l

      IF ( l .LT. 0 ) THEN
         Write(out_unitp,*) 'Bad arguments in poly_hermite :'
         Write(out_unitp,*) ' l < 0 : ',l
         STOP
        end if

       norme  =  sqrt(PI)

       IF (l .EQ. 0) THEN
         poly_Hermite = ONE/sqrt(norme)
       ELSE IF (l .EQ. 1) THEN
           norme = norme * TWO
         poly_Hermite = TWO * x/sqrt(norme)
       ELSE

         pl2 = ONE
         pl1 = TWO * x
         norme = norme * TWO

         DO i=2,l
           norme = norme * TWO * i
           pl0 = TWO*( x*pl1 - (i-1)*pl2 )
           pl2 = pl1
           pl1 = pl0
         END DO
         poly_Hermite = pl0/sqrt(norme)
       END IF

     END FUNCTION poly_Hermite

 FUNCTION gamma_perso(n)
    Implicit none

    real(kind = Rk)  :: gamma_perso
    real(kind = Rk)  :: a
    integer          :: i,n
       IF (n .LE. 0) THEN
           write(out_unitp,*) 'ERROR: gamma( n<=0)',n
           STOP
         END IF
         a = ONE
         DO i = 1,n-1
           a = a * dble (i)
      END DO
      gamma_perso = a
  END FUNCTION gamma_perso

   SUBROUTINE herrec ( p2, dp2, p1, x, nq )
      Implicit none
      integer       ::i
      integer       :: nq
      real(kind = Rk):: dp0
      real(kind = Rk):: dp1
      real(kind = RK):: dp2

      real(kind = Rk):: p0
      real(kind = Rk):: p1
      real(kind = Rk):: p2
      real(kind = Rk):: x

      p1  = ONE
      dp1 = ZERO

      p2  = x
      dp2 = ONE

      DO i = 2, nq

        p0  = p1
        dp0 = dp1

        p1  = p2
        dp1 = dp2

        p2  = x * p1 - HALF * ( dble ( i ) - ONE ) * p0
        dp2 = x * dp1 + p1 - HALF * ( dble ( i ) - ONE ) * dp0

    END DO
   END SUBROUTINE herrec

  SUBROUTINE herroot ( x, nq, dp2, p1 )
    Implicit none
      integer          :: i
      integer          :: nq
      real(kind = Rk),parameter  :: eps = TEN**(-TWELVE) ! 1.0d-12
      real(kind = Rk)  :: d
      real(kind = Rk)  :: dp2
      real(kind = Rk)  :: p1
      real(kind = Rk)  :: p2
      real(kind = Rk)  :: x

      DO i = 1, 10

        CALL herrec ( p2, dp2, p1, x, nq )

        d = p2 / dp2
        x = x - d

        IF ( ABS ( d ) .LE. eps * ( ABS ( x ) + ONE ) ) THEN
          RETURN
        END IF

      END DO
   END SUBROUTINE herroot

SUBROUTINE hercom (nq,xp,w)
   Implicit none

      integer        :: i,nq
      real(kind = Rk):: cc,dp2,p1,s,temp,x
      real(kind = Rk):: w(nq),xp(nq)

      cc = 1.7724538509_Rk * gamma_perso(nq ) / ( TWO**( nq-1) )

      s = ( TWO * dble (real(nq,Kind=Rk) ) + ONE )**( SIXTH )

      DO i = 1, ( nq + 1 ) / 2

       IF ( i .EQ. 1 ) THEN

          x = s**3 - 1.85575_Rk / s

        ELSE IF ( i .EQ. 2 ) THEN

          x = x - 1.14_Rk * ( ( dble ( nq ) )**0.426_Rk ) / x

        ELSE IF ( i .EQ. 3 ) THEN

          x = 1.86_Rk * x - 0.86_Rk * xp(1)

        ELSE IF ( i .EQ. 4 ) THEN

          x = 1.91_Rk * x - 0.91_Rk * xp(2)

        ELSE

          x = TWO * x - xp(i-2)

        END IF

        CALL herroot ( x,  nq, dp2, p1 )

        xp(i) = x
        W(i) = cc / dp2 / p1

        xp( nq-i+1) = - x
        w( nq-i+1) = w(i)

      END DO

      DO i = 1,  nq/2
        temp = xp(i)
        xp(i) = xp( nq+1-i)
        xp( nq+1-i) = temp
      END DO

      DO i = 1, nq
     w(i) = w(i)*exp(xp(i)*xp(i))
      END DO
 END SUBROUTINE hercom

 SUBROUTINE Construct_Basis_poly_Hermite_exp(x,d0gb,d1gb,d2gb,l,deriv)

      logical deriv

      integer        :: l

      real(kind = RK):: pexp,x,d0gb,d1gb,d2gb

       IF (deriv) THEN

          d0gb = poly_Hermite( x,l)
         IF (l .EQ. 0) THEN
          d1gb     = ZERO
          d2gb     = ZERO
         ELSE IF (l .EQ. 1) THEN
          d1gb = sqrt(TWO)*poly_Hermite( x,0)
          d2gb = ZERO

         ELSE IF (l .EQ. 2) THEN
          d1gb = sqrt(TWO*l) * poly_Hermite( x,l-1)
          d2gb = TWO*( x*d1gb-d0gb *l)
         ELSE
          d1gb = sqrt(TWO*l) * poly_Hermite( x,l-1)
          d2gb = TWO*( x* d1gb-d0gb*l)
         END IF

          pexp = exp(- HALF* x* x)
          d2gb = (d2gb-TWO*x*d1gb+( x* x-ONE)*d0gb)*pexp
          d1gb = (d1gb- x*d0gb)*pexp
          d0gb = d0gb*pexp

       ELSE
         d0gb = poly_Hermite(x ,l)*exp(-HALF* x* x)
         d1gb = ZERO
         d2gb = ZERO
       END IF

  END SUBROUTINE Construct_Basis_poly_Hermite_exp

!!!!!Fin de la modification de Robert!!!!!!!!!!

  SUBROUTINE CheckOrtho_Basis(Basis,nderiv)
  USE UtilLib_m

    TYPE(Basis_t),           intent(in)     :: Basis
    integer,                 intent(in)     :: nderiv

    integer                      :: ib
    real(kind=Rk), ALLOCATABLE   :: S(:,:)
    real(kind=Rk), ALLOCATABLE   :: d0bgw(:,:)
    real(kind=Rk)                :: Sii,Sij

    IF (Basis_IS_allocated(Basis)) THEN
      d0bgw = transpose(Basis%d0gb)
      DO ib=1,Basis%nb
        d0bgw(ib,:) = d0bgw(ib,:) * Basis%w(:)
      END DO

      S = matmul(d0bgw,Basis%d0gb)
      IF (nderiv > -1) CALL Write_RMat(S,out_unitp,5,name_info='S')
      Sii = ZERO
      Sij = ZERO
      DO ib=1,Basis%nb
        IF (abs(S(ib,ib)-ONE) > Sii) Sii = abs(S(ib,ib)-ONE)
        S(ib,ib) = ZERO
      END DO
      Sij = maxval(S)
      write(out_unitp,*) 'Sii,Sij',Sii,Sij

      IF (nderiv > 0) THEN
        write(out_unitp,*)
        S = matmul(d0bgw,Basis%d1gb(:,:,1))
        !CALL Write_RMat(S,out_unitp,5,name_info='<d0b|d1b>',Rformat='e13.4')
        CALL Write_RMat(S,out_unitp,5,name_info='<d0b|d1b>')
      END IF

      IF (nderiv > 1) THEN
        write(out_unitp,*)
        S = matmul(d0bgw,Basis%d2gb(:,:,1,1))
        !CALL Write_RMat(S,out_unitp,5,name_info='<d0b|d2b>',Rformat='e13.4')
        CALL Write_RMat(S,out_unitp,5,name_info='<d0b|d1b>')
      END IF

    ELSE
      write(out_unitp,*) ' WARNNING in CheckOrtho_Basis'
      write(out_unitp,*) ' the basis is not allocated.'
    END IF

  END SUBROUTINE CheckOrtho_Basis
  SUBROUTINE Scale_Basis(Basis,x0,sx)
  USE UtilLib_m

    TYPE(Basis_t),       intent(inout)  :: Basis
    real(kind=Rk),       intent(in)     :: x0,sx

    IF (abs(sx) > ONETENTH**6 .AND. Basis_IS_allocated(Basis)) THEN

      Basis%x(:) = x0 + Basis%x(:) / sx
      Basis%w(:) =      Basis%w(:) / sx

      Basis%d0gb(:,:)     = Basis%d0gb(:,:)     * sqrt(sx)
      Basis%d1gb(:,:,:)   = Basis%d1gb(:,:,:)   * sqrt(sx)*sx
      Basis%d2gb(:,:,:,:) = Basis%d2gb(:,:,:,:) * sqrt(sx)*sx*sx
    ELSE
      write(out_unitp,*) ' ERROR in Scale_Basis'
      write(out_unitp,*) ' sx is too small  or ...'
      write(out_unitp,*) ' the basis is not allocated.'
      STOP 'ERROR in Scale_Basis'
    END IF

  END SUBROUTINE Scale_Basis

END MODULE Basis_m


! { dg-do run { target vect_simd_clones } }
! { dg-options "-O2" }
! { dg-additional-options "-msse2" { target sse2_runtime } }
! { dg-additional-options "-mavx" { target avx_runtime } }

module e_53_5_mod
  !$omp declare target (N, Q)
  integer, parameter :: N = 10000, M = 1024
  real :: Q(N,N)
contains
  real function Pfun (k, i)
    !$omp declare simd(Pfun) uniform(i) linear(k) notinbranch
    !$omp declare target
    integer, value, intent(in) :: i, k
    Pfun = (Q(k,i) * Q(i,k))
  end function
end module

real function accum () result (tmp)
  use e_53_5_mod
  real :: tmp1
  integer :: i
  tmp = 0.0e0
  !$omp target map(tofrom: tmp)
    !$omp parallel do private(tmp1) reduction(+:tmp)
    do i = 1, N
      tmp1 = 0.0e0
      !$omp simd reduction(+:tmp1)
      do k = 1, M
        tmp1 = tmp1 + Pfun (k, i)
      end do
      tmp = tmp + tmp1
    end do
  !$omp end target
end function

real function accum_ref () result (tmp)
  use e_53_5_mod
  real :: tmp1
  integer :: i
  tmp = 0.0e0
  do i = 1, N
    tmp1 = 0.0e0
    do k = 1, M
      tmp1 = tmp1 + Pfun (k, i)
    end do
    tmp = tmp + tmp1
  end do
end function

subroutine init ()
  use e_53_5_mod
  integer :: i, j
  do i = 1, N
    do j = 1, N
      Q(i,j) = 0.001 * i * j
    end do
  end do
end subroutine

subroutine check (a, b)
  real :: a, b, err
  real, parameter :: EPS = 0.00001
  if (b == 0.0) then
    err = a
  else if (a == 0.0) then
    err = b
  else
    err = (a - b) / b
  end if
  if (err > EPS .or. err < -EPS) call abort
end subroutine

program e_53_5
  use e_53_5_mod
  real :: accum, accum_ref, d
  call init ()
  !$omp target update to(Q)
  call check (accum (), accum_ref ())
end program


c
c     comment section.
c
c     fm020
c
c             this routine tests the fortran in-line statement function
c     of type logical and integer.  integer constants, logical constants
c     integer variables, logical variables, integer arithmetic express-
c     ions are all used to test the statement function definition and
c     the value returned for the statement function when it is used
c     in the main body of the program.
c
c      references
c        american national standard programming language fortran,
c              x3.9-1978
c
c        section 8.4.1, integer, real, double precision, complex, and
c                       logical type-statements
c        section 15.3.2, intrinsic function references
c        section 15.4, statement functions
c        section 15.4.1, forms of a function statement
c        section 15.4.2, referencing a statement function
c        section 15.5.2, external function references
c
      logical lftn01, ldtn01
      logical lftn02, ldtn02
      logical lftn03, ldtn03, lctn03
      logical lftn04, ldtn04, lctn04
      dimension iadn11(2)
c
c..... test 553
      ifon01(idon01) = 32767
c
c..... test 554
      lftn01(ldtn01) = .true.
c
c..... test 555
      ifon02 ( idon02 ) = idon02
c
c..... test 556
      lftn02( ldtn02 ) = ldtn02
c
c..... test 557
      ifon03 (idon03 )= idon03
c
c..... test 558
      lftn03(ldtn03) = ldtn03
c
c..... test 559
      lftn04(ldtn04) = .not. ldtn04
c
c..... test 560
      ifon04(idon04) = idon04 ** 2
c
c..... test 561
      ifon05(idon05, idon06) = idon05 + idon06
c
c..... test 562
      ifon06(idon07, idon08) = sqrt(float(idon07**2)+float(idon08**2))
c
c..... test 563
      ifon07(idon09) = idon09 ** 2
      ifon08(i,j)=sqrt(float(ifon07(i))+float(ifon07(j)))
c
c..... test 564
      ifon09(k,l) = k / l + k ** l - k * l
c
c
c
c      **********************************************************
c
c         a compiler validation system for the fortran language
c     based on specifications as defined in american national standard
c     programming language fortran x3.9-1978, has been developed by the
c     federal cobol compiler testing service.  the fortran compiler
c     validation system (fcvs) consists of audit routines, their related
c     data, and an executive system.  each audit routine is a fortran
c     program, subprogram or function which includes tests of specific
c     language elements and supporting procedures indicating the result
c     of executing these tests.
c
c         this particular program/subprogram/function contains features
c     found only in the subset as defined in x3.9-1978.
c
c         suggestions and comments should be forwarded to -
c
c                  department of the navy
c                  federal cobol compiler testing service
c                  washington, d.c.  20376
c
c      **********************************************************
c
c
c
c     initialization section
c
c     initialize constants
c      **************
c     i01 contains the logical unit number for the card reader.
      i01 = 5
c     i02 contains the logical unit number for the printer.
      i02 = 6
c     system environment section
c
cx010    this card is replaced by contents of fexec x-010 control card.
c     the cx010 card is for overriding the program default i01 = 5
c     (unit number for card reader).
cx011    this card is replaced by contents of fexec x-011 control card.
c     the cx011 card is for systems which require additional
c     fortran statements for files associated with cx010 above.
c
cx020    this card is replaced by contents of fexec x-020 control card.
c     the cx020 card is for overriding the program default i02 = 6
c     (unit number for printer).
cx021    this card is replaced by contents of fexec x-021 control card.
c     the cx021 card is for systems which require additional
c     fortran statements for files associated with cx020 above.
c
      ivpass=0
      ivfail=0
      ivdele=0
      iczero=0
c
c     write page headers
      write (i02,90000)
      write (i02,90001)
      write (i02,90002)
      write (i02, 90002)
      write (i02,90003)
      write (i02,90002)
      write (i02,90004)
      write (i02,90002)
      write (i02,90011)
      write (i02,90002)
      write (i02,90002)
      write (i02,90005)
      write (i02,90006)
      write (i02,90002)
      ivtnum = 553
c
c      ****  test 553  ****
c     test 553  -  the value of the integer function is set to a
c         constant of 32767 regardless of the value of the arguement
c     supplied to the dummy arguement.  test of positive integer
c     constants for a statement function.
c
c
      if (iczero) 35530, 5530, 35530
 5530 continue
      ivcomp = ifon01(3)
      go to 45530
35530 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45530, 5541, 45530
45530 if ( ivcomp - 32767 )  25530, 15530, 25530
15530 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5541
25530 ivfail = ivfail + 1
      ivcorr = 32767
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5541 continue
      ivtnum = 554
c
c      ****  test 554  ****
c     test 554  -  test of the statement function of type logical
c         set to the logical constant .true. regardless of the
c     arguement supplied to the dummy arguement.
c     a logical    if statement is used in conjunction with the logical
c     statement function.  the true path is tested.
c
c
      if (iczero) 35540, 5540, 35540
 5540 continue
      ivon01 = 0
      if ( lftn01(.false.) )  ivon01 = 1
      go to 45540
35540 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45540, 5551, 45540
45540 if ( ivon01 - 1 )  25540, 15540, 25540
15540 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5551
25540 ivfail = ivfail + 1
      ivcomp = ivon01
      ivcorr = 1
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5551 continue
      ivtnum = 555
c
c      ****  test 555  ****
c     test 555  -  the integer statement function is set to the value
c         of the argeument supplied.
c
c
      if (iczero) 35550, 5550, 35550
 5550 continue
      ivcomp = ifon02 ( 32767 )
      go to 45550
35550 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45550, 5561, 45550
45550 if ( ivcomp - 32767 )  25550, 15550, 25550
15550 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5561
25550 ivfail = ivfail + 1
      ivcorr = 32767
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5561 continue
      ivtnum = 556
c
c      ****  test 556  ****
c     test 556  -  test of a logical statement function set to the
c         value of the arguement supplied.  the false path of a logical
c            if statement is used in conjunction with the logical
c         statement function.
c
c
      if (iczero) 35560, 5560, 35560
 5560 continue
      ivon01 = 1
      if ( lftn02(.false.) )  ivon01 = 0
      go to 45560
35560 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45560, 5571, 45560
45560 if ( ivon01 - 1 )  25560, 15560, 25560
15560 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5571
25560 ivfail = ivfail + 1
      ivcomp = ivon01
      ivcorr = 1
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5571 continue
      ivtnum = 557
c
c      ****  test 557  ****
c     test 557  -  the value of an integer function is set equal to
c         value of the arguement supplied.  this value is an integer
c         variable set to 32767.
c
c
      if (iczero) 35570, 5570, 35570
 5570 continue
      icon01 = 32767
      ivcomp = ifon03 ( icon01 )
      go to 45570
35570 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45570, 5581, 45570
45570 if ( ivcomp - 32767 )  25570, 15570, 25570
15570 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5581
25570 ivfail = ivfail + 1
      ivcorr = 32767
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5581 continue
      ivtnum = 558
c
c      ****  test 558  ****
c     test 558 -  a logical statement function is set equal to the
c         value of the arguement supplied.  this value is a logical
c     variable set to .true.  the true path of a logical if
c         statement is used in conjunction with the logical statement
c         function.
c
c
      if (iczero) 35580, 5580, 35580
 5580 continue
      ivon01 = 0
      lctn03 = .true.
      if ( lftn03(lctn03) )  ivon01 = 1
      go to 45580
35580 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45580, 5591, 45580
45580 if ( ivon01 - 1 )  25580, 15580, 25580
15580 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5591
25580 ivfail = ivfail + 1
      ivcomp = ivon01
      ivcorr = 1
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5591 continue
      ivtnum = 559
c
c      ****  test 559  ****
c     test 559  -  like test 558 only the logical  .not.  is used
c         in the logical statement function definition  the false path
c         of a logical if statement is used in conjunction with the
c         logical statement function.
c
c
      if (iczero) 35590, 5590, 35590
 5590 continue
      ivon01 = 1
      lctn04 = .true.
      if ( lftn04(lctn04) )  ivon01 = 0
      go to 45590
35590 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45590, 5601, 45590
45590 if ( ivon01 - 1 )  25590, 15590, 25590
15590 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5601
25590 ivfail = ivfail + 1
      ivcomp = ivon01
      ivcorr = 1
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5601 continue
      ivtnum = 560
c
c      ****  test 560  ****
c     test 560  -  integer exponientiation used in an integer
c         statement function.
c
c
      if (iczero) 35600, 5600, 35600
 5600 continue
      icon04 = 3
      ivcomp = ifon04(icon04)
      go to 45600
35600 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45600, 5611, 45600
45600 if ( ivcomp - 9 )  25600, 15600, 25600
15600 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5611
25600 ivfail = ivfail + 1
      ivcorr = 9
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5611 continue
      ivtnum = 561
c
c      ****  test 561  ****
c     test 561  -  test of integer addition using two (2) dummy
c         arguements.
c
c
      if (iczero) 35610, 5610, 35610
 5610 continue
      icon05 = 9
      icon06 = 16
      ivcomp = ifon05(icon05, icon06)
      go to 45610
35610 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45610, 5621, 45610
45610 if ( ivcomp - 25 )  25610, 15610, 25610
15610 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5621
25610 ivfail = ivfail + 1
      ivcorr = 25
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5621 continue
      ivtnum = 562
c
c      ****  test 562  ****
c     test 562  -  this test is the solution of a right triangle
c         using integer statement functions which reference the
c         intrinsic functions  sqrt  and  float.  this is a 3-4-5
c         right triangle.
c
c
      if (iczero) 35620, 5620, 35620
 5620 continue
      icon07 = 3
      icon08 = 4
      ivcomp = ifon06(icon07, icon08)
      go to 45620
35620 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45620, 5631, 45620
45620 if ( ivcomp - 5 )  5622, 15620, 5622
 5622 if ( ivcomp - 4 ) 25620, 15620, 25620
15620 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5631
25620 ivfail = ivfail + 1
      ivcorr = 5
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5631 continue
      ivtnum = 563
c
c      ****  test 563  ****
c     test 563  -  solution of a 3-4-5 right triangle like test 562
c         except that both intrinsic and previously defined statement
c         functions are used.
c
c
      if (iczero) 35630, 5630, 35630
 5630 continue
      icon09 = 3
      icon10 = 4
      ivcomp = ifon08(icon09, icon10)
      go to 45630
35630 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45630, 5641, 45630
45630 if ( ivcomp - 5 )   5632, 15630, 5632
 5632 if ( ivcomp - 4 )  25630, 15630, 25630
15630 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5641
25630 ivfail = ivfail + 1
      ivcorr = 5
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5641 continue
      ivtnum = 564
c
c      ****  test 564  ****
c     test 564  -  use  of array elements in an integer statement
c         function which uses the operations of + - * /  .
c
c
      if (iczero) 35640, 5640, 35640
 5640 continue
      iadn11(1) = 2
      iadn11(2) = 2
      ivcomp = ifon09( iadn11(1), iadn11(2) )
      go to 45640
35640 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45640, 5651, 45640
45640 if ( ivcomp - 1 )  25640, 15640, 25640
15640 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5651
25640 ivfail = ivfail + 1
      ivcorr = 1
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5651 continue
c
c     write page footings and run summaries
99999 continue
      write (i02,90002)
      write (i02,90006)
      write (i02,90002)
      write (i02,90002)
      write (i02,90007)
      write (i02,90002)
      write (i02,90008)  ivfail
      write (i02,90009) ivpass
      write (i02,90010) ivdele
c
c
c     terminate routine execution
      stop
c
c     format statements for page headers
90000 format (1h1)
90002 format (1h )
90001 format (1h ,10x,34hfortran compiler validation system)
90003 format (1h ,21x,11hversion 1.0)
90004 format (1h ,10x,38hfor official use only - copyright 1978)
90005 format (1h ,5x,4htest,5x,9hpass/fail, 5x,8hcomputed,8x,7hcorrect)
90006 format (1h ,5x,46h----------------------------------------------)
90011 format (1h ,18x,17hsubset level test)
c
c     format statements for run summaries
90008 format (1h ,15x,i5,19h errors encountered)
90009 format (1h ,15x,i5,13h tests passed)
90010 format (1h ,15x,i5,14h tests deleted)
c
c     format statements for test results
80001 format (1h ,4x,i5,7x,4hpass)
80002 format (1h ,4x,i5,7x,4hfail)
80003 format (1h ,4x,i5,7x,7hdeleted)
80004 format (1h ,4x,i5,7x,4hfail,10x,i6,9x,i6)
80005 format (1h ,4x,i5,7x,4hfail,4x,e12.5,3x,e12.5)
c
90007 format (1h ,20x,20hend of program fm020)
      end


module stats_mod
    implicit none

    private

    type, public :: descriptive_stats_t
        private
        integer :: nr_values = 0
        real :: sum = 0.0, sum2 = 0.0
    contains
        procedure, public, pass :: add_value, get_nr_values, get_mean, get_stddev
    end type descriptive_stats_t

contains

    subroutine add_value(stats, new_value)
        implicit none
        class(descriptive_stats_t), intent(inout) :: stats
        real, value :: new_value

        stats%nr_values = stats%nr_values + 1
        stats%sum = stats%sum + new_value
        stats%sum2 = stats%sum2 + new_value**2
    end subroutine add_value

    function get_nr_values(stats) result(nr_values)
        implicit none
        class(descriptive_stats_t), intent(in) :: stats
        integer :: nr_values

        nr_values = stats%nr_values
    end function get_nr_values

    function get_mean(stats) result(mean_value)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        class(descriptive_stats_t), intent(in) :: stats
        real :: mean_value

        if (stats%nr_values == 0) then
            write (unit=error_unit, fmt='(A)') &
                'error: too few data value to compute mean'
            stop 1
        end if
        associate (n => stats%nr_values, sum => stats%sum)
            mean_value = sum/n
        end associate
    end function get_mean

    function get_stddev(stats) result(stddev_value)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        class(descriptive_stats_t), intent(in) :: stats
        real :: stddev_value

        if (stats%nr_values < 2) then
            write (unit=error_unit, fmt='(A)') &
                'error: too few data values to compute stddev'
            stop 2
        end if
        associate (n => stats%nr_values, sum => stats%sum, sum2 => stats%sum2)
            stddev_value = sqrt((sum2 - sum**2/n)/(n - 1.0))
        end associate
    end function get_stddev

end module stats_mod


! { dg-do run }
! PR fortran/28276
! Original code submitted by Harald Anlauf
! Converted to Dejagnu for the testsuite by Steven G. Kargl
!
program gfcbug36
  implicit none
  real, parameter :: one = 1.0
  real :: a = one

  if (fraction(a) /= 0.5) STOP 1
  if (fraction(one) /= 0.5) STOP 2
  if (fraction(1.0) /= 0.5) STOP 3

  if (exponent(a) /= 1.0) STOP 4
  if (exponent(one) /= 1.0) STOP 5
  if (exponent (1.0) /= 1.0) STOP 6

  if (scale(fraction(a),   exponent(a))   / a   /= 1.) STOP 7
  if (scale(fraction(one), exponent(one)) / one /= 1.) STOP 8
  if (scale(fraction(1.0), exponent(1.0)) / 1.0 /= 1.) STOP 9

end program gfcbug36


      SUBROUTINE CALBUOY
C
C CHANGE RECORD
C **  CALBUOY CALCULATES THE BUOYANCY USING MELLOR'S APPROXIMATION
C **  TO THE UNESCO EQUATION OF STATE (MELLOR, G.L., J. ATM AND OCEAN
C **  TECH, VOL 8, P 609)
C
      USE GLOBAL
	IMPLICIT NONE
	INTEGER::NS,K,L
	REAL::RHOO,SSTMP,RHTMP,PRES,CCON,TMP,TEM0
C
      IF(IBSC.EQ.1) GOTO 1000
      ISPCOR=0
C
C **  DENSITY RHOO AT P=0, S=0, AND T=TEMO
C
      TEM0 = ABS(TEMO)
      RHOO=999.842594+6.793952E-2*TEM0-9.095290E-3*TEM0*TEM0
     &    +1.001685E-4*TEM0*TEM0*TEM0-1.120083E-6*TEM0*TEM0*TEM0*TEM0
     &    +6.536332E-9*TEM0*TEM0*TEM0*TEM0*TEM0
      IF(ISTRAN(1).EQ.0.AND.ISTRAN(2).EQ.0)THEN
        DO K=1,KC
          DO L=2,LA
            B(L,K)=RHOO
          ENDDO
        ENDDO
      ENDIF
      IF(ISTRAN(1).GE.1.AND.ISTRAN(2).EQ.0)THEN
        DO K=1,KC
          DO L=2,LA
            SAL(L,K)=MAX(SAL(L,K),0.)
            SSTMP=SAL(L,K)
            TEM0=ABS(TEMO)
          B(L,K)=RHOO+SSTMP*(0.824493-4.0899E-3*TEM0+7.6438E-5*TEM0*TEM0
     &          -8.2467E-7*TEM0*TEM0*TEM0+5.3875E-9*TEM0*TEM0*TEM0*TEM0)
     &          +SQRT(SSTMP)*SSTMP*(-5.72466E-3+1.0227E-4*TEM0
     &          -1.6546E-6*TEM0*TEM0)+4.8314E-4*SSTMP*SSTMP
          ENDDO
        ENDDO
      ENDIF
      IF(ISTRAN(1).EQ.0.AND.ISTRAN(2).GE.1)THEN
        DO K=1,KC
          DO L=2,LA
            TTMP=TEM(L,K)
            B(L,K)=999.842594+6.793952E-2*TTMP-9.095290E-3*TTMP*TTMP
     &          +1.001685E-4*TTMP*TTMP*TTMP-1.120083E-6*TTMP*TTMP*
     &    TTMP*TTMP+6.536332E-9*TTMP*TTMP*TTMP*TTMP*TTMP
          ENDDO
        ENDDO
      ENDIF
      IF(ISTRAN(1).GE.1.AND.ISTRAN(2).GE.1)THEN
        DO K=1,KC
          DO L=2,LA
            SAL(L,K)=MAX(SAL(L,K),0.)
            SSTMP=SAL(L,K)
            TTMP=TEM(L,K)
            RHTMP=999.842594+6.793952E-2*TTMP-9.095290E-3*TTMP*TTMP
     &          +1.001685E-4*TTMP*TTMP*TTMP-1.120083E-6*TTMP*TTMP*
     &    TTMP*TTMP+6.536332E-9*TTMP*TTMP*TTMP*TTMP*TTMP
            B(L,K)=RHTMP+SSTMP*(0.824493-4.0899E-3*TTMP+7.6438E-5*
     & TTMP*TTMP-8.2467E-7*TTMP*TTMP*TTMP+5.3875E-9*TTMP*TTMP*TTMP*TTMP)
     &          +SQRT(SSTMP)*SSTMP*(-5.72466E-3+1.0227E-4*TTMP
     &          -1.6546E-6*TTMP*TTMP)+4.8314E-4*SSTMP*SSTMP
          ENDDO
        ENDDO
      ENDIF
C
C **  APPLY MELLOR'S PRESSURE CORRECTION
C
      IF(ISPCOR.EQ.1)THEN
        DO K=1,KC
          DO L=2,LA
            PRES=RHOO*G*HP(L)*(1.-ZZ(K))*1.E-6
            CCON=1449.2+1.34*(SAL(L,K)-35.)+4.55*TEM(L,K)
     &          -0.045*TEM(L,K)*TEM(L,K)+0.00821*PRES+15.E-9*PRES*PRES
            TMP=PRES/(CCON*CCON)
            B(L,K)=B(L,K)+1.E+4*TMP*(1.-0.2*TMP)
          ENDDO
        ENDDO
      ENDIF
C
C **  REPLACE DENSITY B(L,K) WITH BUOYANCY B(L,K)
C
      DO K=1,KC
        DO L=2,LA
          B(L,K)=(B(L,K)/RHOO)-1.
        ENDDO
      ENDDO
C
C **  APPLY LOW SEDIMENT CONCENTRATION CORRECTION TO BUOYANCY
C
      IF(ISTRAN(6).GE.1.OR.ISTRAN(7).GE.1)THEN
        DO K=1,KC
          DO L=2,LA
            TVAR1S(L,K)=0.
            TVAR1W(L,K)=0.
          ENDDO
        ENDDO
      ENDIF
      IF(ISTRAN(6).GE.1)THEN
        DO NS=1,NSED
          DO K=1,KC
            DO L=2,LA
              TVAR1S(L,K)=TVAR1S(L,K)+SDEN(NS)*SED(L,K,NS)
              TVAR1W(L,K)=TVAR1W(L,K)+(SSG(NS)-1.)*SDEN(NS)*SED(L,K,NS)
            ENDDO
          ENDDO
        ENDDO
      ENDIF
      IF(ISTRAN(7).GE.1)THEN
        DO NN=1,NSND
          NS=NN+NSED
          DO K=1,KC
            DO L=2,LA
              TVAR1S(L,K)=TVAR1S(L,K)+SDEN(NS)*SND(L,K,NN)
              TVAR1W(L,K)=TVAR1W(L,K)+(SSG(NS)-1.)*SDEN(NS)*SND(L,K,NN)
            ENDDO
          ENDDO
        ENDDO
      ENDIF
      IF(ISTRAN(6).GE.1.OR.ISTRAN(7).GE.1)THEN
        DO K=1,KC
          DO L=2,LA
            B(L,K)=B(L,K)*(1.-TVAR1S(L,K))+TVAR1W(L,K)
          ENDDO
        ENDDO
      ENDIF
      GOTO 2000
C
C     DENSITY AS A LINEAR FUNCTION OF SALINITY ONLY.  FOR DIAGNOSTIC
C     PURPOSES ONLY
C
 1000 CONTINUE
      DO K=1,KC
        DO L=2,LA
          B(L,K)=0.00075*SAL(L,K)
        ENDDO
      ENDDO
 2000 CONTINUE
      RETURN
      END