! MD5 of template: 874b367ed9a2602d10f066584f750d00
! Array related routines (Integration, Interpolation, etc.)
! Thomas Robitaille (c) 2009

module lib_array

  implicit none
  save

  private

  integer,parameter :: idp = selected_int_kind(13)
  integer,parameter :: sp = selected_real_kind(p=6,r=37)
  integer,parameter :: dp = selected_real_kind(p=15,r=307)
  integer,parameter :: qp = selected_real_kind(p=33,r=4931)

  public :: is_nan
  interface is_nan
     module procedure is_nan_int
     module procedure is_nan_int8
     module procedure is_nan_sp
     module procedure is_nan_dp
  end interface is_nan

  public :: linspace
  interface linspace
     module procedure linspace_sp
     module procedure linspace_dp
	module procedure linspace_qp
  end interface linspace

  public :: logspace
  interface logspace
     module procedure logspace_sp
     module procedure logspace_dp
  end interface logspace

  public :: integral
  interface integral
     module procedure integral_sp
     module procedure integral_dp
     module procedure integral_subset_sp
     module procedure integral_subset_dp
  end interface integral

  public :: integral_linlog
  interface integral_linlog
     module procedure integral_linlog_sp
     module procedure integral_linlog_dp
     module procedure integral_linlog_subset_sp
     module procedure integral_linlog_subset_dp
  end interface integral_linlog

  public :: integral_loglin
  interface integral_loglin
     module procedure integral_loglin_sp
     module procedure integral_loglin_dp
     module procedure integral_loglin_subset_sp
     module procedure integral_loglin_subset_dp
  end interface integral_loglin

  public :: integral_loglog
  interface integral_loglog
     module procedure integral_loglog_sp
     module procedure integral_loglog_dp
     module procedure integral_loglog_subset_sp
     module procedure integral_loglog_subset_dp
  end interface integral_loglog

  public :: locate
  interface locate
     module procedure locate_sp
     module procedure locate_dp
  end interface locate

  public :: interp1d
  interface interp1d
     module procedure interp1d_sp
     module procedure interp1d_dp
     module procedure interp1d_array_sp
     module procedure interp1d_array_dp
  end interface interp1d

  public :: interp1d_linlog
  interface interp1d_linlog
     module procedure interp1d_linlog_sp
     module procedure interp1d_linlog_dp
     module procedure interp1d_array_linlog_sp
     module procedure interp1d_array_linlog_dp
  end interface interp1d_linlog

  public :: interp1d_loglin
  interface interp1d_loglin
     module procedure interp1d_loglin_sp
     module procedure interp1d_loglin_dp
     module procedure interp1d_array_loglin_sp
     module procedure interp1d_array_loglin_dp
  end interface interp1d_loglin

  public :: interp1d_loglog
  interface interp1d_loglog
     module procedure interp1d_loglog_sp
     module procedure interp1d_loglog_dp
     module procedure interp1d_array_loglog_sp
     module procedure interp1d_array_loglog_dp
  end interface interp1d_loglog

  public :: rebin
  interface rebin
     module procedure rebin_sp
     module procedure rebin_dp
  end interface rebin

  public :: rebin_linlog
  interface rebin_linlog
     module procedure rebin_linlog_sp
     module procedure rebin_linlog_dp
  end interface rebin_linlog

  public :: rebin_loglin
  interface rebin_loglin
     module procedure rebin_loglin_sp
     module procedure rebin_loglin_dp
  end interface rebin_loglin

  public :: rebin_loglog
  interface rebin_loglog
     module procedure rebin_loglog_sp
     module procedure rebin_loglog_dp
  end interface rebin_loglog

  public :: interp2d
  interface interp2d
     module procedure interp2d_sp
     module procedure interp2d_dp
  end interface interp2d

  public :: histogram1d
  interface histogram1d
     module procedure histogram1d_sp
     module procedure histogram1d_dp
  end interface histogram1d

  public :: histogram2d
  interface histogram2d
     module procedure histogram2d_sp
     module procedure histogram2d_dp
  end interface histogram2d

  public :: ipos
  interface ipos
     module procedure ipos_sp
     module procedure ipos_dp
  end interface ipos

  public :: xval
  interface xval
     module procedure xval_sp
     module procedure xval_dp
  end interface xval

  public :: quicksort
  interface quicksort
     module procedure quicksort_sp
     module procedure quicksort_all_sp
     module procedure quicksort_dp
     module procedure quicksort_all_dp
  end interface quicksort

  public :: quicksort_index
  interface quicksort_index
     module procedure quicksort_index_sp
     module procedure quicksort_index_all_sp
     module procedure quicksort_index_dp
     module procedure quicksort_index_all_dp
  end interface quicksort_index

  public :: test_quicksort_sp
  public :: test_quicksort_dp

  public :: int
  interface int
     module procedure logical2int
  end interface int

