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

    Use Kinds, Only: dp
    Implicit None
    Private
    Public :: Romberg_Quad
    Public :: Composite_Quad
    Public :: Composite_Trapezoid
    Public :: Composite_Simpson
    Public :: Adaptive_Quad
    Public :: Adaptive_Trapezoid
    Public :: Adaptive_Simpson
    Public :: MidPoint_Quad
    Public :: Trapezoid_Quad
    Public :: Simpson_Quad
    Public :: GaussLegendre5
    Public :: GaussLegendre16
    Public :: GaussLegendre96
    Public :: GaussLegendreN
    Public :: Progressive_GaussLegendre

    Real(dp), Parameter :: one_third = 1._dp / 3._dp
    Real(dp), Parameter :: one_sixth = 1._dp / 6._dp
    Integer, Parameter :: bisect_limit = 53

    Interface Romberg_Quad
        Module Procedure Romb_Quad
        Module Procedure Romb_Quad_ranges
    End Interface

Contains

Function Romb_Quad_ranges(f,ab,aTol,rTol,p) Result(q)
    !Integrates f(x) on the intervals between entries in ab(:) by extrapolation on successive composite trapezoid
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: q  !the result of the integration
    Interface
        Function f(x)  !the function to be integrated
            Use Kinds,Only: dp
            Implicit None
            Real(dp) :: f
            Real(dp), Intent(In) :: x
        End Function f
    End Interface
    Real(dp), Intent(In) :: ab(:)  !list of limits of integration
    Real(dp), Intent(In) :: aTol,rTol  !absolute and relative tolerances for convergence
    Real(dp), Intent(Out), Optional :: p  !estimated precision achived in the final estimate
    Real(dp) :: h  !the total width of the integration window from ab(1) to ab(n)
    Real(dp) :: hi  !the width of the i-th integration window
    Integer :: n  !length of the list of integration limits, resulting in n-1 integrations to be performed
    Integer :: i  !loop counter
    Real(dp) :: p_i  !estimated precision of the integral from the i-th interval

    q = 0._dp
    n = Size(ab)
    h = ab(n) - ab(1)
    Do i = 1,n-1
        hi = ab(i+1) - ab(i)
        If (Present(p)) Then
            q = q + Romb_Quad(f,ab(i),ab(i+1),(hi/h)*aTol,rTol,p=p_i)
            p = Min(p,p_i)
        Else
            q = q + Romb_Quad(f,ab(i),ab(i+1),(hi/h)*aTol,rTol)
        End If
    End Do
End Function Romb_Quad_ranges

Function Romb_Quad(f,a,b,aTol,rTol,allow_GL_fallback,p,n_ord,n_ext) Result(q)
    !Integrates f(x) on (a,b) by extrapolation on successive composite trapezoid
    Use Kinds, Only: dp
    Use Utilities, Only: Converged
    Use Utilities, Only: Prec
    Implicit None
    Real(dp) :: q    !the result of the integration
    Interface
        Function f(x)    !the function to be integrated
            Use Kinds,Only: dp
            Implicit None
            Real(dp) :: f
            Real(dp), Intent(In) :: x
        End Function f
    End Interface
    Real(dp), Intent(In) :: a,b  !limits of integration
    Real(dp), Intent(In) :: aTol,rTol  !absolute and relative tolerances for convergence
    Logical, Intent(In), Optional :: allow_GL_fallback  !flag signaling whether fallback to progressive G-L should be used in the
                                                        !event of a failure to converge during extrapolation stages
    Real(dp), Intent(Out), Optional :: p  !estimated precision achived in the final estimate
    Integer, Intent(Out), Optional :: n_ord  !total number of function evaluations (ordinates)
    Integer, Intent(Out), Optional :: n_ext  !total number of extrapolation stages (rows in the table)
    Integer, Parameter :: Tmax = 21  !maximum number of extrapolations in the table
    Real(dp) :: T(0:Tmax)  !Extrapolation table previous row
    Real(dp) :: Tk0,Tk  !Extrapolation table current row values
    Integer :: i,j,k  !counters: i for table row, j for quadrature ordinates, k for table column
    Integer :: n      !number of intervals
    Real(dp) :: h0,h  !spacing between quadrature ordinates
    Real(dp) :: fk    !multiplier for extrapolation steps
    Real(dp) :: s     !sum of function values at quadrature ordinates
    Real(dp) :: Prec0 !precision of the previous extrapolation (used to monitor convergence)
    Integer :: ifin   !final number of extrapolations performed
    Logical :: GL_fallback
    !    If the preprocessor directive ROMB_TABLES is set at compile-time,
    ! then the tables of computed values are dumped to file in the working
    ! directory as the routine runs.
#   if ROMB_TABLES
        Integer :: unit
#   endif

    If (a .EQ. b) Then !zero-width interval for integration
        q = 0._dp
        If (Present(p)) p = Prec(0._dp,q)
        If (Present(n_ord)) n_ord = 0
        If (Present(n_ext)) n_ext = 0
        Return
    End If
    !Initial trapezoid estimate
    n = 1
    s = 0.5_dp * (f(a) + f(b))
    h0 = b - a
    T(0) = h0 * s
    Prec0 = -1._dp
#   if ROMB_TABLES
        Open(NEWUNIT=unit,FILE='Romb_Tables.tst',ACTION='WRITE',STATUS='UNKNOWN',POSITION='APPEND')
        Do k = 0,Tmax
            Write(unit,'(I24)',ADVANCE='NO') k
        End Do
        Write(unit,'(ES24.15)') T(0)
        Close(unit)
#   endif
    Do i = 1,Tmax !up to Tmax rows in the table
        !Trapezoid estimate for the 0-th column of the i-th row of table
        n = n * 2
        h = h0 / Real(n,dp)
        Do j = 1,n-1,2  !Odd values of j are NEW points at which to evaluate f
            s = s + f(a + Real(j,dp)*h)
        End Do
        Tk0 = h * s
        !Fill i-th row, columns k = 1:i, with extrapolated estimates
        fk = 1._dp
        Do k = 1,i  !up to i columns this row
            fk = fk * 4._dp
            Tk = (fk * Tk0 - T(k-1)) / (fk - 1._dp)
            If (k .LT. i) Then
                T(k-1) = Tk0  !store Tk0 for next i
                Tk0 = Tk  !store Tk for next k
            End If !otherwise, skip storage steps if working final column
        End Do
        !Check for convergence
        If (Converged(T(i-1),Tk,rTol=Real(2**k-1)*rTol,aTol=aTol)) Then
            q = Tk
#           if ROMB_TABLES
                T(i-1) = Tk0
                T(i) = Tk
                Open(NEWUNIT=unit,FILE='Romb_Tables.tst',ACTION='WRITE',STATUS='UNKNOWN',POSITION='APPEND')
                Do k = 0,i
                    Write(unit,'(ES24.15)',ADVANCE='NO') T(k)
                End Do
                Write(unit,'(A)') '*'
                Write(unit,*)
                Close(unit)
#           endif
            If (Present(p)) p = Prec(T(i-1),Tk)
            If (Present(n_ord)) n_ord = n
            If (Present(n_ext)) n_ext = i
            Return  !Normal exit
        Else  !Check for failures and prep for the next time though the loop
            !check for exit conditions other than convergence (failures)
            If (i .EQ. Tmax) Then  !extrapolation limit has been reached without convergence
                ifin = Tmax
                Exit
            Else If (i .GT. Tmax/2) Then
                If (Prec(T(i-1),Tk) .LT. Prec0) Then  !precision was LOST on this extrapolation, convergence will not occur
                    ifin = i
                    Exit
                End If
            End If
            !store Tk0 and Tk for next i, and update precision monitor
            Prec0 = Prec(T(i-1),Tk)
            T(i-1) = Tk0
            T(i) = Tk
#           if ROMB_TABLES
                Open(NEWUNIT=unit,FILE='Romb_Tables.tst',ACTION='WRITE',STATUS='UNKNOWN',POSITION='APPEND')
                Do k = 0,i
                    Write(unit,'(ES24.15)',ADVANCE='NO') T(k)
                End Do
                Write(unit,*)
                Close(unit)
#           endif
        End If
    End Do
    !If we get this far, we did not converge
    If (Present(allow_GL_fallback)) Then
        GL_fallback = allow_GL_fallback
    Else
        GL_fallback = .TRUE.
    End If
    If (GL_fallback) Then
        If (Present(p)) Then
            q = Progressive_GaussLegendre(f,a,b,aTol=aTol,rTol=rTol,n_start=5,n_stride=3,n_done=n,p=p)
        Else
            q = Progressive_GaussLegendre(f,a,b,aTol=aTol,rTol=rTol,n_start=5,n_stride=3,n_done=n)
        End If
        If (Present(n_ord)) n_ord = n
        If (Present(n_ext)) n_ext = -1
    Else
        Write(*,*)
        Write(*,'(A,I0,A)')          'WARNING:  Quadratures: Romberg_Quad:  Failed to converge in ',ifin,' extrapolations.'
        If (ifin .LT. Tmax) Then
            Write(*,'(A10,A)')              '','Extrapolation was terminated for loss of precision.'
        End If
        Write(*,'(A10,A,ES23.15E2,A,F0.5,A)') '','Final estimated value: ',Tk,' (~',Prec(T(ifin-1),Tk),' good digits)'
        Write(*,'(A10,A,2(ES10.3E2,A))')      '','Final Extrapolation Error: ',Abs(Tk-T(ifin-1)),   ' (abs), ', &
                                       &                                       Abs(Tk-T(ifin-1))/Tk,' (rel)'
        Write(*,'(A10,A,2(ES10.3E2,A))')      '','Convergence Criteria:      ',atol,                ' (abs), ', &
                                       &                                       rtol,                ' (rel)'
        q = Tk
#       if ROMB_TABLES
            T(i-1) = Tk0
            T(i) = Tk
            Open(NEWUNIT=unit,FILE='Romb_Tables.tst',ACTION='WRITE',STATUS='UNKNOWN',POSITION='APPEND')
            Do k = 0,i
                Write(unit,'(ES24.15)',ADVANCE='NO') T(k)
            End Do
            Write(unit,'(A)') '*'
            Write(unit,*)
            Close(unit)
#       endif
        If (Present(p)) p = Prec(T(ifin-1),Tk)
        If (Present(n_ord)) n_ord = n
        If (Present(n_ext)) n_ext = ifin
    End If
    ! ERROR STOP
    !Currently, no STOP is implemented for a failure to converge.  The result of the quadrature is set to the final value from the
    !Romberg table, and additional required values are set, and execution returns to the calling routine after the above warnings
    !are sent to the screen.
End Function Romb_Quad

Function Richardson_Extrapolation(fh,f2h,p) Result(r)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: r
    Real(dp), Intent(In) :: fh,f2h
    Integer, Intent(In) :: p

    r = ( fh*Real(2**p,dp) - f2h ) / Real(2**p-1,dp)
End Function Richardson_Extrapolation

Function Adaptive_Quad(f,a0,b0,Quad,aTol,rTol) Result(q)
    !Integrates f(x) on (a,b) by adaptively applying composite quadrature
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: q  !the result of the integration
    Interface
        Function f(x)  !the function to be integrated
            Use Kinds,Only: dp
            Implicit None
            Real(dp) :: f
            Real(dp), Intent(In) :: x
        End Function f
        Function Quad(f,a,b,p)  !the quadrature rule to use
            Use Kinds,Only: dp
            Implicit None
            Real(dp) :: Quad  !the result of the quadrature
            Interface
                Function f(x)    !the function to be integrated
                    Use Kinds,Only: dp
                    Implicit None
                    Real(dp) :: f
                    Real(dp), Intent(In) :: x
                End Function f
            End Interface
            Real(dp),Intent(In) :: a,b  !limits of integration
            Integer, Intent(Out), Optional :: p
        End Function Quad
    End Interface
    Real(dp), Intent(In) :: a0,b0  !limits of integration
    Real(dp), Intent(In) :: aTol,rTol  !absolute and relative tolerance to be used as criteria for convergence
    Integer :: n,i
    Real(dp), Allocatable :: s(:,:)
    integer, Allocatable :: sb(:)
    Real(dp) :: a,b,ab
    Real(dp) :: q0,q1,q2
    Real(dp) :: h
    Real(dp) :: rTol_per_h,aTol_per_h
    Real(dp) :: r,r0,dr
    Integer :: p
    Integer :: bisects

    n = 16
    i = 0
    Allocate(s(1:3,1:n))
    s = 0._dp
    Allocate(sb(1:n))
    sb = 0
    q0 = Quad(f,a0,b0,p=p)
    Call Put_s(a0,b0,q0,0)
    rTol_per_h = rTol * Real(2**p-1,dp)
    aTol_per_h = aTol / (b0 - a0)
    q = 0._dp
    Do
        If (Get_s(a,b,q0,bisects)) Then  !got an interval to do
            ab = 0.5_dp * (a + b)
            q1 = Quad(f,a,ab)
            q2 = Quad(f,ab,b)
            If (p .GT. 1) Then
                r = Richardson_Extrapolation(q1+q2,q0,p)
                r0 = q1 + q2
            Else
                r = q1 + q2
                r0 = q0
            End If
            h = b - a
            dr = Abs( r - r0 )
            If (      dr .LT. h * rTol_per_h    & !relative convergence
               & .OR. dr .LT. h * aTol_per_h    & !absolute convergence
               & .OR. bisects .GT. bisect_limit & !bisection limit exceeded
               &      ) Then
                q = q + r  !add to result of the quadrature
            Else  !add the subintervals to the list to be refined again
                Call Put_s(a,ab,q1,bisects+1)
                Call Put_s(ab,b,q2,bisects+1)
            End If
        Else !no intervals left to quadrature
            Exit
        End If
    End Do