contains

  elemental integer function logical2int(a) result(b)
    implicit none
    logical,intent(in) :: a
    if(a) then
       b = 1
    else
       b = 0
    end if
  end function logical2int

  logical elemental function is_nan_int8(value) result(nan)
    ! x != x does not work with pgfortran
    integer(idp),intent(in) :: value
    nan = .not. (value > -1 .or. value < 1)
  end function is_nan_int8

  logical elemental function is_nan_int(value) result(nan)
    ! x != x does not work with pgfortran
    integer,intent(in) :: value
    nan = .not. (value > -1 .or. value < 1)
  end function is_nan_int

  logical elemental function is_nan_dp(value) result(nan)
    ! x != x does not work with pgfortran
    real(dp),intent(in) :: value
    nan = .not. (value > -1 .or. value < 1)
  end function is_nan_dp

  logical elemental function is_nan_sp(value) result(nan)
    ! x != x does not work with pgfortran
    real(sp),intent(in) :: value
    nan = .not. (value > -1 .or. value < 1)
  end function is_nan_sp

  subroutine linspace_dp(xmin,xmax,x)
    implicit none
    real(dp),intent(in) :: xmin,xmax
    real(dp),intent(out) :: x(:)
    integer :: i,n
    n = size(x)
    if (n == 1) then
       if(xmin /= xmax) then
          write(0,'("ERROR: Cannot call linspace with n=1 and xmin /= xmax")')
          stop
       else
          x = xmin
       end if
    else
       do i=1,n
          x(i) = (xmax-xmin) * real(i-1,dp) / real(n-1,dp) + xmin
       end do
    end if
  end subroutine linspace_dp

  subroutine linspace_qp(xmin,xmax,x)
    implicit none
    real(qp),intent(in) :: xmin,xmax
    real(qp),intent(out) :: x(:)
    integer :: i,n
    n = size(x)
    if (n == 1) then
       if(xmin /= xmax) then
          write(0,'("ERROR: Cannot call linspace with n=1 and xmin /= xmax")')
          stop
       else
          x = xmin
       end if
    else
       do i=1,n
          x(i) = (xmax-xmin) * real(i-1,qp) / real(n-1,qp) + xmin
       end do
    end if
  end subroutine linspace_qp

  subroutine logspace_dp(xmin,xmax,x)
    implicit none
    real(dp),intent(in) :: xmin,xmax
    real(dp),intent(out) :: x(:)
    if (size(x) == 1 .and. xmin /= xmax) then
       write(0,'("ERROR: Cannot call logspace with n=1 and xmin /= xmax")')
       stop
    end if
    call linspace(log10(xmin),log10(xmax),x)
    x = 10._dp**x
  end subroutine logspace_dp

  real(dp) function integral_dp(x,y)
    ! Total integral of a function
    implicit none
    real(dp),intent(in) :: x(:),y(:)
    integral_dp = integral_general_dp(x, y, trapezium_dp)
  end function integral_dp

  real(dp) function integral_subset_dp(x,y,x1,x2)
    ! Integral of a function between two limits
    implicit none
    real(dp),intent(in) :: x(:),y(:),x1,x2
    integral_subset_dp = integral_general_subset_dp(x, y, x1, x2, interp1d_dp, trapezium_dp)
  end function integral_subset_dp

  real(dp) function integral_linlog_dp(x,y)
    ! Total integral of a function
    ! (uses linlog interpolation)
    implicit none
    real(dp),intent(in) :: x(:),y(:)
    integral_linlog_dp = integral_general_dp(x, y, trapezium_linlog_dp)
  end function integral_linlog_dp

  real(dp) function integral_linlog_subset_dp(x,y,x1,x2)
    ! Integral of a function between two limits
    ! (uses linlog interpolation)
    implicit none
    real(dp),intent(in) :: x(:),y(:),x1,x2
    integral_linlog_subset_dp = integral_general_subset_dp(x, y, x1, x2, interp1d_linlog_dp, trapezium_linlog_dp)
  end function integral_linlog_subset_dp

  real(dp) function integral_loglin_dp(x,y)
    ! Total integral of a function
    ! (uses loglin interpolation)
    implicit none
    real(dp),intent(in) :: x(:),y(:)
    integral_loglin_dp = integral_general_dp(x, y, trapezium_loglin_dp)
  end function integral_loglin_dp

  real(dp) function integral_loglin_subset_dp(x,y,x1,x2)
    ! Integral of a function between two limits
    ! (uses loglin interpolation)
    implicit none
    real(dp),intent(in) :: x(:),y(:),x1,x2
    integral_loglin_subset_dp = integral_general_subset_dp(x, y, x1, x2, interp1d_loglin_dp, trapezium_loglin_dp)
  end function integral_loglin_subset_dp

  real(dp) function integral_loglog_dp(x,y)
    ! Total integral of a function
    ! (uses log10 interpolation)
    implicit none
    real(dp),intent(in) :: x(:),y(:)
    integral_loglog_dp = integral_general_dp(x, y, trapezium_loglog_dp)
  end function integral_loglog_dp

  real(dp) function integral_loglog_subset_dp(x,y,x1,x2)
    ! Integral of a function between two limits
    ! (uses log10 interpolation)
    implicit none
    real(dp),intent(in) :: x(:),y(:),x1,x2
    integral_loglog_subset_dp = integral_general_subset_dp(x, y, x1, x2, interp1d_loglog_dp, trapezium_loglog_dp)
  end function integral_loglog_subset_dp

  real(dp) function integral_general_dp(x,y,f_chunk) result(sum)
    ! Total integral of a function
    implicit none
    real(dp),intent(in) :: x(:),y(:)
    integer :: j
    interface
       real(dp) function f_chunk(x1,y1,x2,y2)
         import :: dp
         implicit none
         real(dp),intent(in) :: x1,y1,x2,y2
       end function f_chunk
    end interface
    sum = 0._dp
    do j=1,size(x)-1
       sum=sum+f_chunk(x(j),y(j),x(j+1),y(j+1))
    end do
  end function integral_general_dp

  real(dp) function integral_general_subset_dp(x,y,x1,x2,f_interp,f_chunk) result(sum)
    ! Integral of a function between two limits

    implicit none

    real(dp),intent(in) :: x(:),y(:),x1,x2
    integer :: i1,i2
    real(dp) :: f1,f2
    integer :: n

    interface
       real(dp) function f_interp(x, y, xval,bounds_error,fill_value)
         import :: dp
         implicit none
         real(dp),dimension(:),intent(in) :: x,y
         real(dp),intent(in) :: xval
         logical,intent(in),optional :: bounds_error
         real(dp),intent(in),optional :: fill_value
       end function f_interp
       real(dp) function f_chunk(x1,y1,x2,y2)
         import :: dp
         implicit none
         real(dp),intent(in) :: x1,y1,x2,y2
       end function f_chunk
    end interface

    n = size(x)

    if(x1.gt.x(n).or.x2.lt.x(1)) then
       sum = 0._dp
       return
    end if

    if(x1.gt.x(1)) then
       i1 = locate(x,x1)
       f1 = f_interp(x,y,x1)
    else
       i1 = 0
       f1 = 0._dp
    end if

    if(x2.lt.x(n)) then
       i2 = locate(x,x2)
       f2 = f_interp(x,y,x2)
    else
       i2 = n
       f2 = 0._dp
    end if

    if(i2.gt.i1) then

       ! Add main part
       if(i2 > i1+1) then
          sum = integral_general_dp(x(i1+1:i2), y(i1+1:i2), f_chunk)
       else
          sum = 0._dp
       end if

       ! Add extremities
       sum = sum + f_chunk(x1,f1,x(i1+1),y(i1+1))
       sum = sum + f_chunk(x(i2),y(i2),x2,f2)

    else

       sum = f_chunk(x1,f1,x2,f2)

    end if

  end function integral_general_subset_dp

  real(dp) function trapezium_dp(x1,y1,x2,y2)
    implicit none
    real(dp),intent(in) :: x1,y1,x2,y2
    trapezium_dp = 0.5_dp*(y1+y2)*(x2-x1)
  end function trapezium_dp

  real(dp) function trapezium_loglin_dp(x1,y1,x2,y2)
    implicit none
    real(dp),intent(in) :: x1,y1,x2,y2
    real(dp) :: a,b
    if(x1==x2) then
       trapezium_loglin_dp = 0._dp
    else
       a = (y1-y2) / log10(x1/x2)
       b = y1 - a * log10(x1)
       trapezium_loglin_dp = a*(x2*log10(x2) - x1*log10(x1)) &
            &                     + (b-a/log(10._dp)) * (x2 - x1)
    end if
  end function trapezium_loglin_dp

  real(dp) function trapezium_linlog_dp(x1,y1,x2,y2)
    implicit none
    real(dp),intent(in) :: x1,y1,x2,y2
    real(dp) :: dx
    if(x1==x2) then
       trapezium_linlog_dp = 0._dp
    else if(y1==y2) then
       trapezium_linlog_dp = y1*(x2-x1)
    else
       dx = x2 - x1
       trapezium_linlog_dp = (y2-y1)*(x2-x1)/log(10._dp)/log10(y2/y1)
    end if
  end function trapezium_linlog_dp

  real(dp) function trapezium_loglog_dp(x1,y1,x2,y2)
    implicit none
    real(dp),intent(in) :: x1,y1,x2,y2
    real(dp) :: b
    if(x1==x2) then
       trapezium_loglog_dp = 0._dp
    else if(y1==0..or.y2==0.) then
       trapezium_loglog_dp = 0._dp
    else
       b = log10(y1/y2) / log10(x1/x2)
       if(abs(b+1._dp) < 1e-10) then
          trapezium_loglog_dp = x1 * y1 * log(x2/x1)
       else
          trapezium_loglog_dp = y1 * (x2*(x2/x1)**b-x1) / (b+1)
       end if
    end if
  end function trapezium_loglog_dp

  real(dp) function interp1d_single_dp(x1,y1,x2,y2,xval) result(yval)
    real(dp),intent(in) :: x1,y1,x2,y2,xval
    real(dp) :: frac
    frac = ( xval - x1 ) / ( x2 - x1 )
    yval = y1 + frac * ( y2 - y1 )
  end function interp1d_single_dp

  real(dp) function interp1d_single_linlog_dp(x1,y1,x2,y2,xval) result(yval)
    real(dp),intent(in) :: x1,y1,x2,y2,xval
    real(dp) :: frac
    if(y1==0..or.y2==0.) then
       yval = 0._dp
    else
       frac = ( xval - x1 ) / ( x2 - x1 )
       yval = 10._dp**(log10(y1) + frac * ( log10(y2) - log10(y1) ))
    end if
  end function interp1d_single_linlog_dp

  real(dp) function interp1d_single_loglin_dp(x1,y1,x2,y2,xval) result(yval)
    real(dp),intent(in) :: x1,y1,x2,y2,xval
    real(dp) :: frac
    frac = ( log10(xval) - log10(x1) ) / ( log10(x2) - log10(x1) )
    yval = y1 + frac * ( y2 - y1 )
  end function interp1d_single_loglin_dp

  real(dp) function interp1d_single_loglog_dp(x1,y1,x2,y2,xval) result(yval)
    real(dp),intent(in) :: x1,y1,x2,y2,xval
    real(dp) :: frac
    if(y1==0..or.y2==0.) then
       yval = 0._dp
    else
       frac = ( log10(xval) - log10(x1) ) / ( log10(x2) - log10(x1) )
       yval = 10._dp**(log10(y1) + frac * ( log10(y2) - log10(y1) ))
    end if
  end function interp1d_single_loglog_dp

  real(dp) function interp1d_dp(x,y,xval,bounds_error,fill_value) result(yval)
    implicit none
    real(dp),dimension(:),intent(in) :: x,y
    real(dp),intent(in) :: xval
    logical,intent(in),optional :: bounds_error
    real(dp),intent(in),optional :: fill_value
    yval = interp1d_general_dp(x,y,xval,interp1d_single_dp,bounds_error,fill_value)
  end function interp1d_dp

  function interp1d_array_dp(x,y,xval,bounds_error,fill_value)
    implicit none
    real(dp),intent(in) :: x(:),y(:)
    real(dp),intent(in) :: xval(:)
    logical,intent(in),optional :: bounds_error
    real(dp),intent(in),optional :: fill_value
    real(dp) :: interp1d_array_dp(size(xval))
    integer :: i
    do i=1,size(xval)
       interp1d_array_dp(i) = interp1d_dp(x,y,xval(i),bounds_error,fill_value)
    end do
  end function interp1d_array_dp

  real(dp) function interp1d_linlog_dp(x,y,xval,bounds_error,fill_value) result(yval)
    implicit none
    real(dp),dimension(:),intent(in) :: x,y
    real(dp),intent(in) :: xval
    logical,intent(in),optional :: bounds_error
    real(dp),intent(in),optional :: fill_value
    yval = interp1d_general_dp(x,y,xval,interp1d_single_linlog_dp,bounds_error,fill_value)
  end function interp1d_linlog_dp

  function interp1d_array_linlog_dp(x,y,xval,bounds_error,fill_value)
    implicit none
    real(dp),intent(in) :: x(:),y(:)
    real(dp),intent(in) :: xval(:)
    logical,intent(in),optional :: bounds_error
    real(dp),intent(in),optional :: fill_value
    real(dp) :: interp1d_array_linlog_dp(size(xval))
    integer :: i
    do i=1,size(xval)
       interp1d_array_linlog_dp(i) = interp1d_linlog_dp(x,y,xval(i),bounds_error,fill_value)
    end do
  end function interp1d_array_linlog_dp

  real(dp) function interp1d_loglin_dp(x,y,xval,bounds_error,fill_value) result(yval)
    implicit none
    real(dp),dimension(:),intent(in) :: x,y
    real(dp),intent(in) :: xval
    logical,intent(in),optional :: bounds_error
    real(dp),intent(in),optional :: fill_value
    yval = interp1d_general_dp(x,y,xval,interp1d_single_loglin_dp,bounds_error,fill_value)
  end function interp1d_loglin_dp

  function interp1d_array_loglin_dp(x,y,xval,bounds_error,fill_value)
    implicit none
    real(dp),intent(in) :: x(:),y(:)
    real(dp),intent(in) :: xval(:)
    logical,intent(in),optional :: bounds_error
    real(dp),intent(in),optional :: fill_value
    real(dp) :: interp1d_array_loglin_dp(size(xval))
    integer :: i
    do i=1,size(xval)
       interp1d_array_loglin_dp(i) = interp1d_loglin_dp(x,y,xval(i),bounds_error,fill_value)
    end do
  end function interp1d_array_loglin_dp

  real(dp) function interp1d_loglog_dp(x,y,xval,bounds_error,fill_value) result(yval)
    implicit none
    real(dp),dimension(:),intent(in) :: x,y
    real(dp),intent(in) :: xval
    logical,intent(in),optional :: bounds_error
    real(dp),intent(in),optional :: fill_value
    yval = interp1d_general_dp(x,y,xval,interp1d_single_loglog_dp,bounds_error,fill_value)
  end function interp1d_loglog_dp

  function interp1d_array_loglog_dp(x,y,xval,bounds_error,fill_value)
    implicit none
    real(dp),intent(in) :: x(:),y(:)
    real(dp),intent(in) :: xval(:)
    logical,intent(in),optional :: bounds_error
    real(dp),intent(in),optional :: fill_value
    real(dp) :: interp1d_array_loglog_dp(size(xval))
    integer :: i
    do i=1,size(xval)
       interp1d_array_loglog_dp(i) = interp1d_loglog_dp(x,y,xval(i),bounds_error,fill_value)
    end do
  end function interp1d_array_loglog_dp

  real(dp) function interp1d_general_dp(x,y,xval,f_single,bounds_error,fill_value) result(yval)

    implicit none

    integer :: n
    ! the size of the array

    real(dp),dimension(:),intent(in) :: x,y
    ! the x and y arrays

    real(dp),intent(in) :: xval
    ! the value at which to interpolate y

    interface
       real(dp) function f_single(x1,y1,x2,y2,xval)
         import :: dp
         implicit none
         real(dp),intent(in) :: x1,y1,x2,y2,xval
       end function f_single
    end interface

    logical,intent(in),optional :: bounds_error
    ! whether to raise an out of bounds error

    real(dp),intent(in),optional :: fill_value
    ! value for out of bounds if bounds_error is .false.

    integer :: ipos
    ! position of x value in x array

    logical :: bounds_error_tmp
    real(dp) :: fill_value_tmp

    if(present(bounds_error)) then
       bounds_error_tmp = bounds_error
    else
       bounds_error_tmp = .true.
    end if

    if(.not.bounds_error_tmp) then
       if(present(fill_value)) then
          fill_value_tmp = fill_value
       else
          fill_value_tmp = 0._dp
       end if
    end if

    n = size(x)

    ipos = locate(x,xval)

    ! --- First some error checking --- !

    if(ipos == -1) then
       if(bounds_error_tmp) then
          write(0,'("ERROR: Interpolation out of bounds : ",ES11.4," in [",ES11.4,":",ES11.4,"]")') xval,x(1),x(n)
          stop
       else
          yval = fill_value_tmp
          return
       end if
    end if

    if( ipos < n .and. ipos > 0) then
       yval = f_single(x(ipos), y(ipos), x(ipos+1), y(ipos+1), xval)
    else if(ipos == n) then
       yval = y(n)
    else if(ipos == 0) then
       yval = y(1)
    else
       write(0,'("ERROR: Unexpected value of ipos : ",I0)') ipos
       stop
    end if

  end function interp1d_general_dp

  function interp2d_dp(x,y,array,x0,y0,bounds_error,fill_value) result(value)
    ! Bilinar interpolation of array = f(x,y) at (x0,y0)

    implicit none

    real(dp),intent(in) :: x(:),y(:),array(:,:),x0,y0

    logical,intent(in),optional :: bounds_error
    ! whether to raise an out of bounds error

    real(dp),intent(in),optional :: fill_value
    ! value for out of bounds if bounds_error is .false.

    real(dp) :: value,norm
    integer :: i1,i2,j1,j2

    logical :: bounds_error_tmp
    real(dp) :: fill_value_tmp

    if(present(bounds_error)) then
       bounds_error_tmp = bounds_error
    else
       bounds_error_tmp = .true.
    end if

    if(.not.bounds_error_tmp) then
       if(present(fill_value)) then
          fill_value_tmp = fill_value
       else
          fill_value_tmp = 0._dp
       end if
    end if

    if(size(x).ne.size(array,1)) stop "x does not match array"
    if(size(y).ne.size(array,2)) stop "y does not match array"

    i1 = locate(x,x0) ; i2 = i1 + 1
    j1 = locate(y,y0) ; j2 = j1 + 1

    if(i1==-1) then
       if(bounds_error_tmp) then
          write(0,'("ERROR: Interpolation out of bounds : ",ES11.4," in [",ES11.4,":",ES11.4,"]")') x0,x(1),x(size(x))
          stop
       else
          value = fill_value_tmp
          return
       end if
    end if

    if(j1==-1) then
       if(bounds_error_tmp) then
          write(0,'("ERROR: Interpolation out of bounds : ",ES11.4," in [",ES11.4,":",ES11.4,"]")') y0,y(1),y(size(y))
          stop
       else
          value = fill_value_tmp
          return
       end if
    end if

    norm = 1._dp / (x(i2) - x(i1)) / (y(j2)-y(j1))

    value =   array(i1,j1) * (x(i2)-x0) * (y(j2)-y0) * norm &
         &       + array(i2,j1) * (x0-x(i1)) * (y(j2)-y0) * norm &
         &       + array(i1,j2) * (x(i2)-x0) * (y0-y(j1)) * norm &
         &       + array(i2,j2) * (x0-x(i1)) * (y0-y(j1)) * norm

  end function interp2d_dp

  real(dp) function average_lin_dp(a,b)
    implicit none
    real(dp),intent(in) :: a,b
    average_lin_dp = 0.5_dp * (a + b)
  end function average_lin_dp

  real(dp) function average_log_dp(a,b)
    implicit none
    real(dp),intent(in) :: a,b
    average_log_dp = sqrt(a*b)
  end function average_log_dp

  subroutine rebin_dp(x, y, xx, yy)
    real(dp),intent(in) :: x(:), y(:), xx(:)
    real(dp),intent(out) :: yy(:)
    call rebin_general_dp(x, y, xx, yy, average_lin_dp, integral_subset_dp)
  end subroutine rebin_dp

  subroutine rebin_linlog_dp(x, y, xx, yy)
    real(dp),intent(in) :: x(:), y(:), xx(:)
    real(dp),intent(out) :: yy(:)
    call rebin_general_dp(x, y, xx, yy, average_lin_dp, integral_linlog_subset_dp)
  end subroutine rebin_linlog_dp

  subroutine rebin_loglin_dp(x, y, xx, yy)
    real(dp),intent(in) :: x(:), y(:), xx(:)
    real(dp),intent(out) :: yy(:)
    call rebin_general_dp(x, y, xx, yy, average_log_dp, integral_loglin_subset_dp)
  end subroutine rebin_loglin_dp

  subroutine rebin_loglog_dp(x, y, xx, yy)
    real(dp),intent(in) :: x(:), y(:), xx(:)
    real(dp),intent(out) :: yy(:)
    call rebin_general_dp(x, y, xx, yy, average_log_dp, integral_loglog_subset_dp)
  end subroutine rebin_loglog_dp

  subroutine rebin_general_dp(x, y, xx, yy, f_average, f_integral)
    implicit none
    real(dp),intent(in) :: x(:), y(:), xx(:)
    real(dp),intent(out) :: yy(:)
    integer :: i
    real(dp) :: xmin, xmax
    interface
       real(dp) function f_average(a,b)
         import :: dp
         implicit none
         real(dp),intent(in) :: a,b
       end function f_average
       real(dp) function f_integral(x,y,x1,x2)
         import :: dp
         implicit none
         real(dp),intent(in) :: x(:),y(:),x1,x2
       end function f_integral
    end interface
    do i=1,size(xx)
       if(i==1) then
          xmin = xx(1)
       else
          xmin = f_average(xx(i-1), xx(i))
       end if
       if(i==size(xx)) then
          xmax = xx(size(xx))
       else
          xmax = f_average(xx(i), xx(i+1))
       end if
       yy(i) = f_integral(x, y, xmin, xmax) / (xmax - xmin)
    end do
  end subroutine rebin_general_dp

  integer function locate_dp(xx,x)
    ! Locate a value in a sorted array

    implicit none
    real(dp), dimension(:), intent(in) :: xx
    real(dp), intent(in) :: x
    integer :: n,jl,jm,ju
    logical :: ascnd
    n=size(xx)
    ascnd = (xx(n) >= xx(1))
    jl=0
    ju=n+1
    do
       if (ju-jl <= 1) exit
       jm=(ju+jl)/2
       if (ascnd .eqv. (x >= xx(jm))) then
          jl=jm
       else
          ju=jm
       end if
    end do

    if (x == xx(1)) then
       locate_dp = 1
    else if (x == xx(n)) then
       locate_dp = n-1
    else if(ascnd.and. (x > xx(n) .or. x < xx(1))) then
       locate_dp = -1
    else if(.not.ascnd.and. (x < xx(n) .or. x > xx(1))) then
       locate_dp = -1
    else
       locate_dp = jl
    end if

  end function locate_dp

  integer function ipos_dp(xmin,xmax,x,nbin)
    ! Find bin a value falls in for a regular histogram

    implicit none

    real(dp),intent(in) :: xmin,xmax
    ! range of values

    real(dp),intent(in) :: x
    ! the value to bin

    integer,intent(in) :: nbin
    ! number of bins

    real(dp) :: frac

    if(xmax > xmin) then

       if(x < xmin) then
          ipos_dp = 0
       else if(x > xmax) then
          ipos_dp = nbin+1
       else
          frac=(x-xmin)/(xmax-xmin)
          ipos_dp=int(frac*real(nbin))+1
       end if

    else

       if(x < xmax) then
          ipos_dp = 0
       else if(x > xmin) then
          ipos_dp = nbin+1
       else
          frac=(x-xmin)/(xmax-xmin)
          ipos_dp=int(frac*real(nbin))+1
       end if

    end if

  end function ipos_dp

  real(dp) function xval_dp(xmin,xmax,i,nbin)
    ! Find central value of a bin for a regular histogram

    implicit none

    real(dp),intent(in) :: xmin,xmax
    ! range of values

    integer,intent(in) :: i
    ! the bin number

    integer,intent(in) :: nbin
    ! number of bins

    real(dp) :: frac

    frac=(real(i-1)+0.5)/real(nbin)

    xval_dp=frac*(xmax-xmin)+xmin

  end function xval_dp

  subroutine histogram1d_dp(array,xmin,xmax,nbin,hist_x,hist_y,mask,weights)
    ! Bin 1D array of values into 1D regular histogram

    implicit none

    real(dp),dimension(:),intent(in) :: array
    real(dp),dimension(:),intent(in),optional :: weights
    ! the array of values to bin

    real(dp),intent(in) :: xmin,xmax
    ! the range of the histogram

    integer,intent(in) :: nbin
    ! number of bins

    real(dp),dimension(nbin),intent(out) :: hist_x,hist_y
    ! the histogram

    integer :: i,ibin
    ! binning variables

    logical,optional,intent(in) :: mask(:)
    logical,allocatable:: keep(:)

    allocate(keep(size(array)))

    if(present(mask)) then
       keep = mask
    else
       keep = .true.
    end if

    hist_x=0._dp ; hist_y=0._dp

    do i=1,size(array)
       if(keep(i)) then
          ibin=ipos(xmin,xmax,array(i),nbin)
          if(ibin.ge.1.and.ibin.le.nbin) then
             if(present(weights)) then
                hist_y(ibin)=hist_y(ibin)+weights(i)
             else
                hist_y(ibin)=hist_y(ibin)+1._dp
             end if
          end if
       end if
    end do

    do ibin=1,nbin
       hist_x(ibin)=xval(xmin,xmax,ibin,nbin)
    end do

    deallocate(keep)

  end subroutine histogram1d_dp

  subroutine histogram2d_dp(n,x,y,xmin,xmax,ymin,ymax,nx,ny,array,mask_in)
    ! Bin two 1D array of values into 2D regular grid

    implicit none

    integer,intent(in) :: n
    ! number of values to bin

    real(dp),dimension(n),intent(in) :: x,y
    logical,dimension(n),intent(in),optional :: mask_in
    ! the array of values to bin

    real(dp),intent(in) :: xmin,xmax,ymin,ymax
    ! the range of the histogram

    integer,intent(in) :: nx,ny
    ! number of bins

    real(dp),dimension(nx,ny),intent(out) :: array
    ! the histogram

    integer :: i,ix,iy
    ! binning variables

    logical,dimension(n) :: mask

    if(present(mask_in)) then
       mask = mask_in
    else
       mask = .true.
    end if

    array = 0._dp

    do i=1,n

       if(mask(i)) then

          ix=ipos(xmin,xmax,x(i),nx)
          iy=ipos(ymin,ymax,y(i),ny)

          if(ix.ge.1.and.ix.le.nx) then
             if(iy.ge.1.and.iy.le.ny) then
                array(ix,iy) = array(ix,iy) + 1.
             end if
          end if

       end if

    end do

  end subroutine histogram2d_dp

  subroutine swap_dp(array, i, j)
    implicit none
    real(dp),intent(inout) :: array(:)
    integer,intent(in) :: i, j
    real(dp) :: temp
    temp = array(j)
    array(j) = array(i)
    array(i) = temp
  end subroutine swap_dp

  subroutine partition_dp(array, left, right, pivot_index, store_index)
    implicit none
    real(dp),intent(inout) :: array(:)
    integer,intent(in) :: left, right, pivot_index
    integer,intent(out) :: store_index
    real(dp) :: pivot_value
    integer :: i
    pivot_value = array(pivot_index)
    call swap_dp(array, pivot_index, right)
    store_index = left
    do i=left, right-1
       if(array(i) <= pivot_value) then
          call swap_dp(array, i, store_index)
          store_index = store_index + 1
       end if
    end do
    call swap_dp(array, store_index, right)
  end subroutine partition_dp

  recursive subroutine quicksort_dp(array, left, right)
    implicit none
    real(dp),intent(inout) :: array(:)
    integer,intent(in) :: left, right
    integer :: pivot_index, new_pivot_index
    if(right > left) then
       pivot_index = left+(right-left)/2
       call partition_dp(array, left, right, pivot_index, new_pivot_index)
       call quicksort_dp(array, left, new_pivot_index - 1)
       call quicksort_dp(array, new_pivot_index + 1, right)
    end if
  end subroutine quicksort_dp

  recursive subroutine quicksort_all_dp(array)
    implicit none
    real(dp),intent(inout) :: array(:)
    call quicksort_dp(array, 1, size(array))
  end subroutine quicksort_all_dp

  subroutine swap_index_dp(array, index, i, j)
    implicit none
    real(dp),intent(inout) :: array(:)
    integer,intent(inout) :: index(:)
    integer,intent(in) :: i, j
    real(dp) :: temp
    integer :: temp_i
    temp = array(j)
    temp_i = index(j)
    array(j) = array(i)
    index(j) = index(i)
    array(i) = temp
    index(i) = temp_i
  end subroutine swap_index_dp

  subroutine partition_index_dp(array, index, left, right, pivot_index, store_index)
    implicit none
    real(dp),intent(inout) :: array(:)
    integer,intent(inout) :: index(:)
    integer,intent(in) :: left, right, pivot_index
    integer,intent(out) :: store_index
    real(dp) :: pivot_value
    integer :: i
    pivot_value = array(pivot_index)
    call swap_index_dp(array, index, pivot_index, right)
    store_index = left
    do i=left, right-1
       if(array(i) <= pivot_value) then
          call swap_index_dp(array, index, i, store_index)
          store_index = store_index + 1
       end if
    end do
    call swap_index_dp(array, index, store_index, right)
  end subroutine partition_index_dp

  recursive subroutine quicksort_index_dp(array, index, left, right)
    implicit none
    real(dp),intent(inout) :: array(:)
    integer,intent(inout) :: index(:)
    integer,intent(in) :: left, right
    integer :: pivot_index, new_pivot_index
    if(right > left) then
       pivot_index = left+(right-left)/2
       call partition_index_dp(array, index, left, right, pivot_index, new_pivot_index)
       call quicksort_index_dp(array, index, left, new_pivot_index - 1)
       call quicksort_index_dp(array, index, new_pivot_index + 1, right)
    end if
  end subroutine quicksort_index_dp

  recursive subroutine quicksort_index_all_dp(array, index)
    implicit none
    real(dp),intent(inout) :: array(:)
    integer,intent(inout) :: index(:)
    call quicksort_index_dp(array, index, 1, size(array))
  end subroutine quicksort_index_all_dp

  subroutine check_sort_dp(array)
    implicit none
    real(dp),intent(inout) :: array(:)
    integer :: j
    do j=1,size(array)-1
       if(array(j+1) < array(j)) stop "Incorrectly sorted array"
    end do
  end subroutine check_sort_dp

  subroutine test_quicksort_dp()

    implicit none

    real(dp),allocatable :: array1(:), array2(:)
    integer,allocatable :: index(:)
    integer :: j,i

    write(*,'(" Testing quicksort")')

    do j=1,20

       write(*,'("  - n=",I0)') 2**j

       allocate(array1(2**j))

       call random_number(array1)

       call quicksort(array1)

       call check_sort_dp(array1)

       deallocate(array1)

    end do

    write(*,'(" Testing quicksort_index")')

    do j=1,20

       write(*,'("  - n=",I0)') 2**j

       allocate(array1(2**j), array2(2**j), index(2**j))

       call random_number(array1)
       array2 = array1
       forall(i=1:2**j) index(i) = i

       call quicksort_index(array1, index)

       call check_sort_dp(array1)

       if(any(array2(index).ne.array1)) stop "Failure in quicksort_index"

       deallocate(array1, array2, index)

    end do

  end subroutine test_quicksort_dp

  subroutine linspace_sp(xmin,xmax,x)
    implicit none
    real(sp),intent(in) :: xmin,xmax
    real(sp),intent(out) :: x(:)
    integer :: i,n
    n = size(x)
    if (n == 1) then
       if(xmin /= xmax) then
          write(0,'("ERROR: Cannot call linspace with n=1 and xmin /= xmax")')
          stop
       else
          x = xmin
       end if
    else
       do i=1,n
          x(i) = (xmax-xmin) * real(i-1,sp) / real(n-1,sp) + xmin
       end do
    end if
  end subroutine linspace_sp

  subroutine logspace_sp(xmin,xmax,x)
    implicit none
    real(sp),intent(in) :: xmin,xmax
    real(sp),intent(out) :: x(:)
    if (size(x) == 1 .and. xmin /= xmax) then
       write(0,'("ERROR: Cannot call logspace with n=1 and xmin /= xmax")')
       stop
    end if
    call linspace(log10(xmin),log10(xmax),x)
    x = 10._sp**x
  end subroutine logspace_sp

  real(sp) function integral_sp(x,y)
    ! Total integral of a function
    implicit none
    real(sp),intent(in) :: x(:),y(:)
    integral_sp = integral_general_sp(x, y, trapezium_sp)
  end function integral_sp

  real(sp) function integral_subset_sp(x,y,x1,x2)
    ! Integral of a function between two limits
    implicit none
    real(sp),intent(in) :: x(:),y(:),x1,x2
    integral_subset_sp = integral_general_subset_sp(x, y, x1, x2, interp1d_sp, trapezium_sp)
  end function integral_subset_sp

  real(sp) function integral_linlog_sp(x,y)
    ! Total integral of a function
    ! (uses linlog interpolation)
    implicit none
    real(sp),intent(in) :: x(:),y(:)
    integral_linlog_sp = integral_general_sp(x, y, trapezium_linlog_sp)
  end function integral_linlog_sp

  real(sp) function integral_linlog_subset_sp(x,y,x1,x2)
    ! Integral of a function between two limits
    ! (uses linlog interpolation)
    implicit none
    real(sp),intent(in) :: x(:),y(:),x1,x2
    integral_linlog_subset_sp = integral_general_subset_sp(x, y, x1, x2, interp1d_linlog_sp, trapezium_linlog_sp)
  end function integral_linlog_subset_sp

  real(sp) function integral_loglin_sp(x,y)
    ! Total integral of a function
    ! (uses loglin interpolation)
    implicit none
    real(sp),intent(in) :: x(:),y(:)
    integral_loglin_sp = integral_general_sp(x, y, trapezium_loglin_sp)
  end function integral_loglin_sp

  real(sp) function integral_loglin_subset_sp(x,y,x1,x2)
    ! Integral of a function between two limits
    ! (uses loglin interpolation)
    implicit none
    real(sp),intent(in) :: x(:),y(:),x1,x2
    integral_loglin_subset_sp = integral_general_subset_sp(x, y, x1, x2, interp1d_loglin_sp, trapezium_loglin_sp)
  end function integral_loglin_subset_sp

  real(sp) function integral_loglog_sp(x,y)
    ! Total integral of a function
    ! (uses log10 interpolation)
    implicit none
    real(sp),intent(in) :: x(:),y(:)
    integral_loglog_sp = integral_general_sp(x, y, trapezium_loglog_sp)
  end function integral_loglog_sp

  real(sp) function integral_loglog_subset_sp(x,y,x1,x2)
    ! Integral of a function between two limits
    ! (uses log10 interpolation)
    implicit none
    real(sp),intent(in) :: x(:),y(:),x1,x2
    integral_loglog_subset_sp = integral_general_subset_sp(x, y, x1, x2, interp1d_loglog_sp, trapezium_loglog_sp)
  end function integral_loglog_subset_sp

  real(sp) function integral_general_sp(x,y,f_chunk) result(sum)
    ! Total integral of a function
    implicit none
    real(sp),intent(in) :: x(:),y(:)
    integer :: j
    interface
       real(sp) function f_chunk(x1,y1,x2,y2)
         import :: sp
         implicit none
         real(sp),intent(in) :: x1,y1,x2,y2
       end function f_chunk
    end interface
    sum = 0._sp
    do j=1,size(x)-1
       sum=sum+f_chunk(x(j),y(j),x(j+1),y(j+1))
    end do
  end function integral_general_sp

  real(sp) function integral_general_subset_sp(x,y,x1,x2,f_interp,f_chunk) result(sum)
    ! Integral of a function between two limits

    implicit none

    real(sp),intent(in) :: x(:),y(:),x1,x2
    integer :: i1,i2
    real(sp) :: f1,f2
    integer :: n

    interface
       real(sp) function f_interp(x, y, xval,bounds_error,fill_value)
         import :: sp
         implicit none
         real(sp),dimension(:),intent(in) :: x,y
         real(sp),intent(in) :: xval
         logical,intent(in),optional :: bounds_error
         real(sp),intent(in),optional :: fill_value
       end function f_interp
       real(sp) function f_chunk(x1,y1,x2,y2)
         import :: sp
         implicit none
         real(sp),intent(in) :: x1,y1,x2,y2
       end function f_chunk
    end interface

    n = size(x)

    if(x1.gt.x(n).or.x2.lt.x(1)) then
       sum = 0._sp
       return
    end if

    if(x1.gt.x(1)) then
       i1 = locate(x,x1)
       f1 = f_interp(x,y,x1)
    else
       i1 = 0
       f1 = 0._sp
    end if

    if(x2.lt.x(n)) then
       i2 = locate(x,x2)
       f2 = f_interp(x,y,x2)
    else
       i2 = n
       f2 = 0._sp
    end if

    if(i2.gt.i1) then

       ! Add main part
       if(i2 > i1+1) then
          sum = integral_general_sp(x(i1+1:i2), y(i1+1:i2), f_chunk)
       else
          sum = 0._sp
       end if

       ! Add extremities
       sum = sum + f_chunk(x1,f1,x(i1+1),y(i1+1))
       sum = sum + f_chunk(x(i2),y(i2),x2,f2)

    else

       sum = f_chunk(x1,f1,x2,f2)

    end if

  end function integral_general_subset_sp

  real(sp) function trapezium_sp(x1,y1,x2,y2)
    implicit none
    real(sp),intent(in) :: x1,y1,x2,y2
    trapezium_sp = 0.5_sp*(y1+y2)*(x2-x1)
  end function trapezium_sp

  real(sp) function trapezium_loglin_sp(x1,y1,x2,y2)
    implicit none
    real(sp),intent(in) :: x1,y1,x2,y2
    real(sp) :: a,b
    if(x1==x2) then
       trapezium_loglin_sp = 0._sp
    else
       a = (y1-y2) / log10(x1/x2)
       b = y1 - a * log10(x1)
       trapezium_loglin_sp = a*(x2*log10(x2) - x1*log10(x1)) &
            &                     + (b-a/log(10._sp)) * (x2 - x1)
    end if
  end function trapezium_loglin_sp

  real(sp) function trapezium_linlog_sp(x1,y1,x2,y2)
    implicit none
    real(sp),intent(in) :: x1,y1,x2,y2
    real(sp) :: dx
    if(x1==x2) then
       trapezium_linlog_sp = 0._sp
    else if(y1==y2) then
       trapezium_linlog_sp = y1*(x2-x1)
    else
       dx = x2 - x1
       trapezium_linlog_sp = (y2-y1)*(x2-x1)/log(10._sp)/log10(y2/y1)
    end if
  end function trapezium_linlog_sp

  real(sp) function trapezium_loglog_sp(x1,y1,x2,y2)
    implicit none
    real(sp),intent(in) :: x1,y1,x2,y2
    real(sp) :: b
    if(x1==x2) then
       trapezium_loglog_sp = 0._sp
    else if(y1==0..or.y2==0.) then
       trapezium_loglog_sp = 0._sp
    else
       b = log10(y1/y2) / log10(x1/x2)
       if(abs(b+1._dp) < 1e-10) then
          trapezium_loglog_sp = x1 * y1 * log(x2/x1)
       else
          trapezium_loglog_sp = y1 * (x2*(x2/x1)**b-x1) / (b+1)
       end if
    end if
  end function trapezium_loglog_sp

  real(sp) function interp1d_single_sp(x1,y1,x2,y2,xval) result(yval)
    real(sp),intent(in) :: x1,y1,x2,y2,xval
    real(sp) :: frac
    frac = ( xval - x1 ) / ( x2 - x1 )
    yval = y1 + frac * ( y2 - y1 )
  end function interp1d_single_sp

  real(sp) function interp1d_single_linlog_sp(x1,y1,x2,y2,xval) result(yval)
    real(sp),intent(in) :: x1,y1,x2,y2,xval
    real(sp) :: frac
    if(y1==0..or.y2==0.) then
       yval = 0._sp
    else
       frac = ( xval - x1 ) / ( x2 - x1 )
       yval = 10._sp**(log10(y1) + frac * ( log10(y2) - log10(y1) ))
    end if
  end function interp1d_single_linlog_sp

  real(sp) function interp1d_single_loglin_sp(x1,y1,x2,y2,xval) result(yval)
    real(sp),intent(in) :: x1,y1,x2,y2,xval
    real(sp) :: frac
    frac = ( log10(xval) - log10(x1) ) / ( log10(x2) - log10(x1) )
    yval = y1 + frac * ( y2 - y1 )
  end function interp1d_single_loglin_sp

  real(sp) function interp1d_single_loglog_sp(x1,y1,x2,y2,xval) result(yval)
    real(sp),intent(in) :: x1,y1,x2,y2,xval
    real(sp) :: frac
    if(y1==0..or.y2==0.) then
       yval = 0._sp
    else
       frac = ( log10(xval) - log10(x1) ) / ( log10(x2) - log10(x1) )
       yval = 10._sp**(log10(y1) + frac * ( log10(y2) - log10(y1) ))
    end if
  end function interp1d_single_loglog_sp

  real(sp) function interp1d_sp(x,y,xval,bounds_error,fill_value) result(yval)
    implicit none
    real(sp),dimension(:),intent(in) :: x,y
    real(sp),intent(in) :: xval
    logical,intent(in),optional :: bounds_error
    real(sp),intent(in),optional :: fill_value
    yval = interp1d_general_sp(x,y,xval,interp1d_single_sp,bounds_error,fill_value)
  end function interp1d_sp

  function interp1d_array_sp(x,y,xval,bounds_error,fill_value)
    implicit none
    real(sp),intent(in) :: x(:),y(:)
    real(sp),intent(in) :: xval(:)
    logical,intent(in),optional :: bounds_error
    real(sp),intent(in),optional :: fill_value
    real(sp) :: interp1d_array_sp(size(xval))
    integer :: i
    do i=1,size(xval)
       interp1d_array_sp(i) = interp1d_sp(x,y,xval(i),bounds_error,fill_value)
    end do
  end function interp1d_array_sp

  real(sp) function interp1d_linlog_sp(x,y,xval,bounds_error,fill_value) result(yval)
    implicit none
    real(sp),dimension(:),intent(in) :: x,y
    real(sp),intent(in) :: xval
    logical,intent(in),optional :: bounds_error
    real(sp),intent(in),optional :: fill_value
    yval = interp1d_general_sp(x,y,xval,interp1d_single_linlog_sp,bounds_error,fill_value)
  end function interp1d_linlog_sp

  function interp1d_array_linlog_sp(x,y,xval,bounds_error,fill_value)
    implicit none
    real(sp),intent(in) :: x(:),y(:)
    real(sp),intent(in) :: xval(:)
    logical,intent(in),optional :: bounds_error
    real(sp),intent(in),optional :: fill_value
    real(sp) :: interp1d_array_linlog_sp(size(xval))
    integer :: i
    do i=1,size(xval)
       interp1d_array_linlog_sp(i) = interp1d_linlog_sp(x,y,xval(i),bounds_error,fill_value)
    end do
  end function interp1d_array_linlog_sp

  real(sp) function interp1d_loglin_sp(x,y,xval,bounds_error,fill_value) result(yval)
    implicit none
    real(sp),dimension(:),intent(in) :: x,y
    real(sp),intent(in) :: xval
    logical,intent(in),optional :: bounds_error
    real(sp),intent(in),optional :: fill_value
    yval = interp1d_general_sp(x,y,xval,interp1d_single_loglin_sp,bounds_error,fill_value)
  end function interp1d_loglin_sp

  function interp1d_array_loglin_sp(x,y,xval,bounds_error,fill_value)
    implicit none
    real(sp),intent(in) :: x(:),y(:)
    real(sp),intent(in) :: xval(:)
    logical,intent(in),optional :: bounds_error
    real(sp),intent(in),optional :: fill_value
    real(sp) :: interp1d_array_loglin_sp(size(xval))
    integer :: i
    do i=1,size(xval)
       interp1d_array_loglin_sp(i) = interp1d_loglin_sp(x,y,xval(i),bounds_error,fill_value)
    end do
  end function interp1d_array_loglin_sp

  real(sp) function interp1d_loglog_sp(x,y,xval,bounds_error,fill_value) result(yval)
    implicit none
    real(sp),dimension(:),intent(in) :: x,y
    real(sp),intent(in) :: xval
    logical,intent(in),optional :: bounds_error
    real(sp),intent(in),optional :: fill_value
    yval = interp1d_general_sp(x,y,xval,interp1d_single_loglog_sp,bounds_error,fill_value)
  end function interp1d_loglog_sp

  function interp1d_array_loglog_sp(x,y,xval,bounds_error,fill_value)
    implicit none
    real(sp),intent(in) :: x(:),y(:)
    real(sp),intent(in) :: xval(:)
    logical,intent(in),optional :: bounds_error
    real(sp),intent(in),optional :: fill_value
    real(sp) :: interp1d_array_loglog_sp(size(xval))
    integer :: i
    do i=1,size(xval)
       interp1d_array_loglog_sp(i) = interp1d_loglog_sp(x,y,xval(i),bounds_error,fill_value)
    end do
  end function interp1d_array_loglog_sp

  real(sp) function interp1d_general_sp(x,y,xval,f_single,bounds_error,fill_value) result(yval)

    implicit none

    integer :: n
    ! the size of the array

    real(sp),dimension(:),intent(in) :: x,y
    ! the x and y arrays

    real(sp),intent(in) :: xval
    ! the value at which to interpolate y

    interface
       real(sp) function f_single(x1,y1,x2,y2,xval)
         import :: sp
         implicit none
         real(sp),intent(in) :: x1,y1,x2,y2,xval
       end function f_single
    end interface

    logical,intent(in),optional :: bounds_error
    ! whether to raise an out of bounds error

    real(sp),intent(in),optional :: fill_value
    ! value for out of bounds if bounds_error is .false.

    integer :: ipos
    ! position of x value in x array

    logical :: bounds_error_tmp
    real(sp) :: fill_value_tmp

    if(present(bounds_error)) then
       bounds_error_tmp = bounds_error
    else
       bounds_error_tmp = .true.
    end if

    if(.not.bounds_error_tmp) then
       if(present(fill_value)) then
          fill_value_tmp = fill_value
       else
          fill_value_tmp = 0._sp
       end if
    end if

    n = size(x)

    ipos = locate(x,xval)

    ! --- First some error checking --- !

    if(ipos == -1) then
       if(bounds_error_tmp) then
          write(0,'("ERROR: Interpolation out of bounds : ",ES11.4," in [",ES11.4,":",ES11.4,"]")') xval,x(1),x(n)
          stop
       else
          yval = fill_value_tmp
          return
       end if
    end if

    if( ipos < n .and. ipos > 0) then
       yval = f_single(x(ipos), y(ipos), x(ipos+1), y(ipos+1), xval)
    else if(ipos == n) then
       yval = y(n)
    else if(ipos == 0) then
       yval = y(1)
    else
       write(0,'("ERROR: Unexpected value of ipos : ",I0)') ipos
       stop
    end if

  end function interp1d_general_sp

  function interp2d_sp(x,y,array,x0,y0,bounds_error,fill_value) result(value)
    ! Bilinar interpolation of array = f(x,y) at (x0,y0)

    implicit none

    real(sp),intent(in) :: x(:),y(:),array(:,:),x0,y0

    logical,intent(in),optional :: bounds_error
    ! whether to raise an out of bounds error

    real(sp),intent(in),optional :: fill_value
    ! value for out of bounds if bounds_error is .false.

    real(sp) :: value,norm
    integer :: i1,i2,j1,j2

    logical :: bounds_error_tmp
    real(sp) :: fill_value_tmp

    if(present(bounds_error)) then
       bounds_error_tmp = bounds_error
    else
       bounds_error_tmp = .true.
    end if

    if(.not.bounds_error_tmp) then
       if(present(fill_value)) then
          fill_value_tmp = fill_value
       else
          fill_value_tmp = 0._sp
       end if
    end if

    if(size(x).ne.size(array,1)) stop "x does not match array"
    if(size(y).ne.size(array,2)) stop "y does not match array"

    i1 = locate(x,x0) ; i2 = i1 + 1
    j1 = locate(y,y0) ; j2 = j1 + 1

    if(i1==-1) then
       if(bounds_error_tmp) then
          write(0,'("ERROR: Interpolation out of bounds : ",ES11.4," in [",ES11.4,":",ES11.4,"]")') x0,x(1),x(size(x))
          stop
       else
          value = fill_value_tmp
          return
       end if
    end if

    if(j1==-1) then
       if(bounds_error_tmp) then
          write(0,'("ERROR: Interpolation out of bounds : ",ES11.4," in [",ES11.4,":",ES11.4,"]")') y0,y(1),y(size(y))
          stop
       else
          value = fill_value_tmp
          return
       end if
    end if

    norm = 1._sp / (x(i2) - x(i1)) / (y(j2)-y(j1))

    value =   array(i1,j1) * (x(i2)-x0) * (y(j2)-y0) * norm &
         &       + array(i2,j1) * (x0-x(i1)) * (y(j2)-y0) * norm &
         &       + array(i1,j2) * (x(i2)-x0) * (y0-y(j1)) * norm &
         &       + array(i2,j2) * (x0-x(i1)) * (y0-y(j1)) * norm

  end function interp2d_sp

  real(sp) function average_lin_sp(a,b)
    implicit none
    real(sp),intent(in) :: a,b
    average_lin_sp = 0.5_sp * (a + b)
  end function average_lin_sp

  real(sp) function average_log_sp(a,b)
    implicit none
    real(sp),intent(in) :: a,b
    average_log_sp = sqrt(a*b)
  end function average_log_sp

  subroutine rebin_sp(x, y, xx, yy)
    real(sp),intent(in) :: x(:), y(:), xx(:)
    real(sp),intent(out) :: yy(:)
    call rebin_general_sp(x, y, xx, yy, average_lin_sp, integral_subset_sp)
  end subroutine rebin_sp

  subroutine rebin_linlog_sp(x, y, xx, yy)
    real(sp),intent(in) :: x(:), y(:), xx(:)
    real(sp),intent(out) :: yy(:)
    call rebin_general_sp(x, y, xx, yy, average_lin_sp, integral_linlog_subset_sp)
  end subroutine rebin_linlog_sp

  subroutine rebin_loglin_sp(x, y, xx, yy)
    real(sp),intent(in) :: x(:), y(:), xx(:)
    real(sp),intent(out) :: yy(:)
    call rebin_general_sp(x, y, xx, yy, average_log_sp, integral_loglin_subset_sp)
  end subroutine rebin_loglin_sp

  subroutine rebin_loglog_sp(x, y, xx, yy)
    real(sp),intent(in) :: x(:), y(:), xx(:)
    real(sp),intent(out) :: yy(:)
    call rebin_general_sp(x, y, xx, yy, average_log_sp, integral_loglog_subset_sp)
  end subroutine rebin_loglog_sp

  subroutine rebin_general_sp(x, y, xx, yy, f_average, f_integral)
    implicit none
    real(sp),intent(in) :: x(:), y(:), xx(:)
    real(sp),intent(out) :: yy(:)
    integer :: i
    real(sp) :: xmin, xmax
    interface
       real(sp) function f_average(a,b)
         import :: sp
         implicit none
         real(sp),intent(in) :: a,b
       end function f_average
       real(sp) function f_integral(x,y,x1,x2)
         import :: sp
         implicit none
         real(sp),intent(in) :: x(:),y(:),x1,x2
       end function f_integral
    end interface
    do i=1,size(xx)
       if(i==1) then
          xmin = xx(1)
       else
          xmin = f_average(xx(i-1), xx(i))
       end if
       if(i==size(xx)) then
          xmax = xx(size(xx))
       else
          xmax = f_average(xx(i), xx(i+1))
       end if
       yy(i) = f_integral(x, y, xmin, xmax) / (xmax - xmin)
    end do
  end subroutine rebin_general_sp

  integer function locate_sp(xx,x)
    ! Locate a value in a sorted array

    implicit none
    real(sp), dimension(:), intent(in) :: xx
    real(sp), intent(in) :: x
    integer :: n,jl,jm,ju
    logical :: ascnd
    n=size(xx)
    ascnd = (xx(n) >= xx(1))
    jl=0
    ju=n+1
    do
       if (ju-jl <= 1) exit
       jm=(ju+jl)/2
       if (ascnd .eqv. (x >= xx(jm))) then
          jl=jm
       else
          ju=jm
       end if
    end do

    if (x == xx(1)) then
       locate_sp = 1
    else if (x == xx(n)) then
       locate_sp = n-1
    else if(ascnd.and. (x > xx(n) .or. x < xx(1))) then
       locate_sp = -1
    else if(.not.ascnd.and. (x < xx(n) .or. x > xx(1))) then
       locate_sp = -1
    else
       locate_sp = jl
    end if

  end function locate_sp

  integer function ipos_sp(xmin,xmax,x,nbin)
    ! Find bin a value falls in for a regular histogram

    implicit none

    real(sp),intent(in) :: xmin,xmax
    ! range of values

    real(sp),intent(in) :: x
    ! the value to bin

    integer,intent(in) :: nbin
    ! number of bins

    real(sp) :: frac

    if(xmax > xmin) then

       if(x < xmin) then
          ipos_sp = 0
       else if(x > xmax) then
          ipos_sp = nbin+1
       else
          frac=(x-xmin)/(xmax-xmin)
          ipos_sp=int(frac*real(nbin))+1
       end if

    else

       if(x < xmax) then
          ipos_sp = 0
       else if(x > xmin) then
          ipos_sp = nbin+1
       else
          frac=(x-xmin)/(xmax-xmin)
          ipos_sp=int(frac*real(nbin))+1
       end if

    end if

  end function ipos_sp

  real(sp) function xval_sp(xmin,xmax,i,nbin)
    ! Find central value of a bin for a regular histogram

    implicit none

    real(sp),intent(in) :: xmin,xmax
    ! range of values

    integer,intent(in) :: i
    ! the bin number

    integer,intent(in) :: nbin
    ! number of bins

    real(sp) :: frac

    frac=(real(i-1)+0.5)/real(nbin)

    xval_sp=frac*(xmax-xmin)+xmin

  end function xval_sp

  subroutine histogram1d_sp(array,xmin,xmax,nbin,hist_x,hist_y,mask,weights)
    ! Bin 1D array of values into 1D regular histogram

    implicit none

    real(sp),dimension(:),intent(in) :: array
    real(sp),dimension(:),intent(in),optional :: weights
    ! the array of values to bin

    real(sp),intent(in) :: xmin,xmax
    ! the range of the histogram

    integer,intent(in) :: nbin
    ! number of bins

    real(sp),dimension(nbin),intent(out) :: hist_x,hist_y
    ! the histogram

    integer :: i,ibin
    ! binning variables

    logical,optional,intent(in) :: mask(:)
    logical,allocatable:: keep(:)

    allocate(keep(size(array)))

    if(present(mask)) then
       keep = mask
    else
       keep = .true.
    end if

    hist_x=0._sp ; hist_y=0._sp

    do i=1,size(array)
       if(keep(i)) then
          ibin=ipos(xmin,xmax,array(i),nbin)
          if(ibin.ge.1.and.ibin.le.nbin) then
             if(present(weights)) then
                hist_y(ibin)=hist_y(ibin)+weights(i)
             else
                hist_y(ibin)=hist_y(ibin)+1._sp
             end if
          end if
       end if
    end do

    do ibin=1,nbin
       hist_x(ibin)=xval(xmin,xmax,ibin,nbin)
    end do

    deallocate(keep)

  end subroutine histogram1d_sp

  subroutine histogram2d_sp(n,x,y,xmin,xmax,ymin,ymax,nx,ny,array,mask_in)
    ! Bin two 1D array of values into 2D regular grid

    implicit none

    integer,intent(in) :: n
    ! number of values to bin

    real(sp),dimension(n),intent(in) :: x,y
    logical,dimension(n),intent(in),optional :: mask_in
    ! the array of values to bin

    real(sp),intent(in) :: xmin,xmax,ymin,ymax
    ! the range of the histogram

    integer,intent(in) :: nx,ny
    ! number of bins

    real(sp),dimension(nx,ny),intent(out) :: array
    ! the histogram

    integer :: i,ix,iy
    ! binning variables

    logical,dimension(n) :: mask

    if(present(mask_in)) then
       mask = mask_in
    else
       mask = .true.
    end if

    array = 0._sp

    do i=1,n

       if(mask(i)) then

          ix=ipos(xmin,xmax,x(i),nx)
          iy=ipos(ymin,ymax,y(i),ny)

          if(ix.ge.1.and.ix.le.nx) then
             if(iy.ge.1.and.iy.le.ny) then
                array(ix,iy) = array(ix,iy) + 1.
             end if
          end if

       end if

    end do

  end subroutine histogram2d_sp

  subroutine swap_sp(array, i, j)
    implicit none
    real(sp),intent(inout) :: array(:)
    integer,intent(in) :: i, j
    real(sp) :: temp
    temp = array(j)
    array(j) = array(i)
    array(i) = temp
  end subroutine swap_sp

  subroutine partition_sp(array, left, right, pivot_index, store_index)
    implicit none
    real(sp),intent(inout) :: array(:)
    integer,intent(in) :: left, right, pivot_index
    integer,intent(out) :: store_index
    real(sp) :: pivot_value
    integer :: i
    pivot_value = array(pivot_index)
    call swap_sp(array, pivot_index, right)
    store_index = left
    do i=left, right-1
       if(array(i) <= pivot_value) then
          call swap_sp(array, i, store_index)
          store_index = store_index + 1
       end if
    end do
    call swap_sp(array, store_index, right)
  end subroutine partition_sp

  recursive subroutine quicksort_sp(array, left, right)
    implicit none
    real(sp),intent(inout) :: array(:)
    integer,intent(in) :: left, right
    integer :: pivot_index, new_pivot_index
    if(right > left) then
       pivot_index = left+(right-left)/2
       call partition_sp(array, left, right, pivot_index, new_pivot_index)
       call quicksort_sp(array, left, new_pivot_index - 1)
       call quicksort_sp(array, new_pivot_index + 1, right)
    end if
  end subroutine quicksort_sp

  recursive subroutine quicksort_all_sp(array)
    implicit none
    real(sp),intent(inout) :: array(:)
    call quicksort_sp(array, 1, size(array))
  end subroutine quicksort_all_sp

  subroutine swap_index_sp(array, index, i, j)
    implicit none
    real(sp),intent(inout) :: array(:)
    integer,intent(inout) :: index(:)
    integer,intent(in) :: i, j
    real(sp) :: temp
    integer :: temp_i
    temp = array(j)
    temp_i = index(j)
    array(j) = array(i)
    index(j) = index(i)
    array(i) = temp
    index(i) = temp_i
  end subroutine swap_index_sp

  subroutine partition_index_sp(array, index, left, right, pivot_index, store_index)
    implicit none
    real(sp),intent(inout) :: array(:)
    integer,intent(inout) :: index(:)
    integer,intent(in) :: left, right, pivot_index
    integer,intent(out) :: store_index
    real(sp) :: pivot_value
    integer :: i
    pivot_value = array(pivot_index)
    call swap_index_sp(array, index, pivot_index, right)
    store_index = left
    do i=left, right-1
       if(array(i) <= pivot_value) then
          call swap_index_sp(array, index, i, store_index)
          store_index = store_index + 1
       end if
    end do
    call swap_index_sp(array, index, store_index, right)
  end subroutine partition_index_sp

  recursive subroutine quicksort_index_sp(array, index, left, right)
    implicit none
    real(sp),intent(inout) :: array(:)
    integer,intent(inout) :: index(:)
    integer,intent(in) :: left, right
    integer :: pivot_index, new_pivot_index
    if(right > left) then
       pivot_index = left+(right-left)/2
       call partition_index_sp(array, index, left, right, pivot_index, new_pivot_index)
       call quicksort_index_sp(array, index, left, new_pivot_index - 1)
       call quicksort_index_sp(array, index, new_pivot_index + 1, right)
    end if
  end subroutine quicksort_index_sp

  recursive subroutine quicksort_index_all_sp(array, index)
    implicit none
    real(sp),intent(inout) :: array(:)
    integer,intent(inout) :: index(:)
    call quicksort_index_sp(array, index, 1, size(array))
  end subroutine quicksort_index_all_sp

  subroutine check_sort_sp(array)
    implicit none
    real(sp),intent(inout) :: array(:)
    integer :: j
    do j=1,size(array)-1
       if(array(j+1) < array(j)) stop "Incorrectly sorted array"
    end do
  end subroutine check_sort_sp

  subroutine test_quicksort_sp()

    implicit none

    real(sp),allocatable :: array1(:), array2(:)
    integer,allocatable :: index(:)
    integer :: j,i

    write(*,'(" Testing quicksort")')

    do j=1,20

       write(*,'("  - n=",I0)') 2**j

       allocate(array1(2**j))

       call random_number(array1)

       call quicksort(array1)

       call check_sort_sp(array1)

       deallocate(array1)

    end do

    write(*,'(" Testing quicksort_index")')

    do j=1,20

       write(*,'("  - n=",I0)') 2**j

       allocate(array1(2**j), array2(2**j), index(2**j))

       call random_number(array1)
       array2 = array1
       forall(i=1:2**j) index(i) = i

       call quicksort_index(array1, index)

       call check_sort_sp(array1)

       if(any(array2(index).ne.array1)) stop "Failure in quicksort_index"

       deallocate(array1, array2, index)

    end do

  end subroutine test_quicksort_sp

  subroutine invert_matrix(n,a,c)

    implicit none

    integer,intent(in) :: n
    ! size of the matrix

    real(dp),dimension(n,n),intent(in)  :: a
    real(dp),dimension(n,n),intent(out) :: c
    ! the input and output matrices

    real(dp),dimension(n,n) :: b

    integer :: i,j
    real(dp) :: scale

    ! a is the input matrix

    ! b is initially set to a

    b = a

    ! c is initially an identity matrix

    c = 0._dp
    forall(i=1:n) c(i,i) = 1._dp

    ! Go through each row, and sutract from all subsequent rows

    do i=1,n
       do j=i+1,n
          scale = -b(i,j)/b(i,i)
          b(:,j) = b(:,j)+scale*b(:,i)
          c(:,j) = c(:,j)+scale*c(:,i)
       end do
    end do

    do j=1,n-1
       do i=j+1,n
          scale = -b(i,j)/b(i,i)
          b(:,j) = b(:,j)+scale*b(:,i)
          c(:,j) = c(:,j)+scale*c(:,i)
       end do
    end do

    forall(i=1:n,j=1:n) c(i,j) = c(i,j)/b(j,j)
    forall(i=1:n,j=1:n) b(i,j) = b(i,j)/b(j,j)

  end subroutine invert_matrix

  subroutine print_matrix(a)

    implicit none

    integer :: nx,ny
    real(dp),dimension(:,:),intent(in) :: a

    integer :: i

    character(len=20) :: fmt

    nx = size(a,1)
    ny = size(a,2)

    write(fmt,'("(",I3.3,"(F9.5,1X))")') nx

    do i=1,ny
       write(*,fmt) a(:,i)
    end do

  end subroutine print_matrix

  subroutine bin_array(n,x,y,n_bin,xmin,xmax,x_bin,y_bin)

    implicit none

    integer,intent(in) :: n,n_bin
    real(dp),dimension(n),intent(in) :: x,y
    real(dp),dimension(n_bin),intent(out) :: x_bin,y_bin

    real(dp),dimension(n_bin) :: s,c

    real(dp) :: xmin,xmax

    integer :: i,ix

    s = 0.
    c = 0.

    do i=1,n

       ix = ipos(xmin,xmax,x(i),n_bin)

       if(ix.ge.1.and.ix.le.n_bin) then
          c(ix)  = c(ix) + 1.
          s(ix)  = s(ix) + y(i)
       end if

    end do

    do i=1,n_bin
       x_bin(i) = xval(xmin,xmax,i,n_bin)
    end do

    y_bin = s / c

  end subroutine bin_array

  subroutine smooth_2d(array,sigma)

    implicit none

    real,intent(inout) :: array(:,:)

    integer :: nx,ny
    real,allocatable :: array_orig(:,:),array_count(:,:)

    real,intent(in) :: sigma

    integer :: i,j,ii,jj,imin,imax,jmin,jmax,w

    real :: dx,dy,d

    nx = size(array,1)
    ny = size(array,2)

    allocate(array_orig(nx,ny),array_count(nx,ny))

    array_orig  = array
    array       = 0.
    array_count = 0.

    w = nint(sigma * 5._dp)

    do i=1,nx
       do j=1,ny

          imin = max( 1,i-w)
          imax = min(nx,i+w)
          jmin = max( 1,j-w)
          jmax = min(ny,j+w)

          do ii=imin,imax
             do jj=jmin,jmax

                dx = real(ii-i) / sigma
                dy = real(jj-j) / sigma

                d = dx*dx+dy*dy

                array(i,j) = array(i,j) + array_orig(ii,jj) * exp(-d/2._dp)
                array_count(i,j) = array_count(i,j) + exp(-d/2._dp)

             end do
          end do

       end do
    end do

    array = array / array_count

  end subroutine smooth_2d