Contains
    Subroutine Put_s(c1,c2,c3,bs)
        Use Kinds, Only: dp
        Implicit None
        Real(dp), Intent(In) :: c1,c2,c3
        Integer, Intent(In) :: bs
        Real(dp), Allocatable :: swaps(:,:)
        Integer, Allocatable :: swapsb(:)

        i = i + 1
        If (i .GT. n) Then !need more space
            Allocate(swaps(1:3,1:n))
            swaps = s
            Deallocate(s)
            Allocate(s(1:3,1:2*n))
            s = 0._dp
            s(:,1:n) = swaps
            Deallocate(swaps)
            Allocate(swapsb(1:n))
            swapsb = sb
            Deallocate(sb)
            Allocate(sb(1:2*n))
            sb = 0
            sb(1:n) = swapsb
            Deallocate(swapsb)
            n = n * 2
        End If
        s(:,i) = (/ c1 , c2 , c3 /)
        sb(i) = bs
    End Subroutine Put_s
    Function Get_s(c1,c2,c3,bs) Result(bingo)
        Use Kinds, Only: dp
        Implicit None
        Logical :: bingo
        Real(dp), Intent(Out) :: c1,c2,c3
        Integer, Intent(Out) :: bs

        If (i .LT. 1) Then !there was no s to get
            bingo = .FALSE.
        Else
            bingo = .TRUE.
            c1 = s(1,i)
            c2 = s(2,i)
            c3 = s(3,i)
            bs = sb(i)
            i = i - 1
        End If
    End Function Get_s
End Function Adaptive_Quad

Function Adaptive_Trapezoid(f,a0,b0,aTol,rTol) Result(q)
    !Integrates f(x) on (a,b) by adaptively applying composite trapezoid
    Use Kinds,Only: dp
    Implicit None
    Real(dp) :: q  !the result of the integration
    Interface
        Function f(x)  !the function to be integrated
            Use Kinds,Only: dp
            Implicit None
            Real(dp) :: f
            Real(dp), Intent(In) :: x
        End Function f
    End Interface
    Real(dp), Intent(In) :: a0,b0  !limits of integration
    Real(dp), Intent(In) :: aTol,rTol  !absolute and relative tolerance to be used as criteria for convergence
    Integer :: n,i
    Real(dp), Allocatable :: s(:,:)
    Integer, Allocatable :: sb(:)
    Real(dp) :: a,b,ab
    Real(dp) :: fa,fb,fab
    Real(dp) :: q0,q1,q2,r,dr
    Real(dp) :: h
    Real(dp) :: rTol_per_h,aTol_per_h
    Integer :: bisects

    n = 16
    i = 0
    Allocate(s(1:5,1:n))
    s = 0._dp
    Allocate(sb(1:n))
    sb = 0
    i = 0
    !Initial Trapezoid estimate
    fa = f(a0)
    fb = f(b0)
    q0 = (b0 - a0) * (fa + fb) * 0.5_dp
    Call Put_s(a0,b0,fa,fb,q0,0)
    rTol_per_h = rTol * 3._dp
    aTol_per_h = aTol / (b0 - a0)
    q = 0._dp
    Do
        If (Get_s(a,b,fa,fb,q0,bisects)) Then  !got an interval to do
            ab = 0.5_dp * (a + b)
            fab = f(ab)
            h = b - a
            q1 = 0.25_dp * h * (fa + fab)
            q2 = 0.25_dp * h * (fab + fb)
            r = Richardson_Extrapolation(q1+q2,q0,2)
            dr = Abs( q1 + q2 - r )
            If (      dr .LT. h * rTol_per_h    & !relative convergence
               & .OR. dr .LT. h * aTol_per_h    & !absolute convergence
               & .OR. bisects .GT. bisect_limit & !bisection limit exceeded
               &      ) Then
                q = q + r
            Else  !add the subintervals to the list to be quadratured
                Call Put_s(a,ab,fa,fab,q1,bisects+1)
                Call Put_s(ab,b,fab,fb,q2,bisects+1)
            End If
        Else !no intervals left to quadrature
            Exit
        End If
    End Do
Contains
      Subroutine Put_s(c1,c2,c3,c4,c5,bs)
        Use Kinds, Only: dp
        Implicit None
        Real(dp), Intent(In) :: c1,c2,c3,c4,c5
        Integer, Intent(In) :: bs
        Real(dp), Allocatable :: swaps(:,:)
        Integer, Allocatable :: swapsb(:)

        i = i + 1
        If (i .GT. n) Then !need more space
            Allocate(swaps(1:5,1:n))
            swaps = s
            Deallocate(s)
            Allocate(s(1:5,1:2*n))
            s = 0._dp
            s(:,1:n) = swaps
            Deallocate(swaps)
            Allocate(swapsb(1:n))
            swapsb = sb
            Deallocate(sb)
            Allocate(sb(1:2*n))
            sb = 0
            sb(1:n) = swapsb
            Deallocate(swapsb)
            n = n * 2
        End If
        s(:,i) = (/ c1 , c2 , c3 , c4, c5 /)
        sb(i) = bs
    End Subroutine Put_s
    Function Get_s(c1,c2,c3,c4,c5,bs) Result(bingo)
        Use Kinds, Only: dp
        Implicit None
        Logical :: bingo
        Real(dp), Intent(Out) :: c1,c2,c3,c4,c5
        Integer, Intent(Out) :: bs

        If (i .LT. 1) Then !there was no s to get
            bingo = .FALSE.
        Else
            bingo = .TRUE.
            c1 = s(1,i)
            c2 = s(2,i)
            c3 = s(3,i)
            c4 = s(4,i)
            c5 = s(5,i)
            bs = sb(i)
            i = i - 1
        End If
    End Function Get_s
End Function Adaptive_Trapezoid

Function Adaptive_Simpson(f,a0,b0,aTol,rTol) Result(q)
    !Integrates f(x) on (a,b) by adaptively applying composite Simpson
    Use Kinds,Only: dp
    Implicit None
    Real(dp) :: q  !the result of the integration
    Interface
        Function f(x)  !the function to be integrated
            Use Kinds,Only: dp
            Implicit None
            Real(dp) :: f
            Real(dp), Intent(In) :: x
        End Function f
    End Interface
    Real(dp), Intent(In) :: a0,b0  !limits of integration
    Real(dp), Intent(In) :: aTol,rTol  !absolute and relative tolerance to be used as criteria for convergence
    Integer :: n,i
    Real(dp), Allocatable :: s(:,:)
    Integer, Allocatable :: sb(:)
    Real(dp) :: x1,x2,x3,x4,x5
    Real(dp) :: y1,y2,y3,y4,y5
    Real(dp) :: q0,q1,q2,r,dr
    Real(dp) :: h
    Real(dp) :: rTol_per_h,aTol_per_h
    Integer :: bisects

    n = 16
    i = 0
    Allocate(s(1:7,1:n))
    s = 0._dp
    Allocate(sb(1:n))
    sb = 0
    i = 0
    !Initial Simpson estimate
    x3 = 0.5_dp * (a0 + b0)
    y1 = f(a0)
    y3 = f(x3)
    y5 = f(b0)
    q0 = (b0 - a0) * (y1 + 4._dp*y3 + y5) * one_sixth
    Call Put_s(a0,x3,b0,y1,y3,y5,q0,0)
    rTol_per_h = rTol * 15._dp
    aTol_per_h = aTol / (b0 - a0)
    q = 0._dp
    Do
        If (Get_s(x1,x3,x5,y1,y3,y5,q0,bisects)) Then  !got an interval to do
            x2 = 0.5_dp * (x1 + x3)
            x4 = 0.5_dp * (x3 + x5)
            y2 = f(x2)
            y4 = f(x4)
            q1 = (x3-x1) * (y1 + 4._dp*y2 + y3) * one_sixth
            q2 = (x5-x3) * (y3 + 4._dp*y4 + y5) * one_sixth
            r = Richardson_Extrapolation(q1+q2,q0,4)
            h = x5 - x1
            dr = Abs( q1 + q2 - r )
            If (      dr .LT. h * rTol_per_h    & !relative convergence
               & .OR. dr .LT. h * aTol_per_h    & !absolute convergence
               & .OR. bisects .GT. bisect_limit & !bisection limit exceeded
               &      ) Then
                q = q + r
            Else  !add the subintervals to the list to be quadratured
                Call Put_s(x1,x2,x3,y1,y2,y3,q1,bisects+1)
                Call Put_s(x3,x4,x5,y3,y4,y5,q2,bisects+1)
            End If
        Else !no intervals left to quadrature
            Exit
        End If
    End Do
Contains
      Subroutine Put_s(c1,c2,c3,c4,c5,c6,c7,bs)
        Use Kinds, Only: dp
        Implicit None
        Real(dp), Intent(In) :: c1,c2,c3,c4,c5,c6,c7
        Integer, Intent(In) :: bs
        Real(dp), Allocatable :: swaps(:,:)
        Integer, Allocatable :: swapsb(:)

        i = i + 1
        If (i .GT. n) Then !need more space
            Allocate(swaps(1:7,1:n))
            swaps = s
            Deallocate(s)
            Allocate(s(1:7,1:2*n))
            s = 0._dp
            s(:,1:n) = swaps
            Deallocate(swaps)
            Allocate(swapsb(1:n))
            swapsb = sb
            Deallocate(sb)
            Allocate(sb(1:2*n))
            sb = 0
            sb(1:n) = swapsb
            Deallocate(swapsb)
            n = n * 2
        End If
        s(:,i) = (/ c1 , c2 , c3 , c4, c5 , c6 , c7 /)
        sb(i) = bs
    End Subroutine Put_s
    Function Get_s(c1,c2,c3,c4,c5,c6,c7,bs) Result(bingo)
        Use Kinds, Only: dp
        Implicit None
        Logical :: bingo
        Real(dp), Intent(Out) :: c1,c2,c3,c4,c5,c6,c7
        Integer, Intent(Out) :: bs

        If (i .LT. 1) Then !there was no s to get
            bingo = .FALSE.
        Else
            bingo = .TRUE.
            c1 = s(1,i)
            c2 = s(2,i)
            c3 = s(3,i)
            c4 = s(4,i)
            c5 = s(5,i)
            c6 = s(6,i)
            c7 = s(7,i)
            bs = sb(i)
            i = i - 1
        End If
    End Function Get_s
End Function Adaptive_Simpson

Function Composite_Quad(f,a,b,Quad,aTol,rTol) Result(q)
    !Integrates f(x) on (a,b) by composite quadrature
    Use Kinds, Only: dp
    Use Utilities, Only: Converged
    Implicit None
    Real(dp) :: q    !the result of the integration
    Interface
        Function f(x)  !the function to be integrated
            Use Kinds, Only: dp
            Implicit None
            Real(dp) :: f
            Real(dp), Intent(In) :: x
        End Function f
        Function Quad(f,a,b,p)  !the quadrature rule to use
            Use Kinds, Only: dp
            Implicit None
            Real(dp) :: Quad  !the result of the quadrature
            Interface
                Function f(x)    !the function to be integrated
                    Use Kinds ,Only: dp
                    Implicit None
                    Real(dp) :: f
                    Real(dp), Intent(In) :: x
                End Function f
            End Interface
            Real(dp), Intent(In) :: a,b  !interval on which to apply the rule
            Integer, Intent(Out), Optional :: p
        End Function Quad
    End Interface
    Real(dp), Intent(In) :: a,b  !limits of integration
    Real(dp), Intent(In) :: aTol,rTol  !absolute and relative tolerance to be used as criteria for convergence
    Integer :: i,j,n
    Real(dp) :: h,h0
    Real(dp) :: q0,r,dr
    Real(dp) :: eps
    Integer :: p

    n = 1
    q0 = Quad(f,a,b,p=p)
    h0 = b - a
    eps = Real(2**p-1,dp) * h0 * rTol
    Do i = 1,bisect_limit+1  !max intervals is bounded by splitting interval bisect_limit+1 times
        q = 0._dp
        n = n * 2
        h = h0 / Real(n,dp)
        Do j = 1,n
            q = q + Quad(f , a+h*Real((j-1),dp) , a+h*Real(j,dp))
        End Do
        If (p .GT. 1) Then !apply a stage of Richardson extrapolation for a low-cost refinement of the estimate
            r = Richardson_Extrapolation(q,q0,p)
            dr = Abs( r - q )
            If (      dr .LT. eps  & !relative convergence
               & .OR. dr .LT. aTol & !absolute convergence
               &      ) Then
                q = r
                Return
            End If
        Else !Richardson extrapolation does not provide a benefit for methods with p<2 (i.e. Midpoint, etc.)
            If (Converged(q0,q,rTol=rTol,aTol=aTol)) Return
        End If
        q0 = q
    End Do
    !if we get this far, we failed to converge
    Write(*,'(A,I0,A)') 'ERROR:  Quadratures: Composite_Quad:  Failed to converge on ',n,' intervals.'
    ERROR STOP
End Function Composite_Quad

Function MidPoint_Quad(f,a,b,p) Result(q)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: q  !the result of the quadrature
    Interface
        Function f(x)  !the function to be integrated
            Use Kinds, Only: dp
            Implicit None
            Real(dp) :: f
            Real(dp), Intent(In) :: x
        End Function f
    End Interface
    Real(dp), Intent(In) :: a,b  !interval on which to apply the rule
    Integer, Intent(Out), Optional :: p

    q = (b - a) * f( 0.5_dp * (a + b) )
    If (Present(p)) p = 2
End Function MidPoint_Quad

Function Trapezoid_Quad(f,a,b,p) Result(q)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: q  !the result of the quadrature
    Interface
        Function f(x)  !the function to be integrated
            Use Kinds, Only: dp
            Implicit None
            Real(dp) :: f
            Real(dp), Intent(In) :: x
        End Function f
    End Interface
    Real(dp), Intent(In) :: a,b  !interval on which to apply the rule
    Integer, Intent(Out), Optional :: p

    q = 0.5_dp * (b - a) * ( f(a) + f(b) )
    If (Present(p)) p = 2
End Function Trapezoid_Quad

Function Simpson_Quad(f,a,b,p) Result(q)
    Use Kinds, Only: dp
    Implicit None
    Real(dp):: q  !the result of the quadrature
    Interface
        Function f(x)  !the function to be integrated
            Use Kinds, Only: dp
            Implicit None
            Real(dp) :: f
            Real(dp), Intent(In) :: x
        End Function f
    End Interface
    Real(dp), Intent(In) :: a,b  !interval on which to apply the rule
    Integer, Intent(Out), Optional :: p

    q = one_sixth * (b - a) * ( f(a) + 4._dp * f( 0.5_dp * (a + b) ) + f(b) )
    If (Present(p)) p = 4
End Function Simpson_Quad

Function Composite_Trapezoid(f,a,b,aTol,rTol) Result(q)
    !Integrates f(x) on (a,b) by composite trapezoid
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: q  !the result of the integration
    Interface
        Function f(x)  !the function to be integrated
            Use Kinds, Only: dp
            Implicit None
            Real(dp) :: f
            Real(dp), Intent(In) :: x
        End Function f
    End Interface
    Real(dp), Intent(In) :: a,b  !limits of integration
    Real(dp), Intent(In) :: aTol,rTol  !absolute and relative tolerance to be used as criteria for convergence
    Integer :: i,j,n
    Real(dp) :: h,h0
    Real(dp) :: q0,s
    Real(dp) :: r,dr
    Real(dp) :: eps

    n = 1
    s = 0.5_dp * ( f(a) + f(b) )
    h0 = b - a
    eps = 3._dp * h0 * rTol
    q0 = h0 * s
    Do i = 1,bisect_limit+1  !max intervals is bounded by splitting interval bisect_limit+1 times
        n = n * 2
        h = h0 / Real(n,dp)
        Do j = 1,n-1,2  !only odd values of j, these are the NEW points at which to evaluate f
            s = s + f( a + h*Real(j,dp) )
        End Do
        q = h * s
        r = Richardson_Extrapolation(q,q0,2)
        dr = Abs( r - q )
        If (      dr .LT. eps  & !relative convergence
           & .OR. dr .LT. aTol & !absolute convergence
           &      ) Then
             q = r
            Return
        End If
        q0 = q
    End Do
    !if we get this far, we failed to converge
    Write(*,'(A,I0,A)') 'ERROR:  Quadratures: Progressive_Trapezoid:  Failed to converge on ',n,' intervals.'
    ERROR STOP
End Function Composite_Trapezoid

Function Composite_Simpson(f,a,b,aTol,rTol) Result(q)
    !Integrates f(x) on (a,b) by composite Simpson
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: q  !the result of the integration
    Interface
        Function f(x)  !the function to be integrated
            Use Kinds, Only: dp
            Implicit None
            Real(dp) :: f
            Real(dp), Intent(In) :: x
        End Function f
    End Interface
    Real(dp), Intent(In) :: a,b  !limits of integration
    Real(dp), Intent(In) :: aTol,rTol  !absolute and relative tolerance to be used as criteria for convergence
    Integer :: i,j,n
    Real(dp) :: h,h0
    Real(dp) :: q0,s1,s2,s3
    Real(dp) :: r,dr,eps

    n = 2
    s1 = f(a) + f(b)
    s2 = 0._dp
    s3 = f( 0.5_dp * (a + b) )
    h0 = b - a
    eps = 15._dp * h0 * rTol
    q0 = one_sixth * h0 * (s1 + 4._dp*s3)
    Do i = 1,bisect_limit+1  !max intervals is bounded by splitting interval bisect_limit+1 times
        n = n * 2
        h = h0 / Real(n,dp)
        s2 = s2 + s3
        s3 = 0._dp
        Do j = 1,n-1,2  !only odd values of j, these are the NEW points at which to evaluate f
            s3 = s3 + f( a + h*Real(j,dp) )
        End Do
        q = one_third * h * (s1 + 2._dp*s2 + 4._dp*s3)
        r = Richardson_Extrapolation(q,q0,4)
        dr = Abs( r - q )
        If (      dr .LT. eps  & !relative convergence
           & .OR. dr .LT. aTol & !absolute convergence
           &      ) Then
             q = r
            Return
        End If
        q0 = q
    End Do
    !if we get this far, we failed to converge
    Write(*,'(A)') 'ERROR:  Quadratures: Progressive_Simpson:  Failed to converge on ',n,' intervals.'
    ERROR STOP
End Function Composite_Simpson

Function GaussLegendre(f,a,b,n,wi,xi) Result(q)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: q  !result of the quadrature
    Interface
        Function f(x)  !the function to integrate
            Use Kinds, Only: dp
            Implicit None
            Real(dp) :: f
            Real(dp), Intent(In) :: x
        End Function f
    End Interface
    Real(dp), Intent(In) :: a,b  !interval on which to apply the rule
    Integer, Intent(In) :: n
    Real(dp), Intent(In) :: wi(1:n),xi(1:n)
    Real(dp) :: c1,c2  !changes interval from (a,b) to (-1,1)
    Integer :: i
    Real(dp) :: fi(1:n)

    c1 = 0.5_dp * (b - a)
    c2 = 0.5_dp * (b + a)
    Do i = 1,n
        fi(i) = f(c1 * xi(i) + c2)
    End Do
    q = c1 * Dot_Product(wi,fi)
End Function GaussLegendre

Function GaussLegendre5(f,a,b) Result(q)
    Use Kinds, Only: dp
    Use GaussLegendre_w_a, Only: n => n005
    Use GaussLegendre_w_a, Only: wi => w005
    Use GaussLegendre_w_a, Only: xi => a005
    Implicit None
    Real(dp) :: q  !result of the quadrature
    Interface
        Function f(x)  !the function to integrate
            Use Kinds, Only: dp
            Implicit None
            Real(dp) :: f
            Real(dp), Intent(In) :: x
        End Function f
    End Interface
    Real(dp), Intent(In) :: a,b  !interval on which to apply the rule

    q = GaussLegendre(f,a,b,n,wi,xi)
End Function GaussLegendre5

Function GaussLegendre16(f,a,b) Result(q)
    Use Kinds, Only: dp
    Use GaussLegendre_w_a, Only: n => n016
    Use GaussLegendre_w_a, Only: wi => w016
    Use GaussLegendre_w_a, Only: xi => a016
    Implicit None
    Real(dp) :: q  !result of the quadrature
    Interface
        Function f(x)  !the function to integrate
            Use Kinds, Only: dp
            Implicit None
            Real(dp) :: f
            Real(dp), Intent(In) :: x
        End Function f
    End Interface
    Real(dp), Intent(In) :: a,b  !interval on which to apply the rule

    q = GaussLegendre(f,a,b,n,wi,xi)
End Function GaussLegendre16

Function GaussLegendre96(f,a,b) Result(q)
    Use Kinds, Only: dp
    Use GaussLegendre_w_a, Only: n => n096
    Use GaussLegendre_w_a, Only: wi => w096
    Use GaussLegendre_w_a, Only: xi => a096
    Implicit None
    Real(dp) :: q  !result of the quadrature
    Interface
        Function f(x)  !the function to integrate
            Use Kinds, Only: dp
            Implicit None
            Real(dp) :: f
            Real(dp), Intent(In) :: x
        End Function f
    End Interface
    Real(dp), Intent(In) :: a,b  !interval on which to apply the rule

    q = GaussLegendre(f,a,b,n,wi,xi)
End Function GaussLegendre96