end module lib_array


! This subroutine calculates the absolute value of the determinant of a matrix
! using a LAPACK Q-R factorization. The absolute value of the determinant is
! the sum of the absolute values of the elements on the diagonal of the R
! matrix
! Calculate the absolute value of the determinant of a square NXN
! matrix using an LU factorization by LAPACK

subroutine abs_determinant(A, N, det)

   use params, only: dp

   integer N       !Size of the matrix A
   real(dp) A(N, N)
   real(dp) det
   integer LDA
   integer inFO
   integer I
   real(dp) LU(N, N)
   integer IPIV(N, N)

   LDA = N
   LWORK = N
   LU = A

   CALL DGETF2(N, N, A, LDA, IPIV, inFO)
   !Returned LU  matrix contains the U matrix from the LU factorization
   !on the upper diagonal. Take the absolute value of the product of the diagonals
   !to get the absolute value of the determinant

   det = 1.

   do I = 1, N
      det = det*A(I, I)
   ENDdo
   det = ABS(det)

END subroutine abs_determinant


! Define and call a subroutine
program optional_arg
implicit none
real :: x(1000000),xmean,xsd
call random_seed()
call random_number(x)   ! generate uniform random deviates on (0,1]
call stats(x,xmean,xsd) ! subroutine invoked with the call statement
print*,xmean,xsd
contains
!
pure subroutine stats(x,xmean,xsd)
real, intent(in)  :: x(:)  ! data for which stats computed
real, intent(out) :: xmean ! mean of x(:)
real, intent(out) :: xsd   ! standard deviation of x(:)
real, parameter   :: bad = -999.0
integer           :: n
n     = size(x)
! set outputs to bad value if there is insufficient data
xmean = bad
xsd   = bad
if (n < 1) return
xmean = sum(x)/size(x) ! enough data to compute mean
if (n < 2) return
xsd = sqrt(sum((x-xmean)**2)/(n-1)) ! enough data to compute standard deviation
end subroutine stats
end program optional_arg


PROGRAM getSize
IMPLICIT NONE
	REAL(KIND = 4) :: a
	REAL(KIND = 8) :: b
	INTEGER(KIND = 2) :: i
	INTEGER(KIND = 4) :: j

	PRINT *, 'Precision of real(4) = ', PRECISION(a)
	PRINT *, 'Precision of real(8) = ', PRECISION(b)

	PRINT *, 'Range of real(4) = ', RANGE(a)
	PRINT *, 'Range of real(8) = ', RANGE(b)

	PRINT *, 'Maximum exponent of real(4) = ', MAXEXPONENT(a)
	PRINT *, 'Maximum exponent of real(8) = ', MAXEXPONENT(b)

	PRINT *, 'Minimum exponent of real(4) = ', MinEXPONENT(a)
	PRINT *, 'Minimum exponent of real(8) = ', MinEXPONENT(b)

	PRINT *, 'Bits in integer(2) = ', BIT_SIZE(i)
	PRINT *, 'Bits in integer(4) = ', BIT_SIZE(j)
END PROGRAM getSize


module matrix_mod
implicit none

contains

    subroutine compute_sigma(S, nr_rows, nr_cols, Sigma)
        use, intrinsic :: iso_fortran_env, only : dp => REAL64
        implicit none
        real(kind=dp), dimension(:), intent(in) :: S
        integer, intent(in) :: nr_rows, nr_cols
        integer :: i, error
        real(kind=dp), allocatable, dimension(:, :), intent(out) :: Sigma
        allocate(Sigma(nr_rows, nr_cols), stat=error)
        Sigma = 0.0_dp
        do i = 1, min(nr_rows, nr_cols)
            Sigma(i, i) = S(i)
        end do
    end subroutine compute_sigma

    subroutine reconstruct_matrix(U, S, VT, A)
        use, intrinsic :: iso_fortran_env, only : dp => REAL64, error_unit
        implicit none
        real(kind=dp), dimension(:, :), intent(in) :: U, VT
        real(kind=dp), dimension(:), intent(in) :: S
        real(kind=dp), dimension(:, :), allocatable, intent(out) :: A
        real(kind=dp), dimension(:, :), allocatable :: tmp, Sigma
        integer :: nr_rows, nr_cols, error

        ! create Sigma
        nr_rows = size(U, 1)
        nr_cols = size(VT, 2)
        call compute_sigma(S, nr_rows, nr_cols, Sigma)

        ! allocate reconstructed matrix
        allocate(A(nr_rows, nr_cols), stat=error)
        if (error /= 0) then
            write (unit=error_unit, fmt="(A)") "can not allocate A"
            stop
        end if

        ! compute tmp = U*Sigma
        allocate(tmp(nr_rows, nr_cols), stat=error)
        if (error /= 0) then
            write (unit=error_unit, fmt="(A)") "can not allocate work"
            stop
        end if
        call dgemm('N', 'N', nr_rows, nr_cols, nr_rows, 1.0_dp, U, nr_rows, &
                   Sigma, nr_rows, 0.0_dp, tmp, nr_rows)
        call dgemm('N', 'N', nr_rows, nr_cols, nr_cols, 1.0_dp, tmp, nr_rows, &
                   VT, nr_cols, 0.0_dp, A, nr_rows)

        ! clean up
        deallocate(Sigma, tmp)

    end subroutine reconstruct_matrix

    subroutine compute_svd(A_orig, U, S, Vt)
        use, intrinsic :: iso_fortran_env, only : dp => REAL64, i8 => INT64, &
                                                  error_unit
        implicit none
        real(kind=dp), dimension(:, :), intent(in) :: A_orig
        real(kind=dp), dimension(:, :), allocatable, intent(out) :: U, VT
        real(kind=dp), dimension(:), allocatable, intent(out) :: S
        real(kind=dp), dimension(:), allocatable :: work
        real(kind=dp), dimension(:, :), allocatable :: A
        integer :: nr_rows, nr_cols, error, info, lwork

        nr_rows = size(A_orig, 1)
        nr_cols = size(A_orig, 2)

        ! copy A, since it will be destroyed by dgesvd
        allocate(A, source=A_orig, stat=error)
        if (error /= 0) then
            write (unit=error_unit, fmt="(A)") "can not allocate orig_A"
            stop
        end if
        A = A_orig

        ! allocate matricess
        allocate(U(nr_rows, nr_rows), stat=error)
        if (error /= 0) then
            write (unit=error_unit, fmt="(A)") "can not allocate U"
            stop
        end if
        allocate(S(min(nr_rows, nr_cols)), stat=error)
        if (error /= 0) then
            write (unit=error_unit, fmt="(A)") "can not allocate S"
            stop
        end if
        allocate(VT(nr_cols, nr_cols), stat=error)
        if (error /= 0) then
            write (unit=error_unit, fmt="(A)") "can not allocate VT"
            stop
        end if

        ! compute full SVD of A
        allocate(work(1))
        info = 0
        call dgesvd('A', 'A', nr_rows, nr_cols, A, nr_rows, S, &
                    U, nr_rows, VT, nr_cols, work, -1, info)
        lwork = int(work(1))
        deallocate(work)
        allocate(work(lwork), stat=error)
        if (error /= 0) then
            write (unit=error_unit, fmt="(A)") "can not allocate work"
            stop
        end if
        call dgesvd('A', 'A', nr_rows, nr_cols, A, nr_rows, S, &
                    U, nr_rows, VT, nr_cols, work, lwork, info)

        ! clean up
        deallocate(A)
        deallocate(work)

    end subroutine compute_svd

    subroutine get_matrix_dimensions(file_name, matrix_dset_name, &
                                     dims)
        use hdf5
        use, intrinsic :: iso_fortran_env, only : dp => REAL64, error_unit
        implicit none
        integer, parameter :: matrix_rank = 2
        character(len=*), intent(in) :: file_name, matrix_dset_name
        integer, dimension(matrix_rank) :: dims
        integer(hid_t) :: file_id, matrix_dset_id, matrix_fspace_id
        integer(hsize_t), dimension(matrix_rank) :: matrix_dims, &
                                                    max_matrix_dims
        integer :: error
        call h5open_f(error)

        ! open the HDF5 file, overwriting it if it alread exists
        call h5fopen_f(file_name, H5F_ACC_RDONLY_F, file_id, error)
        if (error /= 0) then
            write (unit=error_unit, fmt="(2A)") "# error opening file ", &
                                                file_name
            stop
        end if

        ! open the matrix dataset, and get the matrix file dataspace
        call h5dopen_f(file_id, matrix_dset_name, matrix_dset_id, error)
        call h5dget_space_f(matrix_dset_id, matrix_fspace_id, error)

        ! retrieve the dimensions of the matrix, and allocate the matrix
        call h5sget_simple_extent_dims_f(matrix_fspace_id, matrix_dims, &
                                         max_matrix_dims, error)
        ! close the matrix dataset
        call h5dclose_f(matrix_dset_id, error)

        ! close HDF5 file
        call h5fclose_f(file_id, error)

        ! finalize Fortran HDF5 interface
        call h5close_f(error)
        dims = int(matrix_dims)
    end subroutine get_matrix_dimensions

    subroutine read_matrix(file_name, matrix_dset_name, matrix)
        use hdf5
        use, intrinsic :: iso_fortran_env, only : dp => REAL64, error_unit
        implicit none
        character(len=*), intent(in) :: file_name, matrix_dset_name
        real(kind=dp), allocatable, dimension(:, :), intent(out) :: matrix
        integer(hid_t) :: file_id, matrix_dset_id, matrix_mspace_id, matrix_fspace_id
        integer, parameter :: matrix_rank = 2
        integer(hsize_t), dimension(matrix_rank) :: matrix_dims, &
                                                    max_matrix_dims
        integer :: error
        ! initialize Fortran interface
        call h5open_f(error)

        ! open the HDF5 file, overwriting it if it alread exists
        call h5fopen_f(file_name, H5F_ACC_RDONLY_F, file_id, error)
        if (error /= 0) then
            write (unit=error_unit, fmt="(2A)") "# error opening file ", &
                                                file_name
            stop
        end if

        ! open the matrix dataset, and get the matrix file dataspace
        call h5dopen_f(file_id, matrix_dset_name, matrix_dset_id, error)
        call h5dget_space_f(matrix_dset_id, matrix_fspace_id, error)

        ! retrieve the dimensions of the matrix, and allocate the matrix
        call h5sget_simple_extent_dims_f(matrix_fspace_id, matrix_dims, &
                                         max_matrix_dims, error)
        allocate(matrix(matrix_dims(1), matrix_dims(2)), stat=error)
        if (error /= 0) then
            write (unit=error_unit, fmt="(A)") &
                "matrix can not be allocated"
            stop
        end if

        ! create the matrix memory dataspace
        call h5screate_simple_f(matrix_rank, matrix_dims, &
                                matrix_mspace_id, error)

        ! read the data
        call h5dread_f(matrix_dset_id, H5T_NATIVE_DOUBLE, matrix, &
                       matrix_dims, error, mem_space_id=matrix_mspace_id, &
                       file_space_id=matrix_fspace_id)

        ! close dataspaces
        call h5sclose_f(matrix_mspace_id, error)
        call h5sclose_f(matrix_fspace_id, error)

        ! close the matrix dataset
        call h5dclose_f(matrix_dset_id, error)

        ! close HDF5 file
        call h5fclose_f(file_id, error)

        ! finalize Fortran HDF5 interface
        call h5close_f(error)
    end subroutine read_matrix

    subroutine print_matrix(matrix)
        use, intrinsic :: iso_fortran_env, only : dp => REAL64
        implicit none
        real(kind=dp), dimension(:, :), intent(in) :: matrix
        integer i
        character(len=50) :: format_str
        write (format_str, "('(', I0, 'F8.3)')") size(matrix, 2)
        do i = 1, size(matrix, 1)
            print format_str, matrix(i, :)
        end do
    end subroutine print_matrix