Function GaussLegendreN(n,f,a,b,p) Result(q)
    Use Kinds, Only: dp
    Use GaussLegendre_w_a
    Implicit None
    Real(dp) :: q  !result of the quadrature
    Integer, Intent(In) :: n  !number of quadrature points
    Interface
        Function f(x)  !the function to integrate
            Use Kinds, Only: dp
            Implicit None
            Real(dp) :: f
            Real(dp), Intent(In) :: x
        End Function f
    End Interface
    Real(dp), Intent(In) :: a,b  !interval on which to apply the rule
    Integer, Intent(Out), Optional :: p
    Real(dp), Allocatable :: wi(:),ai(:)  !weights and abscissa

    Allocate(wi(1:n))
    Allocate(ai(1:n))
    Select Case (N)
        Case (1)
            wi = w001
            ai = a001
        Case (2)
            wi = w002
            ai = a002
        Case (3)
            wi = w003
            ai = a003
        Case (4)
            wi = w004
            ai = a004
        Case (5)
            wi = w005
            ai = a005
        Case (6)
            wi = w006
            ai = a006
        Case (7)
            wi = w007
            ai = a007
        Case (8)
            wi = w008
            ai = a008
        Case (9)
            wi = w009
            ai = a009
        Case (10)
            wi = w010
            ai = a010
        Case (11)
            wi = w011
            ai = a011
        Case (12)
            wi = w012
            ai = a012
        Case (13)
            wi = w013
            ai = a013
        Case (14)
            wi = w014
            ai = a014
        Case (15)
            wi = w015
            ai = a015
        Case (16)
            wi = w016
            ai = a016
        Case (17)
            wi = w017
            ai = a017
        Case (18)
            wi = w018
            ai = a018
        Case (19)
            wi = w019
            ai = a019
        Case (20)
            wi = w020
            ai = a020
        Case (21)
            wi = w021
            ai = a021
        Case (22)
            wi = w022
            ai = a022
        Case (23)
            wi = w023
            ai = a023
        Case (24)
            wi = w024
            ai = a024
        Case (25)
            wi = w025
            ai = a025
        Case (26)
            wi = w026
            ai = a026
        Case (27)
            wi = w027
            ai = a027
        Case (28)
            wi = w028
            ai = a028
        Case (29)
            wi = w029
            ai = a029
        Case (30)
            wi = w030
            ai = a030
        Case (31)
            wi = w031
            ai = a031
        Case (32)
            wi = w032
            ai = a032
        Case (33)
            wi = w033
            ai = a033
        Case (34)
            wi = w034
            ai = a034
        Case (35)
            wi = w035
            ai = a035
        Case (36)
            wi = w036
            ai = a036
        Case (37)
            wi = w037
            ai = a037
        Case (38)
            wi = w038
            ai = a038
        Case (39)
            wi = w039
            ai = a039
        Case (40)
            wi = w040
            ai = a040
        Case (41)
            wi = w041
            ai = a041
        Case (42)
            wi = w042
            ai = a042
        Case (43)
            wi = w043
            ai = a043
        Case (44)
            wi = w044
            ai = a044
        Case (45)
            wi = w045
            ai = a045
        Case (46)
            wi = w046
            ai = a046
        Case (47)
            wi = w047
            ai = a047
        Case (48)
            wi = w048
            ai = a048
        Case (49)
            wi = w049
            ai = a049
        Case (50)
            wi = w050
            ai = a050
        Case (51)
            wi = w051
            ai = a051
        Case (52)
            wi = w052
            ai = a052
        Case (53)
            wi = w053
            ai = a053
        Case (54)
            wi = w054
            ai = a054
        Case (55)
            wi = w055
            ai = a055
        Case (56)
            wi = w056
            ai = a056
        Case (57)
            wi = w057
            ai = a057
        Case (58)
            wi = w058
            ai = a058
        Case (59)
            wi = w059
            ai = a059
        Case (60)
            wi = w060
            ai = a060
        Case (61)
            wi = w061
            ai = a061
        Case (62)
            wi = w062
            ai = a062
        Case (63)
            wi = w063
            ai = a063
        Case (64)
            wi = w064
            ai = a064
        Case (65)
            wi = w065
            ai = a065
        Case (66)
            wi = w066
            ai = a066
        Case (67)
            wi = w067
            ai = a067
        Case (68)
            wi = w068
            ai = a068
        Case (69)
            wi = w069
            ai = a069
        Case (70)
            wi = w070
            ai = a070
        Case (71)
            wi = w071
            ai = a071
        Case (72)
            wi = w072
            ai = a072
        Case (73)
            wi = w073
            ai = a073
        Case (74)
            wi = w074
            ai = a074
        Case (75)
            wi = w075
            ai = a075
        Case (76)
            wi = w076
            ai = a076
        Case (77)
            wi = w077
            ai = a077
        Case (78)
            wi = w078
            ai = a078
        Case (79)
            wi = w079
            ai = a079
        Case (80)
            wi = w080
            ai = a080
        Case (81)
            wi = w081
            ai = a081
        Case (82)
            wi = w082
            ai = a082
        Case (83)
            wi = w083
            ai = a083
        Case (84)
            wi = w084
            ai = a084
        Case (85)
            wi = w085
            ai = a085
        Case (86)
            wi = w086
            ai = a086
        Case (87)
            wi = w087
            ai = a087
        Case (88)
            wi = w088
            ai = a088
        Case (89)
            wi = w089
            ai = a089
        Case (90)
            wi = w090
            ai = a090
        Case (91)
            wi = w091
            ai = a091
        Case (92)
            wi = w092
            ai = a092
        Case (93)
            wi = w093
            ai = a093
        Case (94)
            wi = w094
            ai = a094
        Case (95)
            wi = w095
            ai = a095
        Case (96)
            wi = w096
            ai = a096
        Case (97)
            wi = w097
            ai = a097
        Case (98)
            wi = w098
            ai = a098
        Case (99)
            wi = w099
            ai = a099
        Case (100)
            wi = w100
            ai = a100
        Case (101)
            wi = w101
            ai = a101
        Case (102)
            wi = w102
            ai = a102
        Case (103)
            wi = w103
            ai = a103
        Case (104)
            wi = w104
            ai = a104
        Case (105)
            wi = w105
            ai = a105
        Case (106)
            wi = w106
            ai = a106
        Case (107)
            wi = w107
            ai = a107
        Case (108)
            wi = w108
            ai = a108
        Case (109)
            wi = w109
            ai = a109
        Case (110)
            wi = w110
            ai = a110
        Case (111)
            wi = w111
            ai = a111
        Case (112)
            wi = w112
            ai = a112
        Case (113)
            wi = w113
            ai = a113
        Case (114)
            wi = w114
            ai = a114
        Case (115)
            wi = w115
            ai = a115
        Case (116)
            wi = w116
            ai = a116
        Case (117)
            wi = w117
            ai = a117
        Case (118)
            wi = w118
            ai = a118
        Case (119)
            wi = w119
            ai = a119
        Case (120)
            wi = w120
            ai = a120
        Case (121)
            wi = w121
            ai = a121
        Case (122)
            wi = w122
            ai = a122
        Case (123)
            wi = w123
            ai = a123
        Case (124)
            wi = w124
            ai = a124
        Case (125)
            wi = w125
            ai = a125
        Case (126)
            wi = w126
            ai = a126
        Case (127)
            wi = w127
            ai = a127
        Case (128)
            wi = w128
            ai = a128
        Case (129)
            wi = w129
            ai = a129
        Case (130)
            wi = w130
            ai = a130
        Case (131)
            wi = w131
            ai = a131
        Case (132)
            wi = w132
            ai = a132
        Case (133)
            wi = w133
            ai = a133
        Case (134)
            wi = w134
            ai = a134
        Case (135)
            wi = w135
            ai = a135
        Case (136)
            wi = w136
            ai = a136
        Case (137)
            wi = w137
            ai = a137
        Case (138)
            wi = w138
            ai = a138
        Case (139)
            wi = w139
            ai = a139
        Case (140)
            wi = w140
            ai = a140
        Case (141)
            wi = w141
            ai = a141
        Case (142)
            wi = w142
            ai = a142
        Case (143)
            wi = w143
            ai = a143
        Case (144)
            wi = w144
            ai = a144
        Case (145)
            wi = w145
            ai = a145
        Case (146)
            wi = w146
            ai = a146
        Case (147)
            wi = w147
            ai = a147
        Case (148)
            wi = w148
            ai = a148
        Case (149)
            wi = w149
            ai = a149
        Case (150)
            wi = w150
            ai = a150
        Case Default
            Write(*,'(A,I0)') 'ERROR:  Quadratures: GaussLegendreN:  Unsupported N, n = ',N
            ERROR STOP
    End Select
    q = GaussLegendre(f,a,b,n,wi,ai)
    If (Present(p)) p = 2*n - 1
End Function GaussLegendreN

Function Progressive_GaussLegendre(f,a,b,aTol,rTol,n_start,n_stride,n_done,p) Result(q)
    !Integrates f(x) on (a,b) by successive quadrature via Gauss-Legendre n-point rules
    Use Kinds, Only: dp
    Use Utilities, Only: Converged
    Use Utilities, Only: Prec
    Implicit None
    Real(dp) :: q  !result of the integration
    Interface
        Function f(x)  !the function to be integrated
            Use Kinds, Only: dp
            Implicit None
            Real(dp) :: f
            Real(dp), Intent(In) :: x
        End Function
    End Interface
    Real(dp), Intent(In) :: a,b  !limits of integration
    Real(dp), Intent(In) :: aTol,rTol  !absolute and relative tolerance to be used as criteria for convergence
    Integer, Intent(In), Optional :: n_start,n_stride
    Integer, Intent(Out), Optional :: n_done
    Real(dp), Intent(Out), Optional :: p
    Real(dp) :: q0
    Integer :: n,dn
    Integer :: i

    If (Present(n_start)) Then
        n = n_start
    Else
        n = 1
    End If
    If (Present(n_stride)) Then
        dn = n_stride
    Else
        dn = 1
    End If
    q0 = GaussLegendreN(n,f,a,b)
    Do i = n+dn,150,dn !Gauss-Legendre weights and abscissa are available up to 150 points
        q = GaussLegendreN(i,f,a,b)
        If (Converged(q,q0,rTol=rTol,aTol=aTol)) Then
            If (Present(n_done)) n_done = i
            If (Present(p)) Then
                If (i .LT. 150) Then !progress one more stage of GL points to estimate precision
                    q0 = q
                    q = GaussLegendreN(i+1,f,a,b)
                    p = Prec(q0,q)
                Else
                    p = Prec(q0,q)
                End If
            End If
            RETURN !NORMAL EXIT
        End If
        q0 = q
    End Do
    !If we get this far, we failed to converge on 150-point Gauss
    q0 = GaussLegendreN(149,f,a,b) !regress one stage of GL points to estimate precision
    Write(*,*)
    Write(*,'(A,I0,A)') 'WARNING:  Quadratures: Progressive_GaussLegendre:  Failed to converge with ',150,' Gauss-points.'
    Write(*,'(A10,A,ES23.15E2,A,F0.5,A)') '','Final estimated value: ',q,' (~',Prec(q,q0),' good digits)'
    Write(*,'(A10,A,2(ES10.3E2,A))')      '','Final estimated error:     ',Abs(q-q0),  ' (abs), ', &
                                   &                                       Abs(q-q0)/q,' (rel)'
    Write(*,'(A10,A,2(ES10.3E2,A))')      '','Convergence Criteria:      ',atol,       ' (abs), ', &
                                   &                                       rtol,       ' (rel)'
    If (Present(n_done)) n_done = -1
    If (Present(p)) p = Prec(q0,q)
    ! ERROR STOP
    !Currently, no STOP is implemented for a failure to converge.  The result of the quadrature is set to the final value from the
    !quadrature, and additional required values are set, and execution returns to the calling routine after the above warnings
    !are sent to the screen.
End Function Progressive_GaussLegendre

End Module Quadratures


module fcn_radius
    use mod_kinds,      only: rk,ik
    use type_function,  only: function_t
    use type_point,     only: point_t
    implicit none
    private

    !>  Radius function
    !!
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/1/2016
    !!
    !---------------------------------------------------------------------------------
    type, extends(function_t), public :: radius_f

    contains

        procedure   :: init
        procedure   :: compute

    end type radius_f
    !**********************************************************************************

contains

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/2/2016
    !!
    !-------------------------------------------------------------------------
    subroutine init(self)
        class(radius_f),  intent(inout)    :: self

        !
        ! Set function name
        !
        call self%set_name("Radius")

        !
        ! Set function options to default settings
        !

    end subroutine init
    !*************************************************************************

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/2/2016
    !!
    !!
    !---------------------------------------------------------------------------------
    impure elemental function compute(self,time,coord) result(val)
        class(radius_f),   intent(inout)  :: self
        real(rk),       intent(in)  :: time
        type(point_t),  intent(in)  :: coord

        real(rk)                    :: val

        ! r = sqrt(x*x + y*y + z*z)
        val = sqrt(coord%c1_*coord%c1_ + coord%c2_*coord%c2_  + coord%c3_*coord%c3_)

    end function compute
    !**********************************************************************************

end module fcn_radius


program tarefab
    implicit real(8) (a-h,o-z)
    character(70) filename
    dimension v0(2), gama0(2)

    v0 = (/0.0, 10.0/)
    gama0 = (/0.1, 0.01/)

    do i = 1, 2
        do j = 1, 2

            ! Parametros iniciais
            e = 0.001           ! Incremento temporal
            g = 10e0            ! Gravidade
            gama = gama0(j)     ! resistência do ar gamma
            a = -g              ! Aceleração
            r = 100e0           ! Posição
            v = v0(i)           ! Velocidade
            t = 0e0             ! Tempo

            write(filename,'(A,2(I0,A))') 'saida-b-v',i,'-g',j,'-10407962.dat'

            open(10, file=filename)

            do while (r.ge.0)
                write(10, '(F0.6,2(" ",F0.6))') t, r, v
                a = -g -gama*v
                v = v + e*a/2
                r = r + e*v
                t = t + e
            end do

            close(10)
        end do
    end do

end program tarefab


      subroutine mkspl3pb(fun,x,nx,th,nth,ph,nph,fspl,nf4,nf5,
     >   ibcxmin,bcxmin,ibcxmax,bcxmax,nb1,
     >   wk,inwk,ilinx,ilinth,ilinph,ier)
C
C  create a tricubic biperiodic spline with knots at grid points and
C  function values from the callable function `fun' passed.
C
C  use tpsplinb to setup the spline coefficients
C
C  periodic boundary condition for theta & phi grids.
C  boundary condition data may be specified at x(1) and x(nx) for each
C  theta & phi:
C     ibcxmin=0 ==> "not a knot" boundary condition, cf cubspl.for
C     ibcxmin=1 ==> match slope, bcxmin(ith,iph) gives df/dx at
C         x(1),th(ith),ph(iph)
C     ibcxmin=2 ==> match 2nd derivative, given at x(1),th(ith),ph(iph)
C          by bcxmin(ith,iph)
C
C     ibcxmax,bcxmax have analogous interpretation -- at x(nx).
C
      external fun                      ! passed real function(x,th)
      real x(nx)                        ! x coordinate array
      real th(nth)                      ! th coordinate array
      real ph(nph)                      ! ph coordinate array
C
      real fspl(4,4,4,nf4,nf5,nph)      ! function data / spline coeff array
      real wk(inwk)                     ! workspace for bpsplinb
C
      integer ibcxmin                   ! boundary condition indicator
      real bcxmin(nb1,nph)              ! boundary condition data
      integer ibcxmax                   ! boundary condition indicator
      real bcxmax(nb1,nph)              ! boundary condition data
C
      integer ilinx                     ! output =1 if x(...) evenly spaced
      integer ilinth                    ! output =1 if th(...) evenly spaced
      integer ilinph                    ! output =1 if ph(...) evenly spaced
C
      integer ier                       ! completion code from bpspline
C
C----------------------------
C
      ier=0
      if(nf4.lt.nx) then
         write(6,'('' ?mkspl3pb -- array dim error, nf4 .lt. nx'')')
         ier=1
      endif
      if(nf5.lt.nth) then
         write(6,'('' ?mkspl3pb -- array dim error, nf5 .lt. nth'')')
         ier=2
      endif
      if(nb1.lt.nth) then
         write(6,'('' ?mkspl3pb -- array dim error, nb1 .lt. nth'')')
         ier=3
      endif
      if(inwk.lt.5*max(nx,nth,nph)) then
         write(6,'('' ?mkspl3pb -- array dim error, inwk too small'')')
         ier=4
      endif

      if(ier.ne.0) return
C
      do iph=1,nph
         do ith=1,nth
            do ix=1,nx
               fspl(1,1,1,ix,ith,iph)=fun(x(ix),th(ith),ph(iph))
            enddo
         enddo
      enddo
C
      call tpsplinb(x,nx,th,nth,ph,nph,fspl,nf4,nf5,
     >   ibcxmin,bcxmin,ibcxmax,bcxmax,nb1,
     >   wk,inwk,ilinx,ilinth,ilinph,ier)
C
      return
      end


MODULE m_sointg
  !*********************************************************************
  !     compute radial spin-orbit integrant
  !*********************************************************************
CONTAINS
  SUBROUTINE sointg(ntyp,e,vr,v0,atoms,input, vso)
    !
    USE m_differentiate,ONLY:diff3
    USE m_constants,ONLY: c_light
    USE m_types
    IMPLICIT NONE

    TYPE(t_input),INTENT(IN)   :: input
    TYPE(t_atoms),INTENT(IN)   :: atoms
    !     ..
    !     .. Scalar Arguments ..
    INTEGER,INTENT(IN)   :: ntyp
    REAL,    INTENT (IN) :: e
    !     ..
    !     .. Array Arguments ..
    REAL, INTENT (IN)  ::  v0(atoms%jri(ntyp))
    REAL, INTENT (IN)  ::  vr(atoms%jmtd,input%jspins)
    REAL, INTENT (OUT) :: vso(atoms%jmtd,2)
    !     ..
    !     .. Local Scalars ..
    REAL dr,dxv,r,cin2
    INTEGER i,jspin
    !     ..
    !     .. Local Arrays ..
    REAL dv(atoms%jri(ntyp)),xmrel(atoms%jri(ntyp))
    !     ..
    !     ..
    cin2 = 1.0/c_light(1.0)**2
    dr = EXP(atoms%dx(ntyp))
    r = atoms%rmsh(1,ntyp)
    !
    !---> relativistic mass:
    DO i = 1,atoms%jri(ntyp)
       xmrel(i) = 1. + (e-v0(i)/r)/2.*cin2
       r = r*dr
    END DO
    !---> potential derivative (on logarithmic mesh) : v0 := r*v

    CALL diff3(vr(:atoms%jri(ntyp),1),atoms%dx(ntyp),dv)
    !
    r = atoms%rmsh(1,ntyp)
    DO i = 1,atoms%jri(ntyp)
       dxv = (dv(i) - vr(i,1))/(r**3)
       vso(i,2) = cin2*dxv/(4.*xmrel(i)**2)
       r = r*dr
    END DO

    IF (input%jspins.EQ.2) THEN
       CALL diff3(vr(:atoms%jri(ntyp),input%jspins),atoms%dx(ntyp), dv)
       !
       r = atoms%rmsh(1,ntyp)
       DO i = 1,atoms%jri(ntyp)
          dxv = (dv(i) - vr(i,input%jspins))/(r**3)
          vso(i,1) = cin2*dxv/(4.*xmrel(i)**2)
          r = r*dr
       END DO
    ELSE
       DO i = 1,atoms%jri(ntyp)
          vso(i,1) =  vso(i,2)
       END DO
    ENDIF

  END SUBROUTINE sointg
END MODULE m_sointg


program simulation
	implicit none

	real(kind = 8), allocatable :: phobos(:)
	real(kind = 8), allocatable :: deimos(:)
	real(kind = 8) :: tmax, dt, tInitial
	real(kind = 8) :: initialVelocity

  real(kind = 8), parameter :: normalizedGravityPhobos = 4.28871 * (10**7)*(10**6)
  real(kind = 8), parameter :: normalizedGravityDeimos = 4.2839 * (10**7)*(10**6)

	! Set general intial conditions
	tInitial = 0.0d0
	dt = 1.0d0

	! Set phobos inital conditions
	allocate(phobos(4))
	phobos(1) = 9378000d0	! initial x-coordinate
	phobos(2) = 0.0d0	! initial y-coordinate
	phobos(3) = 0.0d0	! initial x-velocity (vy)
	phobos(4) = initialVelocity(normalizedGravityPhobos, phobos(1))	! initial y-velocity (vy)

	! Set deimos inital conditions
	allocate(deimos(4))
	deimos(1) = 23459000	! initial x-coordinate
	deimos(2) = 0.0d0	! initial y-coordinate
	deimos(3) = 0.0d0	! initial x-velocity (vy)
	deimos(4) = initialVelocity(normalizedGravityDeimos, deimos(1))	! initial y-velocity (vy)

	! open a files for output
	open(unit = 10, file = 'phobos.dat', status = 'unknown')
	open(unit = 20, file = 'phobos-energy.dat', status = 'unknown')
	open(unit = 30, file = 'deimos.dat', status = 'unknown')
	open(unit = 40, file = 'deimos-energy.dat', status = 'unknown')

  call calculateOrbit(phobos(1), phobos(2), phobos(3), phobos(4), 27553.824d0, dt, normalizedGravityPhobos, 10, 20)
	call calculateOrbit(deimos(1), deimos(2), deimos(3), deimos(4), 109074.816d0, dt, normalizedGravityDeimos, 30, 40)

	close(unit = 10)
	close(unit = 20)
	close(unit = 30)
	close(unit = 40)

	stop
end program simulation

function initialVelocity(normalizedGravity, moonSemiMajorAxis)
	implicit none

	real(kind = 8), intent(in) :: normalizedGravity
	real(kind = 8), intent(in) :: moonSemiMajorAxis
	real(kind = 8) :: initialVelocity

	initialVelocity = sqrt(normalizedGravity / moonSemiMajorAxis)

	return
end function

subroutine calculateOrbit(y1, y2, y3, y4, tmax, dt, gravity, posFileUnit, energyFileUnit)
	implicit none

	integer :: num_eqns ! Number of equations
	integer :: i

	real(kind = 8), intent(in) :: y1, y2, y3, y4
	real(kind = 8), allocatable :: y(:)
	real(kind = 8) :: t
	real(kind = 8) :: energy
	real(kind = 8) :: kinetic
	real(kind = 8) :: potential
	real(kind = 8), intent(in) :: tmax, dt
	integer, intent(in) :: posFileUnit, energyFileUnit
	real(kind = 8), intent(in) :: gravity

	real(kind = 8), allocatable :: f1(:), f2(:), f3(:), f4(:) ! y1
	real(kind = 8), allocatable :: rhs(:) ! r.h.s

	! # of equations
	num_eqns = 4

	! allocate arrays to correct size
	allocate(y(num_eqns))
	allocate(rhs(num_eqns))
	allocate(f1(num_eqns))
	allocate(f2(num_eqns))
	allocate(f3(num_eqns))
	allocate(f4(num_eqns))

	! set initial conditions
	y(1) = y1	! initial x-coordinate
	y(2) = y2	! initial y-coordinate
	y(3) = y3	! initial x-velocity (vy)
	y(4) = y4	! initial y-velocity (vy)
	t = 0.0d0

	! integrate forward in time
	do while (t <= tmax)
		! evaluate right-hand-side of ODEs
		call rhs_eqns(t, y, rhs, gravity)
		f1 = dt * rhs ! apply first step

		! evaluate right-hand-side at midpoint (Q2)
		call rhs_eqns(t + (0.5d0 * dt), y + (0.5d0 * f1), rhs, gravity)
		f2 = dt * rhs ! apply second step

		! evaluate the right-hand-side at Q1
		call rhs_eqns(t + (0.5d0 * dt), y + (0.5d0 * f2), rhs, gravity)
		f3 = dt * rhs ! apply third step

		! evaluate the right-hand-side at Q3
		call rhs_eqns(t + dt, y + f3, rhs, gravity)
		f4 = dt * rhs ! apply fourth step

		y = y + ((f1 + f4) / 2 + (f2 + f3)) / 3
		t = t + dt	! increment time

		! calculate system energy
    kinetic = 0.5d0 * (y3**2 + y4**2)
    potential = gravity * sqrt(y1**2 + y2**2)
    energy = potential + kinetic

		! write out the results
		write(posFileUnit, *) y(1), y(2)
    write(energyFileUnit, *) t, energy
	end do

	return
end subroutine calculateOrbit

! return the right-hand-side (rhs) of our eqns
subroutine rhs_eqns(t, y0, rhs, gravity)
	implicit none

	real(kind = 8), intent(in) :: t, y0(4)
	real(kind = 8), intent(out) :: rhs(4)
	real(kind = 8) x, y, vx, vy

	! constants normalized
	real(kind = 8), intent(in) :: gravity

	! intialize vectors
	x = y0(1)
	y = y0(2)
	vx = y0(3)
	vy = y0(4)

	! r.h.s of x-position equations
	rhs(1) = vx

	! r.h.s of y-position equations
	rhs(2) = vy

	! r.h.s of x-velocity equations
	rhs(3) = -gravity * x / (x**2 + y**2)**1.5d0

	! r.h.s of y-velocity equations
	rhs(4) = -gravity * y / (x**2 + y**2)**1.5d0
end subroutine rhs_eqns


program test

  ! use mo_moment
  USE mo_kind         , ONLY: i4, sp, dp
  USE mo_errorMeasures, ONLY: BIAS, KGE, LNNSE, MAE, MSE, NSE, RMSE, SAE, SSE
  use mo_ansi_colors, only: color, c_red, c_green
  !
  IMPLICIT NONE
  !
  INTEGER(i4)                 :: i, j, k
  REAL(dp), DIMENSION(54)     :: vec1, vec2
  REAL(dp), DIMENSION(9,6,8)  :: arr1, arr2
  LOGICAL,  DIMENSION(54)     :: maskvec
  LOGICAL,  DIMENSION(9,6,8)  :: mask
  LOGICAL                     :: isgood
  real(dp)                    :: stmp
  real(dp)                    :: dtmp

  write(*,*) ''
  write(*,*) 'Test mo_errormeasures.f90'
  !
  ! read random mask - shape = (6,9,5)
  !open(unit=20, file='field_maskf90.dat', action='read', status='old')
  open(unit=20, file='field_maskf90.dat', action='read', status='old')
  do k = 1, size(arr1, dim=3)
     do i = 1, size(arr1, dim=1)
        read(20,*) (mask(i,j,k), j=1, size(arr1, dim=2))
     end do
  end do
  close(20)
  ! read random number array - shape = (6,9,5)
  !open(unit=20, file='field.dat', action='read', status='old')
  open(unit=20, file='field.dat', action='read', status='old')
  do k = 1, size(arr1, dim=3)
     do i = 1, size(arr1, dim=1)
        read(20,*) (arr1(i,j,k), j=1, size(arr1, dim=2))
     end do
     arr2(:,:,k) = arr1(:,:,k) + real(k, dp) / 5.0_dp
  end do
  close(20)
  !
  ! create example for 1D
  vec1     = reshape(arr1(:,:,1), (/size(arr1, dim=1)*size(arr1, dim=2)/))
  vec2     = reshape(arr1(:,:,2), (/size(arr1, dim=1)*size(arr1, dim=2)/))
  maskvec  = reshape(mask(:,:,1), (/size(mask, dim=1)*size(mask, dim=2)/))
  !
  isgood = .TRUE.
  !
  ! Test masked arrays (sp / dp, 1D / 2D / 3D)
  ! BIAS
  stmp = BIAS(real(vec1, sp), real(vec2, sp), mask=maskvec)
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. 14353)
  dtmp = BIAS(vec1, vec2, mask=maskvec)
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. 14353)
  stmp = BIAS(real(arr1(:,:,1), sp), real(arr2(:,:,4), sp), mask=mask(:,:,1))
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. 20813)
  dtmp = BIAS(arr1(:,:,1), arr2(:,:,4), mask=mask(:,:,1))
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. 20813)
  stmp = BIAS(real(arr1, sp), real(arr2, sp), mask=mask)
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. 9097)
  dtmp = BIAS(arr1, arr2, mask=mask)
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. 9097)
  ! KGE
  stmp = KGE(real(vec1, sp), real(vec2, sp), mask=maskvec)
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. 1783)
  dtmp = KGE(vec1, vec2, mask=maskvec)
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. 1783)
  stmp = KGE(real(arr1(:,:,1), sp), real(arr2(:,:,4), sp), mask=mask(:,:,1))
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. -4730)
  dtmp = KGE(arr1(:,:,1), arr2(:,:,4), mask=mask(:,:,1))
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. -4730)
  stmp = KGE(real(arr1, sp), real(arr2, sp), mask=mask)
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. 7631)
  dtmp = KGE(arr1, arr2, mask=mask)
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. 7631)
  ! MAE
  stmp = MAE(real(vec1, sp), real(vec2, sp), mask=maskvec)
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. 16123)
  dtmp = MAE(vec1, vec2, mask=maskvec)
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. 16123)
  stmp = MAE(real(arr1(:,:,1), sp), real(arr2(:,:,4), sp), mask=mask(:,:,1))
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. &
           21134)
  dtmp = MAE(arr1(:,:,1), arr2(:,:,4), mask=mask(:,:,1))
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. 21134)
  stmp = MAE(real(arr1, sp), real(arr2, sp), mask=mask)
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. 9097)
  dtmp = MAE(arr1, arr2, mask=mask)
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. 9097)
  ! MSE
  stmp = MSE(real(vec1, sp), real(vec2, sp), mask=maskvec)
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. 42183)
  dtmp = MSE(vec1, vec2, mask=maskvec)
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. 42183)
  stmp = MSE(real(arr1(:,:,1), sp), real(arr2(:,:,4), sp), mask=mask(:,:,1))
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. 56920)
  dtmp = MSE(arr1(:,:,1), arr2(:,:,4), mask=mask(:,:,1))
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. 56920)
  stmp = MSE(real(arr1, sp), real(arr2, sp), mask=mask)
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. 10287)
  dtmp = MSE(arr1, arr2, mask=mask)
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. 10287)
  ! NSE
  stmp = NSE(real(vec1, sp), real(vec2, sp), mask=maskvec)
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. -23368)
  dtmp = NSE(vec1, vec2, mask=maskvec)
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. -23368)
  stmp = NSE(real(arr1(:,:,1), sp), real(arr2(:,:,4), sp), mask=mask(:,:,1))
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. -35026)
  dtmp = NSE(arr1(:,:,1), arr2(:,:,4), mask=mask(:,:,1))
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. -35026)
  stmp = NSE(real(arr1, sp), real(arr2, sp), mask=mask)
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. 8164)
  dtmp = NSE(arr1, arr2, mask=mask)
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. 8164)
  ! SAE
  stmp = SAE(real(vec1, sp), real(vec2, sp), mask=maskvec)
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. 403063)
  dtmp = SAE(vec1, vec2, mask=maskvec)
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. 403063)
  stmp = SAE(real(arr1(:,:,1), sp), real(arr2(:,:,4), sp), mask=mask(:,:,1))
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. 528359)
  dtmp = SAE(arr1(:,:,1), arr2(:,:,4), mask=mask(:,:,1))
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. 528359)
  stmp = SAE(real(arr1, sp), real(arr2, sp), mask=mask)
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. 2055999)
  dtmp = SAE(arr1, arr2, mask=mask)
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. 2056000)
  ! SSE
  stmp = SSE(real(vec1, sp), real(vec2, sp), mask=maskvec)
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. 1054575)
  dtmp = SSE(vec1, vec2, mask=maskvec)
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. 1054575)
  stmp = SSE(real(arr1(:,:,1), sp), real(arr2(:,:,4), sp), mask=mask(:,:,1))
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. 1423003)
  dtmp = SSE(arr1(:,:,1), arr2(:,:,4), mask=mask(:,:,1))
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. 1423003)
  stmp = SSE(real(arr1, sp), real(arr2, sp), mask=mask)
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. 2324799)
  dtmp = SSE(arr1, arr2, mask=mask)
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. 2324800)
  ! RMSE
  stmp = RMSE(real(vec1, sp), real(vec2, sp), mask=maskvec)
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. 20538)
  dtmp = RMSE(vec1, vec2, mask=maskvec)
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. 20538)
  stmp = RMSE(real(arr1(:,:,1), sp), real(arr2(:,:,4), sp), mask=mask(:,:,1))
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. 23858)
  dtmp = RMSE(arr1(:,:,1), arr2(:,:,4), mask=mask(:,:,1))
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. 23858)
  stmp = RMSE(real(arr1, sp), real(arr2, sp), mask=mask)
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. 10142)
  dtmp = RMSE(arr1, arr2, mask=mask)
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. 10142)
  !
  ! LNNSE
  ! Attention masks might have changed since inout
  !
  stmp = LNNSE(real(vec1, sp), real(vec2, sp), mask=maskvec)
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. -8993)
  dtmp = LNNSE(vec1, vec2, mask=maskvec)
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. -8993)
  stmp = LNNSE(real(arr1(:,:,1), sp), real(arr2(:,:,4), sp), mask=mask(:,:,1))
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. -21656)
  dtmp = LNNSE(arr1(:,:,1), arr2(:,:,4), mask=mask(:,:,1))
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. -21656)
  stmp = LNNSE(real(arr1, sp), real(arr2, sp), mask=mask)
  isgood = isgood .and. (nint(10000._sp*stmp) .EQ. 8915)
  dtmp = LNNSE(arr1, arr2, mask=mask)
  isgood = isgood .and. (nint(10000._dp*dtmp) .EQ. 8915)
  !
  if (isgood) then
     write(*,*) 'mo_errormeasures ', color('o.k.', c_green)
  else
     write(*,*) 'mo_errormeasures ', color('failed', c_red)
  endif
  !
end program test


      SUBROUTINE cumbet(x,y,a,b,cum,ccum)
C**********************************************************************
C
C     SUBROUTINE CUMBET(X,Y,A,B,CUM,CCUM)
C          Double precision cUMulative incomplete BETa distribution
C
C
C                              Function
C
C
C     Calculates the cdf to X of the incomplete beta distribution
C     with parameters a and b.  This is the integral from 0 to x
C     of (1/B(a,b))*f(t)) where f(t) = t**(a-1) * (1-t)**(b-1)
C
C
C                              Arguments
C
C
C     X --> Upper limit of integration.
C                                        X is DOUBLE PRECISION
C
C     Y --> 1 - X.
C                                        Y is DOUBLE PRECISION
C
C     A --> First parameter of the beta distribution.
C                                        A is DOUBLE PRECISION
C
C     B --> Second parameter of the beta distribution.
C                                        B is DOUBLE PRECISION
C
C     CUM <-- Cumulative incomplete beta distribution.
C                                        CUM is DOUBLE PRECISION
C
C     CCUM <-- Compliment of Cumulative incomplete beta distribution.
C                                        CCUM is DOUBLE PRECISION
C
C
C                              Method
C
C
C     Calls the routine BRATIO.
C
C                                   References
C
C     Didonato, Armido R. and Morris, Alfred H. Jr. (1992) Algorithim
C     708 Significant Digit Computation of the Incomplete Beta Function
C     Ratios. ACM ToMS, Vol.18, No. 3, Sept. 1992, 360-373.
C
C**********************************************************************

C     .. Scalar Arguments ..
      DOUBLE PRECISION x,y,a,b,cum,ccum
C     ..
C     .. Local Scalars ..
      INTEGER ierr
C     ..
C     .. External Routines ..
      EXTERNAL bratio
C     ..
C     .. Executable Statements ..
      IF (.NOT. (x.LE.0.0D0)) GO TO 10
      cum = 0.0D0
      ccum = 1.0D0
      RETURN

   10 IF (.NOT. (y.LE.0.0D0)) GO TO 20
      cum = 1.0D0
      ccum = 0.0D0
      RETURN

   20 CALL bratio(a,b,x,y,cum,ccum,ierr)

C     Call bratio routine

      RETURN

      END


#INCLUDE 'MR_H_ALIGN_PADDING.H'
!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_TDMA

    USE MR_KINDS

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_TDMA1 , MR_TDMA2

!***********************************************************************************************************************************

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (FUNCTION)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  FUNCTION MR_TDMA1( NI , NJ , A , B , C , D ) RESULT( X )

    IMPLICIT NONE

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI , NJ

    REAL   (CARD_KIND) , INTENT(IN ) , DIMENSION(2:NI2(NI,CARD_KIND)  ,1:NJ  ) :: A
    REAL   (CARD_KIND) , INTENT(IN ) , DIMENSION(1:NI1(NI,CARD_KIND)  ,1:NJ  ) :: B
    REAL   (CARD_KIND) , INTENT(IN ) , DIMENSION(1:NI2(NI,CARD_KIND)-1,1:NJ  ) :: C
    REAL   (CARD_KIND) , INTENT(IN ) , DIMENSION(1:NI1(NI,CARD_KIND)  ,1:NJ  ) :: D

    REAL   (CARD_KIND) , DIMENSION(1:NI1(NI,CARD_KIND)  ,1:NJ  ) :: X
    REAL   (CARD_KIND) , DIMENSION(1:NI1(NI,CARD_KIND)         ) :: Y

    REAL   (CARD_KIND)                                        :: W
    REAL   (CARD_KIND) , DIMENSION(1:NI2(NI,CARD_KIND)-1       ) :: V

    INTEGER(IJID_KIND) :: I , J

    DO J = 1 , NJ

    ! GAUSSIAN ELIMINATION
      I = 1
        W = B( I , J )
        Y( I ) = D( I , J ) / W
      !END I = 1
     !DIR$ VECTOR ALIGNED
      DO I = 2 , NI
        V(I-1) = C(I-1, J ) / W
        W = B( I , J ) - A( I , J ) * V(I-1)
        Y( I ) = ( D( I , J ) - A( I , J ) * Y(I-1) ) / W
      END DO

    ! BACK SUBSTITUTION
      I = NI
        X( I , J ) = Y( I )
      !END I = NI
     !DIR$ VECTOR ALIGNED
      DO I = NI-1 , 1 , -1
        X( I , J ) = Y( I ) - V( I ) * X(I+1, J )
      END DO

    END DO

  END FUNCTION MR_TDMA1

!***********************************************************************************************************************************
! UNIT:
!
!  (FUNCTION)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  FUNCTION MR_TDMA2( NI , NJ , A , B , C , D ) RESULT( X )

    IMPLICIT NONE

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI , NJ

    REAL   (CARD_KIND) , INTENT(IN ) , DIMENSION(1:NI1(NI,CARD_KIND)  ,2:NJ  ) :: A
    REAL   (CARD_KIND) , INTENT(IN ) , DIMENSION(1:NI1(NI,CARD_KIND)  ,1:NJ  ) :: B
    REAL   (CARD_KIND) , INTENT(IN ) , DIMENSION(1:NI1(NI,CARD_KIND)  ,1:NJ-1) :: C
    REAL   (CARD_KIND) , INTENT(IN ) , DIMENSION(1:NI1(NI,CARD_KIND)  ,1:NJ  ) :: D

    REAL   (CARD_KIND) , DIMENSION(1:NI1(NI,CARD_KIND)  ,1:NJ  ) :: X
    REAL   (CARD_KIND) , DIMENSION(1:NI1(NI,CARD_KIND)  ,1:NJ  ) :: Y

    REAL   (CARD_KIND) , DIMENSION(1:NI1(NI,CARD_KIND)         ) :: W
    REAL   (CARD_KIND) , DIMENSION(1:NI1(NI,CARD_KIND)  ,1:NJ-1) :: V

    INTEGER(IJID_KIND) :: I , J

  ! GAUSSIAN ELIMINATION
    J = 1
     !DIR$ VECTOR ALIGNED
      DO I = 1 , NI
        W( I ) = B( I , J )
        Y( I , J ) = D( I , J ) / W( I )
      END DO
    !END J = 1
    DO J = 2 , NJ
     !DIR$ VECTOR ALIGNED
      DO I = 1 , NI
        V( I ,J-1) = C( I ,J-1) / W( I )
        W( I ) = B( I , J ) - A( I , J ) * V( I ,J-1)
        Y( I , J ) = ( D( I , J ) - A( I , J ) * Y( I ,J-1) ) / W( I )
      END DO
    END DO

  ! BACK SUBSTITUTION
    J = NJ
     !DIR$ VECTOR ALIGNED
      DO I = 1 , NI
        X( I , J ) = Y( I , J )
      END DO
    !END J = NJ
    DO J = NJ-1 , 1 , -1
     !DIR$ VECTOR ALIGNED
      DO I = 1 , NI
        X( I , J ) = Y( I , J ) - V( I , J ) * X( I ,J+1)
      END DO
    END DO

  END FUNCTION MR_TDMA2

  END MODULE MR_MOD_TDMA


! Code by: Jostein Brandshoi

! ---------------------------------------------------------------------------------------------------------------
! This program uses the upwind scheme together with cyclic boundary conditions and MPDATA method to solve the
! advection equation for the region x in [0, j_max] and t > 0. MPDATA is only used when specified by the user
! through the command line. Below is info on how to compile (with gfortran) and run the program.
!
! Compile/run on Linux:
!
! > gfortran -o advection_solver.exe advection_solver.f90
! > advection_solver.exe <method_type> <differentation_type> <output_filename>
!
! Compile/run on Linux:
!
! > gfortran -o advection_solver advection_solver.f90
! > ./advection_solver <method_type> <differentation_type> <output_filename>
!
! Command line args (in order):
!     method_type         : Choose either "mpdata" or an arbitrary non-empy string. Determines if MPDATA is
!                               used or not. something different than "mpdata" is given, ordinary upwind is used
!     differentation_type : Choose between "forward", "centered" or "backward". Determines what FDA is
!                               used for computing the anti-diffusive velocity u_star.
!     output_filename     : Give a filename (*.dat) to store the theta values at releveant time levels
!                               for plotting.
! ---------------------------------------------------------------------------------------------------------------

PROGRAM advection_solver
    IMPLICIT NONE
    ! ------------------------------- VARIABLE DECLARATIONS -------------------------------
    double precision, parameter :: L = 50000.0                      ! Location (L/2) where initial bell is max [m]
    double precision, parameter :: sigma = L / 10.0                 ! Measure of with of initial Gaussian bell [m]
    double precision, parameter :: theta_0 = 10.0                   ! Max temperature value of initial bell [deg C]
    double precision, parameter :: u_0 = 1.0                        ! Advection speed (constant here) [m/s]
    double precision, parameter :: S_c = 1.1                        ! Scaling factor for use in MPDATA
    double precision, parameter :: epsilon = 1E-15                  ! Small to avoid zero division in MPDATA

    double precision, parameter :: C = 0.50                         ! Courant number [u_0 * delta_t / delta_x] [m/s]
    double precision, parameter :: delta_x = sigma / 10.0           ! Distance between spatial gridpoints [m]
    double precision, parameter :: delta_t = C * delta_x / u_0      ! Time between temporal gridpoints [s]

    integer :: i, j, n                                              ! Counter variables (i: iters, j: space, n: time)
    integer :: n_temp, n_curr = 1, n_next = 2                       ! Indices to represent curr and next time stetp
    integer, parameter :: num_iterations = 1
    integer, parameter :: j_max = idint(L / delta_x + 1)            ! Max number of space points in [0: j = 1, L: j = j_max]
    integer, parameter :: n_max = idint((25 * L) / (u_0 * delta_t)) ! Max number of time points needed for 25 cycles
    integer, parameter :: n_05c = idint((5 * L) / (u_0 * delta_t))  ! Number of time points needed for 5 cycles
    integer, parameter :: n_10c = idint((10 * L) / (u_0 * delta_t)) ! Number of time points needed for 10 cycles
    integer, parameter :: n_15c = idint((15 * L) / (u_0 * delta_t)) ! Number of time points needed for 15 cycles
    integer, parameter :: n_20c = idint((20 * L) / (u_0 * delta_t)) ! Number of time points needed for 20 cycles

    double precision, dimension(j_max) :: theta_star = 0.0, u_star = 0.0, F_star = 0.0
    double precision, dimension(j_max, 2) :: theta = 0.0            ! 2D-array to store solution at time points n and n + 1

    character(len = 32) :: method_type                              ! String to specify which algorithm to use
    character(len = 32) :: differentation_type                      ! String to specify which FDA to use in MPDATA
    character(len = 32) :: output_filename                          ! Variable to hold output filename for results

    logical :: use_scaling = .TRUE.                                 ! Boolean that specifies if scaling is used
    ! -------------------------------------------------------------------------------------

    ! -------------------------------- INITIAL CONDITION ----------------------------------
    ! Compute initial condition for theta and where x_j = (j - 1) * delta_x.
    do j = 1, j_max
        theta(j, n_curr) = theta_0 * dexp(-((2 * ((j - 1) * delta_x) - L) / sigma) ** 2)
    end do
    ! -------------------------------------------------------------------------------------

    ! ---------- GETTING ARGS FROM CMD-LINE AND OPEN .DAT FILE FOR RESULT OUTPUT ----------
    CALL GET_COMMAND_ARGUMENT(1, method_type)                    ! Get cmd-line arg for method type
    CALL GET_COMMAND_ARGUMENT(2, differentation_type)            ! Get cmd-line arg for diff type file
    CALL GET_COMMAND_ARGUMENT(3, output_filename)                ! Get cmd-line arg for output file
    open(unit = 10, file = output_filename, form = "formatted")  ! Open file that will store results
    ! -------------------------------------------------------------------------------------

    ! ---------------- USING UPWIND SCHEME, BC'S AND MPDATA IF REQUESTED ------------------
    do n = 0, n_max     ! Loop, in time as long as necessary to complete requested number of cycles
        theta(1, n_curr) = theta(j_max, n_curr)     ! BC theta at the left boundary x = 0

        ! Use upwind scheme to compute a predictor to theta at time level n + 1
        do j = 2, j_max
            theta_star(j) = theta(j, n_curr) - C * (theta(j, n_curr) - theta(j - 1, n_curr))
        end do

        if (method_type == "mpdata") then   ! Employ MPDATA method when specified
            do i = 1, num_iterations        ! Use MPDATA for num_iterations iterations
                theta_star(1) = theta_star(j_max)   ! BC for theta_star for each iteration
                u_star(1) = u_star(j_max)           ! BC for u_star for each iteration
                F_star(1) = F_star(j_max)           ! BC for F_star for each iteration

                ! Compute u_star (at all interior points) if theta_star > 0 with requested FDA.
                do j = 2, j_max - 1
                    if (theta_star(j) > 0) then
                        if (differentation_type == "centered") then
                            u_star(j) = 0.25 * (1 - C) * u_0 * ((theta_star(j + 1) - &
                                theta_star(j - 1)) / (theta_star(j) + epsilon))
                        else if (differentation_type == "forward") then
                            u_star(j) = 0.50 * (1 - C) * u_0 * ((theta_star(j + 1) - &
                                theta_star(j)) / (theta_star(j) + epsilon))
                        else if (differentation_type == "backward") then
                            u_star(j) = 0.50 * (1 - C) * u_0 * ((theta_star(j) - &
                                theta_star(j - 1)) / (theta_star(j) + epsilon))
                        end if
                    else
                        u_star(j) = 0.0     ! u_star set to zero when theta_star <= 0
                    end if

                    ! Scale anti-diffusive velocity when scaled approach is used.
                    if (use_scaling .eqv. .TRUE.) then
                        u_star(j) = u_star(j) * S_c
                    end if
                end do

                ! Compute u_star (at the j_max using BC) if theta_star > 0 with requested FDA.
                if (theta_star(j_max) > 0) then
                    if (differentation_type == "centered") then
                        u_star(j_max) = 0.25 * (1 - C) * u_0 * ((theta_star(1) - &
                            theta_star(j_max - 1)) / (theta_star(j_max) + epsilon))
                    else if(differentation_type == "forward") then
                        u_star(j_max) = 0.50 * (1 - C) * u_0 * ((theta_star(1) - &
                        theta_star(1)) / (theta_star(1) + epsilon))
                    else if (differentation_type == "backward") then
                        u_star(j_max) = 0.50 * (1 - C) * u_0 * ((theta_star(1) - &
                            theta_star(j_max - 1)) / (theta_star(1) + epsilon))
                    end if
                else
                    u_star(j_max) = 0.0     ! u_star set to zero when theta_star <= 0
                end if

                ! Scale anti-diffusive velocity at end point j_max.
                if (use_scaling .eqv. .TRUE.) then
                    u_star(j_max) = u_star(j_max) * S_c
                end if

                ! Compute F_star at all interior points.
                do j = 2, j_max - 1
                    F_star(j) = 0.5 * ((u_star(j) + dabs(u_star(j))) * &
                        theta_star(j) + (u_star(j + 1) - dabs(u_star(j + 1))) * &
                        theta_star(j + 1)) * (delta_t / delta_x)
                end do

                ! Compute F_star at the j_max using BC.
                F_star(j_max) = 0.5 * ((u_star(j_max) + dabs(u_star(j_max))) * &
                    theta_star(j_max) + (u_star(1) - dabs(u_star(1))) * &
                    theta_star(1)) * (delta_t / delta_x)

                ! Update theta_star to be the corrected value
                do j = 2, j_max
                    theta_star(j) = theta_star(j) - (F_star(j) - F_star(j - 1))
                end do

                if (use_scaling .eqv. .TRUE.) then
                    exit    ! Exit iteration loop after one iteration if scaling method is used
                end if
            end do
        end if

        do j = 2, j_max
            theta(j, n_next) = theta_star(j)    ! Set theta at time level n + 1 equal theta_star
        end do

        ! Write theta to file for time steps corresponding to the requested cycles.
        if (n == 0 .or. n == n_05c .or. n == n_10c .or. n == n_15c .or. n == n_20c .or. n == n_max) then
            write(unit = 10, fmt = "(102f20.14)") float(n), theta(:, n_curr) / theta_0  ! Write line-wise
        end if

        n_temp = n_next     ! Set help index to second theta column (2)
        n_next = n_curr     ! Set next time step index to first theta column (1)
        n_curr = n_temp     ! Set current time step index to second column (2)
    end do
    ! -------------------------------------------------------------------------------------

    close(unit = 10)    ! Close file after writing

END PROGRAM advection_solver


! ================================================================================================ !
! Shared module for general physical constants
! Last modified: 2018-05-25
! See: http://pdg.lbl.gov/2017/reviews/rpp2016-rev-phys-constants.pdf
! Some values are not updated to ensure numerical compatability with older studies
! ================================================================================================ !
module physical_constants

  use floatPrecision

  implicit none

  ! Proton and Electron Mass (MeV)
  real(kind=fPrec), parameter :: pmap  = 938.271998_fPrec               ! Old
  real(kind=fPrec), parameter :: pmae  = 0.510998902_fPrec              ! PDG 2002

  ! Proton and Electron Mass (MeV) Latest Values
  real(kind=fPrec), parameter :: pmap_18 = 938.272081_fPrec             ! PDG 2018
  real(kind=fPrec), parameter :: pmae_18 = 0.5109989461_fPrec           ! PDG 2018

  ! Classical electron radius
  real(kind=fPrec), parameter :: crade    = 2.817940285e-15_fPrec       ! Old
  real(kind=fPrec), parameter :: crade_18 = 2.8179403227e-15_fPrec      ! PDG 2018

  ! Speed of light
  real(kind=fPrec), parameter :: clight = 2.99792458e8_fPrec            ! Exact by definition

  ! Avogadro constant
! real(kind=fPrec), parameter :: fnavo  = 6.02214129e23_fPrec           ! Old
! real(kind=fPrec), parameter :: fnavo  = 6.022140857e23_fPrec          ! PDG 2018
  real(kind=fPrec), parameter :: fnavo  = 6.02214076e23_fPrec           ! Exact by definition

  ! Planck constant
! real(kind=fPrec), parameter :: planck = 6.626070040e-34_fPrec
  real(kind=fPrec), parameter :: planck = 6.62607015e-34_fPrec          ! Exact by definition

  !Electric charge
  real(kind=fPrec), parameter :: echarge = 1.602176634e-19_fPrec        ! Exact by definition

  ! Vacuum permittivity
  real(kind=fPrec), parameter :: eps0   = 8.854187817e-12_fPrec

end module physical_constants

! ================================================================================================ !
! Shared module for numerical constants
! Last modified: 2018-05-25
! To ensure that the same values (including round-off) is used throughout the program.
! ================================================================================================ !
module numerical_constants

  use floatPrecision

  implicit none

! real(kind=fPrec), parameter :: pi      = 3.141592653589793238462643383279502884197169399375105820974_fPrec
! real(kind=fPrec), parameter :: inv_ln2 = 1.442695040888963407359924681001892137426645954152985934135_fPrec

  ! We set the parameters of irrational numbers explicitly to their nearest binary representation
  ! without depending on rounding from decimal representation. These use decimal round near.
  ! Small program for checking binary and hex here: https://gist.github.com/vkbo/0e5d0c4b7b1ecb533a0486c79a30f741
  ! Note: Transfer to real128 only works for GNU

  real(kind=fPrec), parameter :: pi      = real(z'400921fb54442d18',fPrec)
  real(kind=fPrec), parameter :: pi2     = real(z'3ff921fb54442d18',fPrec)
  real(kind=fPrec), parameter :: twopi   = real(z'401921fb54442d18',fPrec)
  real(kind=fPrec), parameter :: pisqrt  = real(z'3ffc5bf891b4ef6a',fPrec)
  real(kind=fPrec), parameter :: inv_ln2 = real(z'3ff71547652b82fe',fPrec)
  real(kind=fPrec), parameter :: rad     = real(z'3f91df46a2529d39',fPrec)

  ! The variable pieni is roughly the smallest normal single precision float value.
  ! However, 1e-38 is actually subnormal in 32 bit (0x006ce3ee). Smallest normal is 1.17549435e-38 (0x00800000)
  ! This is probably not a good idea for performance in single prec, but changing it makes a difference in postprocessing it seems.
  real(kind=fPrec), parameter :: pieni  = 1e-38_fPrec

  real(kind=fPrec), parameter :: zero   = 0.0_fPrec
  real(kind=fPrec), parameter :: half   = 0.5_fPrec
  real(kind=fPrec), parameter :: one    = 1.0_fPrec
  real(kind=fPrec), parameter :: two    = 2.0_fPrec
  real(kind=fPrec), parameter :: three  = 3.0_fPrec
  real(kind=fPrec), parameter :: four   = 4.0_fPrec
  real(kind=fPrec), parameter :: five   = 5.0_fPrec
  real(kind=fPrec), parameter :: six    = 6.0_fPrec
  real(kind=fPrec), parameter :: seven  = 7.0_fPrec
  real(kind=fPrec), parameter :: eight  = 8.0_fPrec
  real(kind=fPrec), parameter :: nine   = 9.0_fPrec

  real(kind=fPrec), parameter :: c1e1   = 1.0e1_fPrec
  real(kind=fPrec), parameter :: c1e2   = 1.0e2_fPrec
  real(kind=fPrec), parameter :: c2e2   = 2.0e2_fPrec
  real(kind=fPrec), parameter :: c1e3   = 1.0e3_fPrec
  real(kind=fPrec), parameter :: c2e3   = 2.0e3_fPrec
  real(kind=fPrec), parameter :: c4e3   = 4.0e3_fPrec
  real(kind=fPrec), parameter :: c1e4   = 1.0e4_fPrec
  real(kind=fPrec), parameter :: c1e5   = 1.0e5_fPrec
  real(kind=fPrec), parameter :: c1e6   = 1.0e6_fPrec
  real(kind=fPrec), parameter :: c1e7   = 1.0e7_fPrec
  real(kind=fPrec), parameter :: c1e8   = 1.0e8_fPrec
  real(kind=fPrec), parameter :: c1e9   = 1.0e9_fPrec
  real(kind=fPrec), parameter :: c1e10  = 1.0e10_fPrec
  real(kind=fPrec), parameter :: c1e12  = 1.0e12_fPrec
  real(kind=fPrec), parameter :: c1e13  = 1.0e13_fPrec
  real(kind=fPrec), parameter :: c1e15  = 1.0e15_fPrec
  real(kind=fPrec), parameter :: c1e16  = 1.0e16_fPrec
  real(kind=fPrec), parameter :: c1e27  = 1.0e27_fPrec
  real(kind=fPrec), parameter :: c1e38  = 1.0e38_fPrec

  real(kind=fPrec), parameter :: c180e0 = 1.8e2_fPrec

  real(kind=fPrec), parameter :: c1m1   = 1.0e-1_fPrec
  real(kind=fPrec), parameter :: c2m1   = 2.0e-1_fPrec
  real(kind=fPrec), parameter :: c1m2   = 1.0e-2_fPrec
  real(kind=fPrec), parameter :: c5m2   = 5.0e-2_fPrec
  real(kind=fPrec), parameter :: c1m3   = 1.0e-3_fPrec
  real(kind=fPrec), parameter :: c1m4   = 1.0e-4_fPrec
  real(kind=fPrec), parameter :: c5m4   = 5.0e-4_fPrec
  real(kind=fPrec), parameter :: c1m5   = 1.0e-5_fPrec
  real(kind=fPrec), parameter :: c1m6   = 1.0e-6_fPrec
  real(kind=fPrec), parameter :: c2m6   = 2.0e-6_fPrec
  real(kind=fPrec), parameter :: c1m7   = 1.0e-7_fPrec
  real(kind=fPrec), parameter :: c1m8   = 1.0e-8_fPrec
  real(kind=fPrec), parameter :: c1m9   = 1.0e-9_fPrec
  real(kind=fPrec), parameter :: c2m9   = 2.0e-9_fPrec
  real(kind=fPrec), parameter :: c1m10  = 1.0e-10_fPrec
  real(kind=fPrec), parameter :: c1m12  = 1.0e-12_fPrec
  real(kind=fPrec), parameter :: c1m13  = 1.0e-13_fPrec
  real(kind=fPrec), parameter :: c1m15  = 1.0e-15_fPrec
  real(kind=fPrec), parameter :: c1m18  = 1.0e-18_fPrec
  real(kind=fPrec), parameter :: c1m21  = 1.0e-21_fPrec
  real(kind=fPrec), parameter :: c1m24  = 1.0e-24_fPrec
  real(kind=fPrec), parameter :: c1m27  = 1.0e-27_fPrec
  real(kind=fPrec), parameter :: c1m36  = 1.0e-36_fPrec
  real(kind=fPrec), parameter :: c1m38  = 1.0e-38_fPrec

end module numerical_constants


program autocorr

  ! A program to calculate the autocorrelation coefficient of an image
  ! for a number of vectors

  use iso_varying_string
  use cmdline_arguments, only: assignment(=), have_args, get_options, next_arg, option_exists, get_value, has_value
  use file_functions, only: stderr
  use pnm_class
  use precision, only: rd_kind

  implicit none

  character(len=1000) :: fname

  type (pnm_object) :: pnm

  integer :: i, j, k, l, m, error, nx, ny, nxny, weight

  real :: datamean, sumsqr
  real(kind=rd_kind) :: moran, geary

  integer, allocatable, dimension(:,:) :: data
  real, allocatable, dimension(:,:) :: shifted, datanorm
  logical, allocatable, dimension(:,:) :: mask, shiftedmask

  type (varying_string) :: myoptions(3)

  logical :: debug = .FALSE.

  ! Populate our
  myoptions(1) = "help"
  myoptions(2) = "debug"
  myoptions(3) = "num"

  call get_options(myoptions, error)
  if (error > 0) stop 'Whoops error processing options!'

  if ( option_exists('help') ) then
     call usage
     stop
  end if

  if ( .not. have_args() ) then
     write(stderr,*) "ERROR! Must provide a pgm file as command line argument"
     call usage
     stop
  end if

  debug = option_exists("debug")

  do while (have_args())

     ! The files are on the command line
     fname = next_arg()

     call read(pnm,trim(fname))

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

     nxny = nx*ny

     ! Allocate the space required for the data
     allocate(data(nx,ny),shifted(nx,ny),datanorm(nx,ny),mask(nx,ny),shiftedmask(nx,ny))

     data = pnm

     datamean = mean(data, data > 0)

     datanorm = real(data) - datamean

     mask = data > 0

     sumsqr = sum( datanorm**2, mask = mask )

     if (debug) print *,'mean = ', datamean
     if (debug) print *,count(mask)
     if (debug) print *,'sumsqr = ',sumsqr
     if (debug) print *,'nxny/sumsqr = ',real(nxny)/sumsqr

     if (debug) print *,'sum(data**2)', sum( data**2, mask = mask )

     do i = 0, nx - 1

        shifted = eoshift(datanorm,i,dim=1)
        shiftedmask = eoshift(mask,i,dim=1)
        if (debug) print *,count(shiftedmask)

        moran = 0
        geary = 0
        weight = 1

!!$        do j = -1, 1
!!$           do k = -1, 1
!!$              moran = moran + sum( eoshift(eoshift(datanorm,j,dim=1),k,dim=2)*shifted, mask = shiftedmask )
!!$              ! if (debug) print *,moran
!!$              weight = weight + 1
!!$           end do
!!$        end do
!!$
!!$        moran = (real(nxny) / sumsqr * real(count(shiftedmask)) * real(weight) ) * moran

        weight = 0

        do j = 1, nx
           do k = 1, ny
              if (.not. mask(j,k)) cycle
              ! do l = -1, 1
              do l = 0, 0
                 if (j+l > nx .or. j+l < 1) cycle
                 ! do m = -1, 1
                 do m = 0, 0
                    if (k+m > ny .or. k+m < 1) cycle
                    if (.NOT. shiftedmask(j+l,k+m) ) cycle
                    moran = moran + datanorm(j,k) * shifted(k+m,j+l)
                    geary = geary + (data(j,k) - shifted(k+m,j+l))**2
                    weight = weight + 1
                 end do
              end do
           end do
        end do

        if (debug) print *,i,weight,moran

        moran = (real(nxny) / (sumsqr * real(weight) ) ) * moran

        if (debug) print *,i,moran

        if (debug) print *,i,weight,geary

        geary = 0.5 * (real(nxny - 1) / (sumsqr * real(weight) ) ) * geary

        if (debug) print *,i,geary

     end do

     deallocate(data)

  end do

contains

  real function mean (array, mask)

    integer, intent(in) :: array(:,:)
    logical, intent(in) :: mask(:,:)

    integer(kind=8) :: total, npixels

    total = 0
    npixels = 0
    do i = 1, size(array,2)
       total = total + sum(array(:,i),mask=mask(:,i))
       npixels = npixels + count(mask(:,i))
       ! print *,i,total
    end do
    mean = real(total,8) / real(npixels,8)

  end function mean

  subroutine usage

    write(stderr,*)
    write(stderr,*) 'autocorr calculates the autocorrelation coefficient of an image file'
    write(stderr,*)
    write(stderr,*) 'Usage: autocorr [OPTIONS] mol2file [group-spec]'
    write(stderr,*)
    write(stderr,*) ' OPTIONS:'
    write(stderr,*)
    write(stderr,*) '  --help    - print this message and exit'
    write(stderr,*) '  --debug   - suppress diagnostic output'
    write(stderr,*) '  --num     - number of vectors'
    write(stderr,*)

  end subroutine usage

end program autocorr


PROGRAM F033

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER, DIMENSION(4, 2) :: PRODUCTS_LIST

    CHARACTER (LEN=10) :: TEMP_STR

    REAL    :: VALUE_1, VALUE_2

    INTEGER :: COUNT_VAL = 1

    INTEGER :: I, J, TEMP_NUM_11, TEMP_NUM_12, TEMP_NUM_21,                    &
                     TEMP_NUM_22, TEMP_NUM_3,  TEMP_NUM_4

    LOGICAL :: REDUCED

    DO I = 10, 50

        DO J = 10, 99

            IF ((I >= J) .OR. (MOD(I, 10) == 0) .OR. (MOD(J, 10) == 0)) CYCLE

            WRITE(TEMP_STR, '(I10)') I
            TEMP_STR = ADJUSTL(TEMP_STR)

            TEMP_NUM_11 = IACHAR(TEMP_STR(1:1)) - IACHAR('0')
            TEMP_NUM_12 = IACHAR(TEMP_STR(2:2)) - IACHAR('0')

            WRITE(TEMP_STR, '(I10)') J
            TEMP_STR = ADJUSTL(TEMP_STR)

            TEMP_NUM_21 = IACHAR(TEMP_STR(1:1)) - IACHAR('0')
            TEMP_NUM_22 = IACHAR(TEMP_STR(2:2)) - IACHAR('0')

            TEMP_NUM_3 = 99999
            TEMP_NUM_4 = 99999

             IF  ((TEMP_NUM_11 == TEMP_NUM_21)                                 &
            .AND. (TEMP_NUM_12 /= TEMP_NUM_22)) THEN

                TEMP_NUM_3 = TEMP_NUM_12
                TEMP_NUM_4 = TEMP_NUM_22

            ELSE IF ((TEMP_NUM_11 == TEMP_NUM_22)                              &
            .AND.    (TEMP_NUM_12 /= TEMP_NUM_21)) THEN

                TEMP_NUM_3 = TEMP_NUM_12
                TEMP_NUM_4 = TEMP_NUM_21

            ELSE IF ((TEMP_NUM_12 == TEMP_NUM_21)                              &
            .AND.    (TEMP_NUM_11 /= TEMP_NUM_22)) THEN

                TEMP_NUM_3 = TEMP_NUM_11
                TEMP_NUM_4 = TEMP_NUM_22

            ELSE IF ((TEMP_NUM_12 == TEMP_NUM_22)                              &
            .AND.    (TEMP_NUM_11 /= TEMP_NUM_21)) THEN

                TEMP_NUM_3 = TEMP_NUM_11
                TEMP_NUM_4 = TEMP_NUM_21

            END IF

            IF (TEMP_NUM_3 /= 99999) THEN

                VALUE_1 = (FLOOR(REAL(I) * 1.0E5 / REAL(J))) / 1.0E5;
                VALUE_2 = (FLOOR(REAL(TEMP_NUM_3) * 1.0E5 /                    &
                           REAL(TEMP_NUM_4))) / 1.0E5;

                IF  ((VALUE_1 - VALUE_2) <  1.0E-5                             &
               .AND. (VALUE_1 - VALUE_2) > -1.0E-5) THEN

                    PRODUCTS_LIST(COUNT_VAL, 1) = I
                    PRODUCTS_LIST(COUNT_VAL, 2) = J
                    COUNT_VAL = COUNT_VAL + 1
                END IF

            END IF

        END DO

    END DO

    PRODUCTS_LIST(1, 1) = PRODUCTS_LIST(1, 1) * PRODUCTS_LIST(2, 1)            &
                        * PRODUCTS_LIST(3, 1) * PRODUCTS_LIST(4, 1)

    PRODUCTS_LIST(1, 2) = PRODUCTS_LIST(1, 2) * PRODUCTS_LIST(2, 2)            &
                        * PRODUCTS_LIST(3, 2) * PRODUCTS_LIST(4, 2)

    DO WHILE ((PRODUCTS_LIST(1, 1) /= 1) .AND. (PRODUCTS_LIST(1, 2) /= 1))

        I = 2
        REDUCED = .FALSE.

        DO WHILE (.NOT. REDUCED)

            IF ((MOD(PRODUCTS_LIST(1, 1), I) == 0)                             &
          .AND. (MOD(PRODUCTS_LIST(1, 2), I) == 0)) THEN

                PRODUCTS_LIST(1, 1) = PRODUCTS_LIST(1, 1) / I
                PRODUCTS_LIST(1, 2) = PRODUCTS_LIST(1, 2) / I
                REDUCED = .TRUE.

            ELSE
                I = I + 1
            END IF

        END DO

    END DO

    PRINT ('(I0)'), PRODUCTS_LIST(1, 2)

END PROGRAM F033