end module matrix_mod


      PROGRAM LA_SGBSVX_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements"
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_GBSVX
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: K, KL, KU, I, J, N, NRHS
      CHARACTER(LEN=1) :: EQUED
!  .. "Local Arrays" ..
      REAL(WP), ALLOCATABLE :: AB(:,:), B(:,:), X(:,:), R(:), C(:), &
                               FERR(:), BERR(:)
!  .. "Executable Statements" ..
      WRITE (*,*) 'LA_GBSVX Example Program Results.'
      N = 6; KL = 2; KU = 1; NRHS = 2
!     ALLOCATE ( AB(2*KL+KU+1,N), B(N,NRHS), X(N,NRHS), R(N), C(N), &
      ALLOCATE ( AB(  KL+KU+1,N), B(N,NRHS), X(N,NRHS), R(N), C(N), &
                 FERR(NRHS),BERR(NRHS) )

      OPEN(UNIT=21,FILE='gbsv.ma',STATUS='UNKNOWN')
!     DO I=KL+1,2*KL+KU+1
      DO I=   1,  KL+KU+1
      DO J=1,N
         READ(21,'(F2.0)') AB(I,J)
      ENDDO
      ENDDO
      CLOSE(21)

      AB(:,1:1)=1e-6*AB(:,1:1)
      DO J = 1, N
        DO K = 1, 1+KU-MIN(J-1,KU)-1; AB(K,J) = HUGE(1.0_WP); END DO
        DO K = 1+ KU+MIN(N-J,KL)+KL+1, 1+KU+KL; AB(K,J) = HUGE(1.0_WP); END DO
      END DO
      WRITE(*,*) 'The array AB:'
      DO I=1,N; WRITE(*,*) AB(I,:); ENDDO

      B = 0.0_WP
      DO I = 1, NRHS;
        DO J = 1, N
          DO K = 1+KU-MIN(J-1,KU), 1+ KU+MIN(N-J,KL)
            B(J,I) = AB(K,J)+B(J,I);
          ENDDO
        ENDDO;
        B(:,I) = B(:,I)*I;
      ENDDO

      WRITE(*,*) 'The RHS matrix B:'
      DO I=1,N; WRITE(*,"(1(I3,1X),I3,1X)") INT(B(I,:)); ENDDO

      WRITE(*,*) "CALL LA_GBSVX( AB, B, X, 2, TRANS='T', EQUED=EQUED,", &
                 " R=R, C=C, FERR=FERR, BERR=BERR )"

      CALL LA_GBSVX( AB, B, X, 2, FACT='E',TRANS='T',EQUED=EQUED, &
                     R=R, C=C, FERR=FERR, BERR=BERR )

      WRITE(*,*)'X on exit: '
      DO I=1,N; WRITE(*,"(1(E12.6,1X),E12.6,1X)") X(I,:); ENDDO
      WRITE(*,*)'EQUED = ', EQUED
      WRITE(*,*)'R = ', R
      WRITE(*,*)'C = ', C
      WRITE(*,*)'FERR = ', FERR
      WRITE(*,*)'BERR = ', BERR

      END PROGRAM LA_SGBSVX_EXAMPLE


       SUBROUTINE cross_product(X,Y,Z)

! PURPOSE    :  computation of the cross product of two vectors X and Y

! PARAMETERS :
!         IN :  X(I),I=1,2,3 COMPONENTS OF  X
!               Y(I),I=1,2,3 COMPONENTS OF  Y
!        OUT :  Z(I),I=1,2,3 COMPONENTS OF  Z
!
! AUTHOR     :  Dr. Tzupang Tseng
!
! CREATED    :  01-NOV-2017
!
!
! COPYRIGHT  :  GEOSCIENCE AUSTRALIA
!

       IMPLICIT NONE
       REAL*8       :: X(3),Y(3),Z(3)

! computation of the cross product of two vectros X and Y
! -------------------------------------------------------
       Z(1)=X(2)*Y(3)-X(3)*Y(2)
       Z(2)=X(3)*Y(1)-X(1)*Y(3)
       Z(3)=X(1)*Y(2)-X(2)*Y(1)
       RETURN
       END SUBROUTINE


    use dflib
    !Author : globalpolicy
    !Blog   : c0dew0rth.blogspot.com
    !GitHub : globalpolicy
    !Date   : 06:05PM - 12th August, 2019
    !Purpose: To draw flownet (revised)
    !Changes:
    !-Head at dam heel is water depth as should be(was assumed 0 before)
    !-Dam was fixed to be the size of a single grid box. Now, width of dam can be specified.
    !-Dam's heel and toe are Dirichlet boundaries i.e. known heads but any node between are treated as unknowns.
    !Parameters : contourInterval, numDys, numDxs, DxsTillDam, DamWidthInDxs, reservoirHead, downstreamBoundaryHead

    !Built by observing structure of an example coefficient matrix from my Fortran Simulation notes
    !https://photos.app.goo.gl/BS5C2tp4MNMFp9Dh6 -> example grid
    !https://photos.app.goo.gl/GecBS62BS1hTPNri9 -> matrix construction
    !https://photos.app.goo.gl/WgKvzMWf63CRNBwZA -> final matrix
    !Also, during revision of code, the following problems were taken as a reference:
    !https://photos.app.goo.gl/1p7NWiWeYKTRTBEh6
    !https://photos.app.goo.gl/LF51G7jisALXweCL7
    !Coefficient matrices were constructed for them and solved in Excel:
    !https://drive.google.com/open?id=1I513Eq-tPaADIw_MF5oiTIGo4es4k2f8
    !Great lectures I made my notes off of:
    !https://www.youtube.com/watch?v=FgR3KS51mbA - Prof. Wen Shen, Penn State University
    !https://www.youtube.com/watch?v=i0f2DegLBN8 - Sandip Mazumder

    implicit none

    integer i,j,col,row
    character(10) char
    real tmp,distance,smallestDistanceIndex,smallestDistance
    integer numDys,numDxs,numUnknowns,DxsTillDam,DamWidthInDxs
    integer(2) viewPortTopLeftx,viewPortTopLefty,viewPortBottomRightx,viewPortBottomRighty,viewPortWidth !viewPortWidth=viewPortHeight
    real reservoirHead,downstreamBoundaryHead
    real A(500,500),B(500,500),X(500,500),AInverse(500,500)
    logical status
    TYPE(wxycoord) wxy
    integer ret
    real H(500,500)
    real EquipotentialX(500,500),EquipotentialY(500,500) !one column for one head, same column's row element from each matrix give the equipotential point x,y
    real searchHead,currentHead,rightHead,upHead,contourInterval
    real interpolatedX,interpolatedY
    integer numberOfContours, contourId
    integer contourPointsCounters(500) !stores the number of equipotential points obtained for each contour

    contourInterval=10

    numDys=3 !total grid boxes along Y axis, enclosed within boundaries top and bottom
    numDxs=4 !total grid boxes along X axis, enclosed within boundaries left and right
    DxsTillDam=2
    DamWidthInDxs=2

    reservoirHead=100
    downstreamBoundaryHead=50

    viewPortWidth = 400 !width(=height) of the viewport
    viewPortTopLeftx = 200
    viewPortTopLefty = 80

    numUnknowns=numDys*numDxs+(DamWidthInDxs-1)
    numberOfContours=reservoirHead/contourInterval + 1

    !generate coefficient matrix A
    !the rows, columns and nodes in the comments are referencing the full domain grid including the boundaries(https://photos.app.goo.gl/nToWZ9p3znyGxvwy8), not the array/matrix used here
    do i=1,numUnknowns !row index
        do j=1,numUnknowns !column index
            if(i.EQ.j) then

                A(i,j)=-4

                !for immediate right element of diagonal's row (right blob of Laplace computational stencil)
                if(i.LT.numDxs*numDys.AND.MODULO(i,numDxs).EQ.1) then !if current node is on u/s boundary
                    A(i,j+1)=2
                elseif(i.LE.numDxs*numDys.AND.MODULO(i,numDxs).EQ.0) then !if current node is on second-last column (before d/s boundary) and below the surface row
                    A(i,j+1)=0
                    B(i,1)=B(i,1)-downstreamBoundaryHead
                elseif(i.GT.numDxs*numDys.AND.i.EQ.numUnknowns) then !if current node is the final unknown i.e. surface node right beneath dam, right before toe of dam(d/s boundary)
                    A(i,j+1)=0
                    B(i,1)=B(i,1)-0
                else
                    A(i,j+1)=1
                endif

                !for immediate left element of diagonal's row (left blob of Laplace computational stencil)
                if(j.GT.1) then !if current node is not the bottom-left one
                    if(i.LT.numDxs*numDys.AND.MODULO(i,numDxs).EQ.1) then !if current node is on u/s boundary
                        A(i,j-1)=0
                    elseif(DamWidthInDxs.GE.2.AND.i.EQ.numDxs*numDys+1) then !if current node is right beneath the dam, one node to right of heel
                        A(i,j-1)=0
                        B(i,1)=B(i,1)-reservoirHead
                    else
                        A(i,j-1)=1
                    endif
                endif

                !for far right element of diagonal's row (top blob of Laplace computational stencil)
                if(i.LE.numDxs) then !if current node is in the bottom row
                    A(i,j+numDxs)=2
                elseif(j+numDxs.LE.numDxs*numDys) then !if current row is below the second-top row
                    A(i,j+numDxs)=1
                elseif(j.LE.numDxs*numDys) then !if current row is second-top row(row immediately below surface)
                    if(j.LE.numUnknowns-(DamWidthInDxs-1+numDxs-DxsTillDam-1)) then !if this node is u/s of heel of dam, heel inclusive
                        B(i,1)=B(i,1)+(-reservoirHead)
                    elseif(j.GT.numDxs*numDys-(DamWidthInDxs-1).AND.j.LE.numDxs*numDys) then !if node is between(exclusive) heel and toe
                        A(i,j+(DamWidthInDxs-1))=1
                    endif
                else !if current row is topmost row(unknown nodes directly beneath the dam)
                    B(i,1)=B(i,1)+0
                endif

                !for far left element of diagonal's row (bottom blob of Laplace computational stencil)
                if(j.GT.numDxs) then
                    if(j.LE.numDxs*numDys) then
                        A(i,j-numDxs)=1
                    else
                        A(i,j-(DamWIdthInDxs-1))=2
                    endif
                endif

            endif
        end do
    end do

    !generated coefficient matrix A written to file for inspection
    open(1,file='A.txt')
    do i=1,numUnknowns
        write(1,'(F5.1,$)') (A(i,j),j=1,numUnknowns)
        write(1,*)
    end do
    close(1)

    !generated B vector written to file for inspection
    open(1,file='B.txt')
    do i=1,numUnknowns
        write(1,*) B(i,1)
    end do
    close(1)

    call Inverse(A,AInverse,numUnknowns)
    X=matmul(AInverse,B)

    !calculated X vector
    open(1,file='X.txt')
    do i=1,numUnknowns
        write(1,*) X(i,1)
    end do
    close(1)

    !setup viewport
    viewPortBottomRightx = int2(viewPortTopLeftx+real(numDxs)/real(numDys)*viewPortWidth)
    viewPortBottomRighty = int2(viewPortTopLefty+viewPortWidth)
    call SETVIEWPORT(200,80,viewPortBottomRightx,viewPortBottomRighty)
    status = SETCOLOR(4) !red
    status = FLOODFILL(51,81,4) !flood fill viewport
    status = SETWINDOW(.TRUE.,real(0,8),real(0,8),real(numDxs,8),real(numDys,8))
    status = SETCOLOR(1)

    !draw horizontal lines from bottom to top
    do i=0,numDys
        call MOVETO_W(0.0_8,real(i,8),wxy)
        ret = LINETO_W(real(numDxs,8),real(i,8))
    end do

    !draw vertical lines from left to right
    do i=0,numDxs
        call MOVETO_W(real(i,8),0.0_8,wxy)
        ret = LINETO_W(real(i,8),real(numDys,8))
    end do

    !create Head matrix for whole domain from calculated heads at nodes and the boundary condition values
    !populate non-last row(below surface) of Head matrix from the computed X vector
    do i=1,numDys
        do j=1,numDxs+1
            if(j.EQ.numDxs+1) then !if final column
                H(i,j)=downstreamBoundaryHead
            else
                H(i,j)=X((i-1)*numDxs+j,1)
            endif
        end do
    end do
    !populate the last row (corresponding to the surface heads)
    i=1
    do j=1,numDxs+1
        if(j.LE.DxsTillDam+1) then
            H(numDys+1,j)=reservoirHead
        elseif(j.GT.DxsTillDam+1.AND.j.LT.numDxs+1) then
            H(numDys+1,j)=X(numDxs*numDys+i,1)
            i=i+1
        else
            H(numDys+1,j)=0
        endif
    end do

    !output H matrix to file for inspection
    !observe that it is of the form (taking the referenced example at the top)
    !           h1           h2             h3          h4    downstreamBoundaryHead
    !           h5           h6             h7          h8    downstreamBoundaryHead
    !           h9          h10             h11         h12   downstreamBoundaryHead
    !   reservoirHead   reservoirHead  reservoirHead    h13     0
    !where h1,h2,... are computed heads from X vector
    !also observe that H matrix has exactly the same number of elements as nodes in our whole domain grid(i.e. numDys+1 by numDxs+1)
    open(1,file='H.txt')
    do i=1,numDys+1
        write(1,'(F5.1,$,"  ")') (H(i,j),j=1,numDxs+1)
        write(1,*)
    end do
    close(1)

    contourId=0
    do searchHead=0,reservoirHead,contourInterval
        contourId=contourId+1
        !iterate through grid nodes one column at a time, left to right, looking for same potential(searchHead) right and top
        !note that correspondence between our grid coordinate and H matrix's element is
        !Head at coordinate (col,row) of grid  = (row+1,col+1) element of H matrix
        !Makes use of the fact that in a row, head decreases from left to right.
        !Depending on column on grid, in a column, head decreases top to bottom for col<damX and increases for col>=damX
        do col=0,numDxs
10            do row=0,numDys
                currentHead=H(row+1,col+1)
                if(currentHead.NE.searchHead) then
                    if(col<numDxs) then !look toward east node
                        rightHead=H(row+1,col+2)
                        if(searchHead.LE.currentHead.AND.searchHead.GE.rightHead) then
                            interpolatedX=col+1/(rightHead-currentHead)*(searchHead-currentHead)
                            contourPointsCounters(contourId)=contourPointsCounters(contourId)+1
                            EquipotentialX(contourPointsCounters(contourId),contourId)=interpolatedX
                            EquipotentialY(contourPointsCounters(contourId),contourId)=row
                        endif

                    endif
                    if(row<numDys) then !look toward north node
                        upHead=H(row+2,col+1)
                        if(col<DxsTillDam) then !if we're left of dam
                            !head increases towards up
                            if(searchHead.GE.currentHead.AND.searchHead.LE.upHead) then
                                interpolatedY=row+1/(upHead-currentHead)*(searchHead-currentHead)
                                contourPointsCounters(contourId)=contourPointsCounters(contourId)+1
                                EquipotentialY(contourPointsCounters(contourId),contourId)=interpolatedY
                                EquipotentialX(contourPointsCounters(contourId),contourId)=col
                            endif
                        else !if we're at or right of dam's heel
                            !head decreases towards up
                            if(searchHead.LE.currentHead.AND.searchHead.GE.upHead) then
                                interpolatedY=row+1/(upHead-currentHead)*(searchHead-currentHead)
                                contourPointsCounters(contourId)=contourPointsCounters(contourId)+1
                                EquipotentialY(contourPointsCounters(contourId),contourId)=interpolatedY
                                EquipotentialX(contourPointsCounters(contourId),contourId)=col
                            endif
                        endif
                    endif
                else
                    !we're standing at our searchHead!!
                    contourPointsCounters(contourId)=contourPointsCounters(contourId)+1
                    EquipotentialY(contourPointsCounters(contourId),contourId)=row
                    EquipotentialX(contourPointsCounters(contourId),contourId)=col
                endif
            end do
        end do
    end do

    !!----DEPRECATED EQUIPOTENTIAL POINT SORTING METHOD----
    !!sort equipotential points in ascending (descending works too) order of x coordinate for proper equipotential line
    !!sketching (left to right in ascending, right to left in descending).
    !!EDIT : Equipotential curves that are improper functions (two y's for a x) don't behave nicely with
    !!this method though. Only a couple of curves, generally towards the center of the flownet are as such
    !!in my experience.
    !do contourId=1,numberOfContours
    !    do i=1,contourPointsCounters(contourId)
    !        do j=i,contourPointsCounters(contourId)
    !            if(EquipotentialX(j,contourId).LT.EquipotentialX(i,contourId)) then
    !                tmp=EquipotentialY(i,contourId)
    !                EquipotentialY(i,contourId)=EquipotentialY(j,contourId)
    !                EquipotentialY(j,contourId)=tmp
    !
    !                tmp=EquipotentialX(i,contourId)
    !                EquipotentialX(i,contourId)=EquipotentialX(j,contourId)
    !                EquipotentialX(j,contourId)=tmp
    !            endif
    !        end do
    !    end do
    !end do

    !equipotential points sorting for proper equipotential line sketching
    !first sort equipotential points in descending order of Y coordinate(topmost to bottom-most)
    !then sort based on shortest consecutive distance.
    !better than sorting by x coordinate but not totally devoid of some weird artifacts
    do contourId=1,numberOfContours
        !sort descending in Y coordinate
        do i=1,contourPointsCounters(contourId)
            do j=i,contourPointsCounters(contourId)
                if(EquipotentialY(j,contourId).GT.EquipotentialY(i,contourId)) then
                    !swap Y coordinate
                    tmp=EquipotentialY(i,contourId)
                    EquipotentialY(i,contourId)=EquipotentialY(j,contourId)
                    EquipotentialY(j,contourId)=tmp
                    !swap X coordinate
                    tmp=EquipotentialX(i,contourId)
                    EquipotentialX(i,contourId)=EquipotentialX(j,contourId)
                    EquipotentialX(j,contourId)=tmp
                endif
            end do
        end do
        !sort based on shortest consecutive distance (basically ordering the shortest path downward, downward coz the array is descending inY)
        do i=1,contourPointsCounters(contourId)-1
            smallestDistance=10000 !very large number
            do j=i+1,contourPointsCounters(contourId)
                !distance between i and j point
                distance = (EquipotentialX(i,contourId)-EquipotentialX(j,contourId))**2 + (EquipotentialY(i,contourId)-EquipotentialY(j,contourId))**2
                if(distance.LT.smallestDistance) then
                    smallestDistance=distance
                    smallestDistanceIndex=j
                endif
            end do
            !swap i+1 point and point at smallestDistanceIndex
            !X
            tmp = EquipotentialX(i+1,contourId)
            EquipotentialX(i+1,contourId) = EquipotentialX(smallestDistanceIndex,contourId)
            EquipotentialX(smallestDistanceIndex,contourId) = tmp
            !Y
            tmp = EquipotentialY(i+1,contourId)
            EquipotentialY(i+1,contourId) = EquipotentialY(smallestDistanceIndex,contourId)
            EquipotentialY(smallestDistanceIndex,contourId) = tmp
        end do
    end do

    !write equipotential points to file for observation
    open(1,file='Isobars.txt')
        do contourId=1,numberOfContours
            write(1,*) (contourId-1)*contourInterval
            write(1,'("(",F5.2,",",F5.2,")      ",$)') (EquipotentialX(i,contourId),EquipotentialY(i,contourId),i=1,contourPointsCounters(contourId))
            write(1,*) ''
        end do
    close(1)

    !draw equipotential lines
    do contourId=1,numberOfContours
        call MOVETO_W(real(EquipotentialX(1,contourId),8),real(EquipotentialY(1,contourId),8),wxy)

        !draw a circle on the equipotential point(not necessary)
        status = SETCOLOR(6)
        ret = ELLIPSE_W($GFILLINTERIOR,real(EquipotentialX(1,contourId)-0.015,8),real(EquipotentialY(1,contourId)+0.015,8),real(EquipotentialX(1,contourId)+0.015,8),real(EquipotentialY(1,contourId)-0.015,8))
        status = SETCOLOR(2)

        do i=2,contourPointsCounters(contourId)
            !draw a circle on the equipotential point(not necessary)
            status = SETCOLOR(6)
            ret = ELLIPSE_W($GFILLINTERIOR,real(EquipotentialX(i,contourId)-0.015,8),real(EquipotentialY(i,contourId)+0.015,8),real(EquipotentialX(i,contourId)+0.015,8),real(EquipotentialY(i,contourId)-0.015,8))
            status = SETCOLOR(2)

            !avoids jumping lines
            call GETCURRENTPOSITION_W(wxy)
            if(abs(wxy.wx-EquipotentialX(i,contourId)).GT.4.OR.abs(wxy.wy-EquipotentialY(i,contourId)).GT.4) then
                call MOVETO_W(real(EquipotentialX(i,contourId),8),real(EquipotentialY(i,contourId),8),wxy)
            endif

            ret = LINETO_W(real(EquipotentialX(i,contourId),8),real(EquipotentialY(i,contourId),8))

        end do
    end do

    !draw one grid length horizontal line on grid top representing base of dam
    status = SETCOLOR(8)
    call MOVETO_W(real(DxsTillDam,8),real(numDys,8),wxy)
    ret = LINETO_W(real(DxsTillDam+DamWidthInDxs,8),real(numDys,8))

    !write heads on grid nodes
    !note that correspondence between our grid coordinate and H matrix's element is
    !head at coordinate (col,row) of grid  = (row+1,col+1) element of H matrix
    status = SETCOLOR(8)
    status = INITIALIZEFONTS()
    status = SETFONT('t''Arial''h12w8pvb')
    !loop for except the bottom and right boundaries and bottom-right node (else they're clipped)
    do i=0,numDxs-1
        do j=1,numDys
            call MOVETO_W(real(i,8),real(j,8),wxy)
            write(char,'(F6.2)') H(j+1,i+1)
            call OUTGTEXT(char)
        end do
    end do
    !for bottom boundary
    do i=0,numDxs-1
        call MOVETO_W(real(i,8),real(0,8)+0.1,wxy)
        write(char,'(F6.2)') H(0+1,i+1)
        call OUTGTEXT(char)
    end do
    !for right boundary
    do i=1,numDys
        call MOVETO_W(real(numDxs,8)-0.3,real(i,8),wxy)
        write(char,'(F6.2)') H(i+1,numDxs+1)
        call OUTGTEXT(char)
    end do
    !for bottom right node
    call MOVETO_W(real(numDxs,8)-0.3,real(0,8)+0.1,wxy)
    write(char,'(F6.2)') H(0+1,numDxs+1)
    call OUTGTEXT(char)

    end program

subroutine Inverse(X,XI,size)
dimension X(500,500),XI(500,500),originalX(500,500)
integer rowindex,colindex,size,tmpi,tmpj,i,j
real pivotelement

originalX=X

do i=1,size
    do j=1,size
        if(i.EQ.j) then
            XI(i,j)=1
        else
            XI(i,j)=0 !this is for good measure coz by default, XI may have been changed by the caller itself though it is 0 by default
        endif
    end do
end do

do rowindex=1,size !loop over rows of X

    pivotelement=X(rowindex,rowindex) !this is crucial!

    !divide the row by pivot element
    do colindex=1,size
        X(rowindex,colindex)=X(rowindex,colindex)/pivotelement
    end do
    do colindex=1,size
        XI(rowindex,colindex)=XI(rowindex,colindex)/pivotelement
    end do

    !perform row operations to make non-pivot elements of this column zero
    do i=1,size !i gives the row number being manipulated
        pivotelement=X(i,rowindex) !pivot element for the currently manipulated row. this i crucial

        if(i.NE.rowindex) then !row operations are for non-current rows only

            do j=1,size !column index for ith row of X matrix
                X(i,j)=X(i,j)-pivotelement*X(rowindex,j)
            end do
            do j=1,size !column index for ith row of XI matrix
                XI(i,j)=XI(i,j)-pivotelement*XI(rowindex,j)
            end do

        endif
    end do

end do

!restore X to original X since upon inversion completion, X has been reduced to an Identity matrix. good practice
X=originalX

end subroutine