Program testQuadratures

Use Kinds, Only: id
Use Kinds, Only: dp
Use Global, Only: Pi
Use FileIO_Utilities, Only: delta_Time
Use Quadratures, Only: Romberg_Quad
Use Quadratures, Only: Adaptive_Simpson
Use Quadratures, Only: Adaptive_Trapezoid
Use Quadratures, Only: Composite_Simpson
Use Quadratures, Only: Composite_Trapezoid
Use Quadratures, Only: Composite_Quad
Use Quadratures, Only: Progressive_GaussLegendre
Use Quadratures, Only: Midpoint_Quad
Use Quadratures, Only: Trapezoid_Quad
Use Quadratures, Only: Simpson_Quad
Use Quadratures, Only: Adaptive_Quad
Use Utilities, Only: Prec

Implicit None

Integer(id) :: c
Real(dp), Parameter :: aTol = 0._dp
Real(dp) :: rTol
Integer, Parameter :: n = 3
Real(dp), Parameter :: rTols(1:n) = (/ 1.E-6_dp , 1.E-9_dp , 1.E-12_dp /)
Integer :: j
Real(dp) :: dt
Real(dp) :: f
Integer(id), SAVE :: calls
Integer :: i
Real(dp), Parameter :: fSin3_ans =     0.41583381465627398043_dp
Real(dp), Parameter :: fExp3_ans =     0.75680249730643946285_dp
Real(dp), Parameter :: fSin2Cos3_ans = 0.06712281323017693881_dp
Real(dp), Parameter :: fPlanck_ans =   0.99044994083816813221_dp
Real(dp), Parameter :: test_time = 1._dp
Real(dp), Parameter :: kT = 1._dp ![keV] Temp for test Placnkian

Write(*,*)
Write(*,'(A)') 'Quadrature comparisons for Integral Sin(x**3) on [0,Pi]'
Write(*,'(A)') '---------------------------------------------------------'
Do j = 1,n
    rTol = rTols(j)
    Write(*,*)
    Write(*,'(A,F19.16,A,I0,A)'                 ) 'Integral Sin(x**3) on [0,Pi]: ',fSin3_ans, &
                                                & ': Seeking ~',-NINT(Log10(rTol)),' digits...'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Composite_Quad(fSin3,0._dp,pi,Midpoint_Quad,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Comp Midpoint:                ', &
                                                & f,' w/ ',Prec(f,fSin3_ans),' digits in ',dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Adaptive_Quad(fSin3,0._dp,pi,Midpoint_Quad,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Adap Midpoint:                ', &
                                                & f,' w/ ',Prec(f,fSin3_ans),' digits in ',dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Composite_Quad(fSin3,0._dp,pi,Trapezoid_Quad,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Comp Trapezoid (generic):     ', &
                                                & f,' w/ ',Prec(f,fSin3_ans),' digits in ',dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Composite_Trapezoid(fSin3,0._dp,pi,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Comp Trapezoid:               ', &
                                                & f,' w/ ',Prec(f,fSin3_ans),' digits in ',dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Adaptive_Quad(fSin3,0._dp,pi,Trapezoid_Quad,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Adap Trapezoid (generic):     ', &
                                                & f,' w/ ',Prec(f,fSin3_ans),' digits in ',dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Adaptive_Trapezoid(fSin3,0._dp,pi,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Adap Trapezoid:               ', &
                                                & f,' w/ ',Prec(f,fSin3_ans),' digits in ',dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Composite_Quad(fSin3,0._dp,pi,Simpson_Quad,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Comp Simpson (generic):       ', &
                                                & f,' w/ ',Prec(f,fSin3_ans),' digits in ',dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Composite_Simpson(fSin3,0._dp,pi,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Comp Simpson:                 ', &
                                                & f,' w/ ',Prec(f,fSin3_ans),' digits in ',dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Adaptive_Quad(fSin3,0._dp,pi,Simpson_Quad,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Adap Simpson (generic):       ', &
                                                & f,' w/ ',Prec(f,fSin3_ans),' digits in ',dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Adaptive_Simpson(fSin3,0._dp,pi,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Adap Simpson:                 ', &
                                                & f,' w/ ',Prec(f,fSin3_ans),' digits in ',dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Progressive_GaussLegendre(fSin3,0._dp,pi,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Prog Gauss-Legendre:          ', &
                                                & f,' w/ ',Prec(f,fSin3_ans),' digits in ',dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Progressive_GaussLegendre(fSin3,0._dp,pi,aTol,rTol,n_stride=2)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Prog Gauss-Legend (stride=2): ', &
                                                & f,' w/ ',Prec(f,fSin3_ans),' digits in ',dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Romberg_Quad(fSin3,0._dp,pi,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Romberg:                      ', &
                                                & f,' w/ ',Prec(f,fSin3_ans),' digits in ',dt/Real(i,dp),' sec w/ ',calls/i,' evals'
End Do

Write(*,*)
Write(*,*)
Write(*,'(A)') 'Quadrature comparisons for Integral Exp(x**3) on [0,ln(2)]'
Write(*,'(A)') '------------------------------------------------------------'
Do j = 1,n
    rTol = rTols(j)
    Write(*,*)
    Write(*,'(A,F19.16,A,I0,A)'                 ) 'Integral Exp(x**3) on [0,ln(2)]: ',fExp3_ans, &
                                                & ': Seeking ~',-NINT(Log10(rTol)),' digits...'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Composite_Quad(fExp3,0._dp,log(2._dp),Midpoint_Quad,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Comp Midpoint:                   ', &
                                                & f,' w/ ',Prec(f,fExp3_ans),' digits in ',dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Adaptive_Quad(fExp3,0._dp,log(2._dp),Midpoint_Quad,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Adap Midpoint:                   ', &
                                                & f,' w/ ',Prec(f,fExp3_ans),' digits in ',dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Composite_Quad(fExp3,0._dp,log(2._dp),Trapezoid_Quad,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Comp Trapezoid (generic):        ', &
                                                & f,' w/ ',Prec(f,fExp3_ans),' digits in ',dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Composite_Trapezoid(fExp3,0._dp,log(2._dp),aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Comp Trapezoid:                  ', &
                                                & f,' w/ ',Prec(f,fExp3_ans),' digits in ',dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Adaptive_Quad(fExp3,0._dp,log(2._dp),Trapezoid_Quad,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Adap Trapezoid (generic):        ', &
                                                & f,' w/ ',Prec(f,fExp3_ans),' digits in ',dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Adaptive_Trapezoid(fExp3,0._dp,log(2._dp),aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Adap Trapezoid:                  ', &
                                                & f,' w/ ',Prec(f,fExp3_ans),' digits in ',dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Composite_Quad(fExp3,0._dp,log(2._dp),Simpson_Quad,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Comp Simpson (generic):          ', &
                                                & f,' w/ ',Prec(f,fExp3_ans),' digits in ',dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Composite_Simpson(fExp3,0._dp,log(2._dp),aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Comp Simpson:                    ', &
                                                & f,' w/ ',Prec(f,fExp3_ans),' digits in ',dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Adaptive_Quad(fExp3,0._dp,log(2._dp),Simpson_Quad,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Adap Simpson (generic):          ', &
                                                & f,' w/ ',Prec(f,fExp3_ans),' digits in ',dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Adaptive_Simpson(fExp3,0._dp,log(2._dp),aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Adap Simpson:                    ', &
                                                & f,' w/ ',Prec(f,fExp3_ans),' digits in ',dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Progressive_GaussLegendre(fExp3,0._dp,log(2._dp),aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Prog Gauss-Legendre:             ', &
                                                & f,' w/ ',Prec(f,fExp3_ans),' digits in ',dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Progressive_GaussLegendre(fExp3,0._dp,log(2._dp),aTol,rTol,n_stride=2)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Prog Gauss-Legendre (stride=2):  ', &
                                                & f,' w/ ',Prec(f,fExp3_ans),' digits in ',dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Romberg_Quad(fExp3,0._dp,log(2._dp),aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Romberg:                         ', &
                                                & f,' w/ ',Prec(f,fExp3_ans),' digits in ',dt/Real(i,dp),' sec w/ ',calls/i,' evals'
End Do

Write(*,*)
Write(*,*)
Write(*,'(A)') 'Quadrature comparisons for Integral Sin(x**2)Cos(x**3) on [0,Pi]'
Write(*,'(A)') '------------------------------------------------------------------'
Do j = 1,n
    rTol = rTols(j)
    Write(*,*)
    Write(*,'(A,F19.16,A,I0,A)'                 ) 'Integral Sin(x**2)Cos(x**3) on [0,Pi]: ',fSin2Cos3_ans, &
                                                & ': Seeking ~',-NINT(Log10(rTol)),' digits...'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Composite_Quad(fSin2Cos3,0._dp,pi,Midpoint_Quad,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Comp Midpoint:                         ', &
                                                & f,' w/ ',Prec(f,fSin2Cos3_ans),' digits in ', &
                                                & dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Adaptive_Quad(fSin2Cos3,0._dp,pi,Midpoint_Quad,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Adap Midpoint:                         ', &
                                                & f,' w/ ',Prec(f,fSin2Cos3_ans),' digits in ', &
                                                & dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Composite_Quad(fSin2Cos3,0._dp,pi,Trapezoid_Quad,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Comp Trapezoid (generic):              ', &
                                                & f,' w/ ',Prec(f,fSin2Cos3_ans),' digits in ', &
                                                & dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Composite_Trapezoid(fSin2Cos3,0._dp,pi,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Comp Trapezoid:                        ', &
                                                & f,' w/ ',Prec(f,fSin2Cos3_ans),' digits in ', &
                                                & dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Adaptive_Quad(fSin2Cos3,0._dp,pi,Trapezoid_Quad,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Adap Trapezoid (generic):              ', &
                                                & f,' w/ ',Prec(f,fSin2Cos3_ans),' digits in ', &
                                                & dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Adaptive_Trapezoid(fSin2Cos3,0._dp,pi,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Adap Trapezoid:                        ', &
                                                & f,' w/ ',Prec(f,fSin2Cos3_ans),' digits in ', &
                                                & dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Composite_Quad(fSin2Cos3,0._dp,pi,Simpson_Quad,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Comp Simpson (generic):                ', &
                                                & f,' w/ ',Prec(f,fSin2Cos3_ans),' digits in ', &
                                                & dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Composite_Simpson(fSin2Cos3,0._dp,pi,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Comp Simpson:                          ', &
                                                & f,' w/ ',Prec(f,fSin2Cos3_ans),' digits in ', &
                                                & dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Adaptive_Quad(fSin2Cos3,0._dp,pi,Simpson_Quad,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Adap Simpson (generic):                ', &
                                                & f,' w/ ',Prec(f,fSin2Cos3_ans),' digits in ', &
                                                & dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Adaptive_Simpson(fSin2Cos3,0._dp,pi,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Adap Simpson:                          ', &
                                                & f,' w/ ',Prec(f,fSin2Cos3_ans),' digits in ', &
                                                & dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Progressive_GaussLegendre(fSin2Cos3,0._dp,pi,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Prog Gauss-Legendre:                   ', &
                                                & f,' w/ ',Prec(f,fSin2Cos3_ans),' digits in ', &
                                                & dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Progressive_GaussLegendre(fSin2Cos3,0._dp,pi,aTol,rTol,n_stride=2)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Prog Gauss-Legendre (stride=2):        ', &
                                                & f,' w/ ',Prec(f,fSin2Cos3_ans),' digits in ', &
                                                & dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Romberg_Quad(fSin2Cos3,0._dp,pi,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Romberg:                               ', &
                                                & f,' w/ ',Prec(f,fSin2Cos3_ans),' digits in ', &
                                                & dt/Real(i,dp),' sec w/ ',calls/i,' evals'
End Do

Write(*,*)
Write(*,*)
Write(*,'(A)') 'Quadrature comparisons for Integral of the Normalized Planck function on [0,10]'
Write(*,'(A)') '----------------------------------------------------------------------------------'
Do j = 1,n
    rTol = rTols(j)
    Write(*,*)
    Write(*,'(A,F19.16,A,I0,A)'                 ) 'Integral Norm Planck on [0,10]: ',fPlanck_ans, &
                                                & ': Seeking ~',-NINT(Log10(rTol)),' digits...'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Composite_Quad(fPlanck,0._dp,10._dp,Midpoint_Quad,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Comp Midpoint:                  ', &
                                                & f,' w/ ',Prec(f,fPlanck_ans),' digits in ', &
                                                & dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Adaptive_Quad(fPlanck,0._dp,10._dp,Midpoint_Quad,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Adap Midpoint:                  ', &
                                                & f,' w/ ',Prec(f,fPlanck_ans),' digits in ', &
                                                & dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Composite_Quad(fPlanck,0._dp,10._dp,Trapezoid_Quad,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Comp Trapezoid (generic):       ', &
                                                & f,' w/ ',Prec(f,fPlanck_ans),' digits in ', &
                                                & dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Composite_Trapezoid(fPlanck,0._dp,10._dp,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Comp Trapezoid:                 ', &
                                                & f,' w/ ',Prec(f,fPlanck_ans),' digits in ', &
                                                & dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Adaptive_Quad(fPlanck,0._dp,10._dp,Trapezoid_Quad,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Adap Trapezoid (generic):       ', &
                                                & f,' w/ ',Prec(f,fPlanck_ans),' digits in ', &
                                                & dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Adaptive_Trapezoid(fPlanck,0._dp,10._dp,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Adap Trapezoid:                 ', &
                                                & f,' w/ ',Prec(f,fPlanck_ans),' digits in ', &
                                                & dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Composite_Quad(fPlanck,0._dp,10._dp,Simpson_Quad,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Comp Simpson (generic):         ', &
                                                & f,' w/ ',Prec(f,fPlanck_ans),' digits in ', &
                                                & dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Composite_Simpson(fPlanck,0._dp,10._dp,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Comp Simpson:                   ', &
                                                & f,' w/ ',Prec(f,fPlanck_ans),' digits in ', &
                                                & dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Adaptive_Quad(fPlanck,0._dp,10._dp,Simpson_Quad,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Adap Simpson (generic):         ', &
                                                & f,' w/ ',Prec(f,fPlanck_ans),' digits in ', &
                                                & dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Adaptive_Simpson(fPlanck,0._dp,10._dp,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Adap Simpson:                   ', &
                                                & f,' w/ ',Prec(f,fPlanck_ans),' digits in ', &
                                                & dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Progressive_GaussLegendre(fPlanck,0._dp,10._dp,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Prog Gauss-Legendre:            ', &
                                                & f,' w/ ',Prec(f,fPlanck_ans),' digits in ', &
                                                & dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Progressive_GaussLegendre(fPlanck,0._dp,10._dp,aTol,rTol,n_stride=2)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Prog Gauss-Legendre (stride=2): ', &
                                                & f,' w/ ',Prec(f,fPlanck_ans),' digits in ', &
                                                & dt/Real(i,dp),' sec w/ ',calls/i,' evals'
    f = 0._dp
    calls = 0
    i = 0
    Call SYSTEM_CLOCK(c)
    Do
        f = Romberg_Quad(fPlanck,0._dp,10._dp,aTol,rTol)
        i = i + 1
        dt = delta_Time(clock_then = c)
        If (dt .GT. test_time) Exit
    End Do
    dt = delta_Time(clock_then = c)
    Write(*,'(A,F19.16,A,F5.2,A,ES9.3E2,A,I0,A)') 'Romberg:                        ', &
                                                & f,' w/ ',Prec(f,fPlanck_ans),' digits in ', &
                                                & dt/Real(i,dp),' sec w/ ',calls/i,' evals'
End Do

Write(*,*)

Contains

    Function fSin3(x) Result(f)
        Use Kinds, Only: dp
        Implicit None
        Real(dp) :: f
        Real(dp), Intent(In) :: x

        f = Sin(x**3)
        calls = calls + 1
    End Function fSin3

    Function fExp3(x) Result(f)
        Use Kinds, Only: dp
        Implicit None
        Real(dp) :: f
        Real(dp), Intent(In) :: x

        f = Exp(x**3)
        calls = calls + 1
    End Function fExp3

    Function fSin2Cos3(x) Result(f)
        Use Kinds, Only: dp
        Implicit None
        Real(dp) :: f
        Real(dp), Intent(In) :: x

        f = Sin(x**2) * Cos(x**3)
        calls = calls + 1
    End Function fSin2Cos3

    Function fPlanck(hv) Result(p)
        !Returns the intensity at E [keV] of a normalized Plankian blackbody with temperature kT [keV]
        Use Kinds, Only: dp
        Use Global, Only: Pi
        Implicit None
        Real(dp) :: p
        Real(dp), Intent(In) :: hv
        !Real(dp), Intent(In) :: kT
        Real(dp):: b,b_sq
        Real(dp), Parameter :: c1 =  1._dp / 47900160._dp
        Real(dp), Parameter :: c2 = -1._dp / 1209600._dp
        Real(dp), Parameter :: c3 =  1._dp / 30240._dp
        Real(dp), Parameter :: c4 = -1._dp / 720._dp
        Real(dp), Parameter :: c5 =  1._dp / 12._dp
        Real(dp), Parameter :: c6 = -1._dp / 2._dp

        b = hv / kT
        If (b .LE. 0._dp) Then
            p = 0._dp
            Return
        Else If (b .LT. 0.1_dp) Then
            !for small values of z use a series expansion approximation
            !No doubt, a more compact or recursive form exists, but the following correctly accumulates ~20 digits of precision
            b_sq = b**2
            p = b_sq * c1 + c2
            p = p * b_sq + c3
            p = p * b_sq + c4
            p = p * b_sq + c5
            p = p * b + c6
            p = p * b + 1._dp
            p = p * b_sq * 15._dp / (kT*(Pi**4))
        Else
            !Bridgeman 5-7
            p = 15._dp * hv**3 / ((Exp(b) - 1._dp) * (kT*pi)**4)
        End If
        calls = calls + 1
    End Function fPlanck

End Program testQuadratures


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE GPOINTS3X3                                              C
C                                                                      C
C 3X3 GAUSS POINTS GENERATION                                          C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
      SUBROUTINE GPOINTS3X3(XP,XW)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER (ZERO=0.D0,ONE=1.D0)
C
      DIMENSION XP(2,9),XW(9),RLGP(2,9)
C
      CALL CLEARV(XW,9)
      CALL CLEAR(XP,2,9)
      CALL CLEAR(RLGP,2,9)
C
      RLGP(1,1)=-ONE
      RLGP(1,2)=ZERO
      RLGP(1,3)= ONE
      RLGP(1,4)=-ONE
      RLGP(1,5)=ZERO
      RLGP(1,6)= ONE
      RLGP(1,7)=-ONE
      RLGP(1,8)=ZERO
      RLGP(1,9)= ONE
C
      RLGP(2,1)=-ONE
      RLGP(2,2)=-ONE
      RLGP(2,3)=-ONE
      RLGP(2,4)=ZERO
      RLGP(2,5)=ZERO
      RLGP(2,6)=ZERO
      RLGP(2,7)= ONE
      RLGP(2,8)= ONE
      RLGP(2,9)= ONE
C
      XW(1)=0.555555555555556D0**2
      XW(2)=0.555555555555556D0*0.888888888888889D0
      XW(3)=0.555555555555556D0**2
C
      XW(4)=0.555555555555556D0*0.888888888888889D0
      XW(5)=0.888888888888889D0**2
      XW(6)=0.555555555555556D0*0.888888888888889D0
C
      XW(7)=0.555555555555556D0**2
      XW(8)=0.555555555555556D0*0.888888888888889D0
      XW(9)=0.555555555555556D0**2
C
      G=DSQRT(0.60D0)
      DO I=1,2
        DO J=1,9
          XP(I,J)=G*RLGP(I,J)
        END DO
      END DO
C
      RETURN
C
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE GAUSS1D                                                 C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE GAUSS1D(XP,XW)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION XP(6),XW(6)
C
      XP(1)=-0.932469514203152
      XP(2)=-0.661209386466265
      XP(3)=-0.238619186083197
      XP(6)= 0.932469514203152
      XP(5)= 0.661209386466265
      XP(4)= 0.238619186083197
C
      XW(1)=0.171324492379170
      XW(2)=0.360761573048139
      XW(3)=0.467913934572691
      XW(6)=XW(1)
      XW(5)=XW(2)
      XW(4)=XW(3)
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE GPOINTS2X2                                              C
C                                                                      C
C 2X2 GAUSS POINTS GENERATION                                          C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
      SUBROUTINE GPOINTS2X2(XP,XW)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER (ZERO=0.D0,ONE=1.D0,HALF=0.5D0)
C
      DIMENSION XP(2,9),XW(9)
C
      CALL CLEARV(XW,9)
      CALL CLEAR(XP,2,9)
C
      DO K1=1,4
        XW(K1)=ONE
      END DO
C
c      XP(1,1)=-0.288675134595
c      XP(2,1)=-0.288675134595
c      XP(1,2)= 0.288675134595
c      XP(2,2)=-0.288675134595
c      XP(1,3)=-0.288675134595
c      XP(2,3)= 0.288675134595
c      XP(1,4)= 0.288675134595
c      XP(2,4)= 0.288675134595
C

      XP(1,1)=-0.577350269189626
      XP(2,1)=-0.577350269189626
      XP(1,2)= 0.577350269189626
      XP(2,2)=-0.577350269189626
      XP(1,3)=-0.577350269189626
      XP(2,3)= 0.577350269189626
      XP(1,4)= 0.577350269189626
      XP(2,4)= 0.577350269189626
c
      RETURN
C
      END
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE GPOINTS7                                              C
C                                                                      C
C     7 GAUSS POINTS FOR TRIANGULAR DOMAINS                            C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE GPOINTS7(XP,XW)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER (ZERO=0.D0,ONE=1.D0,HALF=0.5D0)
C
      DIMENSION XP(2,7),XW(7)
C
      CALL CLEARV(XW,7)
      CALL CLEAR(XP,2,7)
C

      XW(1)=0.1259391805448D0
      XW(2)=XW(1)
      XW(3)=XW(1)
      XW(4)=0.1323941527885D0
      XW(5)=XW(4)
      XW(6)=XW(4)
      XW(7)=0.225D0

C
      XP(1,1)= 0.1012865073235D0
      XP(1,2)= 0.7974269853531D0
      XP(1,3)= 0.1012865073235D0
      XP(1,4)= 0.4701420641051D0
      XP(1,5)= 0.4701420641051D0
      XP(1,6)= 0.0597158717898D0
      XP(1,7)= 0.3333333333333D0
C
      XP(2,1)= XP(1,1)
      XP(2,2)= XP(1,1)
      XP(2,3)= XP(1,2)
      XP(2,4)= XP(1,6)
      XP(2,5)= XP(1,4)
      XP(2,6)= XP(1,4)
      XP(2,7)= XP(1,7)
C
      RETURN
C
      END
C


!Program to test RRSPACING intrinsic function.

program test_rrspacing
  call test_real4(3.0)
  call test_real4(33.0)
  call test_real4(-3.0)
  call test_real8(3.0_8)
  call test_real8(33.0_8)
  call test_real8(-33.0_8)
end
subroutine test_real4(orig)
  real x,y,orig
  integer p
  x = orig
  p = 24
  y = abs (x * 2.0 ** (- exponent (x))) * (2.0 ** p)
  x = rrspacing(x)
  if (abs (x - y) .gt. abs(x * 1e-6)) call abort
end

subroutine test_real8(orig)
  real*8 x,y,t,orig
  integer p
  x = orig
  p = 53
  y = abs (x * 2.0 ** (- exponent (x))) * (2.0 ** p)
  x = rrspacing(x)
  if (abs (x - y) .gt. abs(x * 1e-6)) call abort
end


!==================================================================================================
!>Module: module_grid                                                                             !
!>Details: This module generates a stretched grid and is a modified version of the original code  !
!>=================================================================================================

module module_grid

contains
SUBROUTINE sGrid_Generator(H,N1,ALPHA,YPAD,YHAD)

IMPLICIT NONE

REAL(8),INTENT(IN)				::ALPHA
INTEGER,INTENT(IN)				::N1
REAL(8),DIMENSION(N1),INTENT(INOUT)		::YPAD,YHAD
INTEGER						::J,I
REAL(8)						::ALPHA1,ALPHA2
INTEGER						::N05,N06
REAL(8)						::COEF
REAL(8),INTENT(IN)				::H

ALPHA1=ALPHA
ALPHA2=ALPHA
N05=(N1+1)/2
N06=N05+1

!---  MESH FOR HALF LOWER CHANNEL ---
COEF=DEXP(ALPHA1*(1.-N05))
DO J=2,N05
   YPAD(J)=(.5*(DEXP(ALPHA1*(J-N05))-COEF)/(1.-COEF))*(H)
ENDDO
!---  MESH FOR HALF UPPER CHANNEL ---
COEF=DEXP(ALPHA2*(N05-N1))
DO J=N06,N1-1
  YPAD(J)=(1.-.5*(DEXP(ALPHA2*(N05-J))-COEF)/(1.-COEF))*(H)
ENDDO
!---  NEAR WALL POINTS ---
YPAD(1)=-YPAD(2)
YPAD(N1)=(2.*H)-YPAD(N1-1)
YHAD(1)=0.
DO J=2,N1
  YHAD(J)=YPAD(J)-YPAD(J-1)
ENDDO

!UNCOMMENT this block, if you want to save grid points in a separate file.
!OPEN(12,file='GRID.dat')
!WRITE(12,"(A26,I4,A31,1ES16.8)") '# GRID: NUMBER OF POINTS: ',N1,' STRETCHING COEFFICIENT ALPHA: ',ALPHA
!WRITE(12,*) "#I        YPAD              YHAD"
!DO I=1,N1
!        WRITE(12,11)I,YPAD(I),YHAD(I)
!ENDDO
!11 FORMAT(I3,2x,2(F16.8,2x))
!CLOSE(12)
!print *, "Copying Generated GRID.dat to the directory '../Simulated_Data'"
!call system('cp GRID.dat ../Simulated_Data/GRID.dat')

print *,"Grid Generation Successfull."
end subroutine
end module module_grid


program main
  use AbstractOperators
  !use SimpleVectors
  use DVectors
  use ExampleOperators

  use KrylovSolver
  implicit none
  ! problem vars
  type(Laplacian) :: laplacian_1d
  type(DiagonalMatrix) :: inverse_diagonal_laplacian
  real(kind=double), allocatable :: sol(:)
  real(kind=double), allocatable :: rhs(:)
  integer :: n
  integer :: max_iterations=400
  real(kind=double) :: tolerance=1.0d-5,h,sign

  ! local vars
  integer :: ierr,i,m,j
  real(kind=double), allocatable :: res(:)
  n=100
  h=1.0d0/(n-1)

  !! init matrix
  call laplacian_1d%init(n)

  !! allocate solution and rhs and set the latter
  allocate(sol(n),rhs(n))
  rhs=0
  rhs(1)=1
  rhs(n)=1

  sol=0.0d0
  allocate(res(n))

  !! init diagonal and set values with inverse of
  !! diagonal of the Laplacian
  call inverse_diagonal_laplacian%init(n)
  inverse_diagonal_laplacian%coefficients=1.0d0/(2.0d0)

  write(*,*) d_norm(n,rhs)
  sol=zero
  call pcg(laplacian_1d,rhs,sol,ierr,&
       tolerance=1.0d-3,&
       max_iterations=400)!,&
  !preconditioner=inverse_diagonal_laplacian)

  !! check results

  call laplacian_1d%apply(sol,res,ierr)
  res=res-rhs;
  write(*,*) 'Res=',d_norm(n,res)

end program main


! PR 14396
! These we failing on targets which do not provide the c99 complex math
! functions.
! Extracted from intrinsic77.f in the g77 testsuite.
      logical fail
      common /flags/ fail
      fail = .false.
      call square_root
      if (fail) call abort
      end
      subroutine square_root
      intrinsic sqrt, dsqrt, csqrt
      real x, a
      x = 4.0
      a = 2.0
      call c_r(SQRT(x),a,'SQRT(real)')
      call c_d(SQRT(1.d0*x),1.d0*a,'SQRT(double)')
      call c_c(SQRT((1.,0.)*x),(1.,0.)*a,'SQRT(complex)')
      call c_d(DSQRT(1.d0*x),1.d0*a,'DSQRT(double)')
      call c_c(CSQRT((1.,0.)*x),(1.,0.)*a,'CSQRT(complex)')
      call p_r_r(SQRT,x,a,'SQRT')
      call p_d_d(DSQRT,1.d0*x,1.d0*a,'DSQRT')
      call p_c_c(CSQRT,(1.,0.)*x,(1.,0.)*a ,'CSQRT')
      end
      subroutine failure(label)
!     Report failure and set flag
      character*(*) label
      logical fail
      common /flags/ fail
      write(6,'(a,a,a)') 'Test ',label,' FAILED'
      fail = .true.
      end
      subroutine c_r(a,b,label)
!     Check if REAL a equals b, and fail otherwise
      real a, b
      character*(*) label
      if ( abs(a-b) .gt. 1.0e-5 ) then
         call failure(label)
         write(6,*) 'Got ',a,' expected ', b
      end if
      end
      subroutine c_d(a,b,label)
!     Check if DOUBLE PRECISION a equals b, and fail otherwise
      double precision a, b
      character*(*) label
      if ( abs(a-b) .gt. 1.0d-5 ) then
         call failure(label)
         write(6,*) 'Got ',a,' expected ', b
      end if
      end

      subroutine c_c(a,b,label)
!     Check if COMPLEX a equals b, and fail otherwise
      complex a, b
      character*(*) label
      if ( abs(a-b) .gt. 1.0e-5 ) then
         call failure(label)
         write(6,*) 'Got ',a,' expected ', b
      end if
      end
      subroutine p_r_r(f,x,a,label)
!     Check if REAL f(x) equals a for REAL x
      real f,x,a
      character*(*) label
      call c_r(f(x),a,label)
      end
      subroutine p_d_d(f,x,a,label)
!     Check if DOUBLE PRECISION f(x) equals a for DOUBLE PRECISION x
      double precision f,x,a
      character*(*) label
      call c_d(f(x),a,label)
      end
      subroutine p_c_c(f,x,a,label)
!     Check if COMPLEX f(x) equals a for COMPLEX x
      complex f,x,a
      character*(*) label
      call c_c(f(x),a,label)
      end


! Matrix and vector multipication

program arrayDotProduct
    implicit none

    real,dimension(5):: a,b
    INTEGER:: i, j, asize, bsize

    asize = SIZE(a)
    bsize = size(b)

    do i = 1, asize
        a(i) = i
        end do

    do j = 1, bsize
        b(j) =  j*2
    end do

    do i = 1, asize
        PRINT*, a(i)
    end do

    do j = 1, bsize
        PRINT*, b(j)
    end do

    PRINT*, 'Dot Product: }'
    PRINT*, DOT_PRODUCT(a, b)
end program arrayDotProduct


program P1
  !  integrate exp(-x) from [-1,+1] by trapezoid algorithm
  implicit none
  integer :: i
  integer, dimension(4) :: N
  real*8 :: f_n,f_a,x0=-1,xf=1
  real*8, external :: f
  N = (/10,50,100,200/)
  f_a = -exp(x0)+exp(xf)

  do i = 1,4
     call trap(f,x0,xf,N(i),f_n)
     print *,N(i),f_n-f_a,(f_n-f_a)/f_a
  enddo

end program P1

subroutine trap(f,x0,xf,N,sum)
  implicit none
  real*8, intent(in) :: x0,xf
  integer, intent(in) :: N
  real*8, external :: f
  real*8, intent(out) :: sum
  real*8 :: h
  integer :: i
  sum = 0.5 * f(x0)
  h = (xf-x0)*1.0/N
  do i=1,N
     sum = sum + f(x0+i*h)
  enddo
  sum = (sum + f(xf))*h
end subroutine trap

real*8 function f(x)
  implicit none
  real*8, intent(in) :: x
  f=exp(-x)
end function f


! The Computer Language Benchmarks Game
! https://salsa.debian.org/benchmarksgame-team/benchmarksgame/
!
! Author: Jannis Teunissen
! Heavily based on Fortran code contributed by Pascal Parois
!
! Compilation:
! gfortran -pipe -O3 -fomit-frame-pointer -march=core2 \
!          -fopenmp mandelbrot.f90 -o mandelbrot
! ifort -O3 -march=core2 -qopenmp mandelbrot.f90 -o mandelbrot
program mandelbrot
  use iso_fortran_env, dp => real64

  implicit none

  integer, parameter  :: max_iterations = 50 ! How many Mandelbrot iterations
  integer, parameter  :: buf_size       = 32 ! Buffer size for arrays
  real(dp), parameter :: threshold      = 4.0_dp ! Threshold for iterations

  integer                       :: i, j, k, n, pos, my_unit
  integer                       :: bytepos, nx, width
  integer(int8), allocatable    :: buffer(:, :)
  real(dp), dimension(buf_size) :: cr, ci, zr, zi, tr, ti
  real(dp)                      :: cte
  real(dp), allocatable         :: cr_values(:), ci_values(:)
  character(len=64)             :: argv, header
  character(len=:), allocatable :: char_output
  character(len=*), parameter   :: output_style = "multiple_strings"

  ! Get bitmap size from command line argument
  call get_command_argument(1, argv)
  read(argv, *) width

  ! Determine smallest multiple of buf_size greater or equal to width
  nx = ceiling(width/real(buf_size, dp)) * buf_size

  ! Allocate results buffer
  allocate(buffer(nx/8, width))
  buffer = 0

  ! Set complex coordinates from [-1.5 - i -- 0.5 + i]
  allocate(cr_values(nx))
  allocate(ci_values(width))
  cte = 2.0_dp/width ! Step size
  cr_values = [(cte * i - 1.5_dp, i = 0, nx-1)]
  ci_values = [(cte * i - 1, i = 0, width-1)]

  !$omp parallel do private(i, j, k, n, bytepos, pos) &
  !$omp private(zr, zi, cr, ci, tr, ti) schedule(guided)
  do i = 1, width
     pos     = 1
     bytepos = 8
     ci      = ci_values(i)

     do j = 1, nx, buf_size
        ! Set initial values (together with ci above)
        cr = cr_values(j:j+buf_size-1)
        zr = 0.0_dp
        zi = 0.0_dp
        tr = 0.0_dp
        ti = 0.0_dp

        ! Perform very simple loop unrolling
        do k = 1, max_iterations/2
           ! Update the real and complex parts
           zi = 2*zr*zi+ci
           zr = tr-ti+cr
           ti = zi*zi
           tr = zr*zr
           ! One more update
           zi = 2*zr*zi+ci
           zr = tr-ti+cr
           ti = zi*zi
           tr = zr*zr

           ! Check if all values have exceeded the threshold
           if (all(tr + ti > threshold)) exit
        end do

        ! Store results in buffer
        do k = 1, buf_size
           ! Pack boolean values into bytes
           bytepos = bytepos - 1
           if (tr(k)+ti(k) < threshold .and. j <= width) then
              buffer(pos, i) = ibset(buffer(pos, i), bytepos)
           end if

           ! Advance at the end of the byte
           if (bytepos == 0) then
              bytepos = 8
              pos     = pos + 1
           end if
        end do
     end do
  end do
  !$omp end parallel do

  ! pbm header
  write(header, "(a,i0,a,i0,a)") "P4" // new_line("a"), &
       width, " ", width, new_line("a")

  i = ceiling(width/8.0_dp)

  ! Fortran allows to write binary output (stream access) to files, but not to
  ! stdout. Some tricks are therefore required.

  select case (output_style)
  case ("one_big_string")
     ! Convert binary data to one big string
     allocate(character(len=i*width) :: char_output)
     char_output = transfer(buffer(1:i, :), char_output)
     write(*, '(a)', advance='no') trim(header)
     write(*, '(a)', advance='no') char_output
  case ("multiple_strings")
     ! This avoids problems with ifort for larger output sizes
     allocate(character(len=i) :: char_output)
     write(*, '(a)', advance='no') trim(header)
     do j = 1, width
        char_output = transfer(buffer(1:i, j), char_output)
        write(*, '(a)', advance='no') char_output
     end do
  case default
     ! Write unformatted data to stdout, by opening it as a file
     open(newunit=my_unit, file="/dev/stdout", access='stream', &
          form='unformatted', action='write')
     write(my_unit) trim(header)
     write(my_unit) buffer(1:i, :)
     flush(my_unit)
     close(my_unit)
  end select

end program mandelbrot


!
! The Laboratory of Algorithms
!
! The MIT License
!
! Copyright 2011-2015 Andrey Pudov.
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the 'Software'), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
!

! A Pythagorean triplet is a set of three natural numbers, a < b < c, for which,
!
!          a^2 + b^2 = c^2
!
! For example, 3^2 + 4^2 = 9 + 16 = 25 = 5^2.
! There exists exactly one Pythagorean triplet for which a + b + c = 1000.
! Find the product abc.
module MPEProblem9

    implicit none
    private

    type, public :: TPEProblem9
    contains
        procedure, nopass :: present
    end type
contains
    subroutine present
        write (*, '(A)') 'Problem 9. Special Pythagorean triplet.'

        write (*, '(A, I)') 'Product 1: ', product1()
    end subroutine

    pure function product1()
        integer, parameter:: limit = 1000
        integer product1
        integer a
        integer b
        integer c

        ! initial value
        product1 = 0

        do c = 1, limit
            do b = 1, c - 1
                do a = 1, b - 1
                    if (a + b + c .eq. limit) then
                        if ((a**2) + (b**2) .eq. (c**2)) then
                            product1 = a * b * c

                            return
                        end if
                    end if
                end do
            end do
        end do
    end function
end module


module mod_arrays

  ! Utility functions that operate on arrays.

  implicit none

  private
  public :: argsort, average, crossneg, crosspos, intdate, moving_average,&
            moving_std, reverse, std

contains

  pure function argsort(x) result(a)
    ! Returns indices that sort x from low to high.
    real, intent(in):: x(:)
    integer :: a(size(x))
    integer :: i, i0, tmp1
    real :: tmp2
    real :: xwork(size(x))
    a = [(real(i), i = 1, size(x))]
    xwork = x
    do i = 1, size(x) - 1
      i0 = minloc(xwork(i:), 1) + i - 1
      if (i0 /= i) then
        tmp2 = xwork(i)
        xwork(i) = xwork(i0)
        xwork(i0) = tmp2
        tmp1 = a(i)
        a(i) = a(i0)
        a(i0) = tmp1
      end if
    end do
  end function argsort

  pure real function average(x)
    ! Returns a average of x.
    real, intent(in) :: x(:)
    average = sum(x) / size(x)
  end function average

  pure function crossneg(x, w) result(res)
    ! Returns indices where input array x crosses its
    ! moving average with window w from positive to negative.
    real, intent(in) :: x(:)
    integer, intent(in) :: w
    integer, allocatable :: res(:)
    real, allocatable :: xavg(:)
    logical, allocatable :: greater(:), smaller(:)
    integer :: i
    res = [(i, i = 2, size(x))]
    xavg = moving_average(x, w)
    greater = x > xavg
    smaller = x < xavg
    res = pack(res, smaller(2:) .and. greater(:size(x)-1))
  end function crossneg

  pure function crosspos(x, w) result(res)
    ! Returns indices where input array x crosses its
    ! moving average with window w from negative to positive.
    real, intent(in) :: x(:)
    integer, intent(in) :: w
    integer, allocatable :: res(:)
    real, allocatable :: xavg(:)
    logical, allocatable :: greater(:), smaller(:)
    integer :: i
    res = [(i, i = 2, size(x))]
    xavg = moving_average(x, w)
    greater = x > xavg
    smaller = x < xavg
    res = pack(res, greater(2:) .and. smaller(:size(x)-1))
  end function crosspos

  pure elemental integer function intdate(t)
    ! Converts a time stamp in format YYYY-mm-dd to integer.
    character(len=10), intent(in) :: t
    character(len=8) :: str
    str = t(1:4) // t(6:7) // t(9:10)
    read(str, *) intdate
  end function intdate

  pure function moving_average(x, w) result(res)
    ! Returns the moving average of x with one-sided window w.
    real, intent(in) :: x(:)
    integer, intent(in) :: w
    real :: res(size(x))
    integer :: i, i1
    do i = 1, size(x)
      i1 = max(i-w, 1)
      res(i) = average(x(i1:i))
    end do
  end function moving_average

  pure function moving_std(x, w) result(res)
    ! Returns the moving standard deviation of x with one-sided window w.
    real, intent(in) :: x(:)
    integer, intent(in) :: w
    real :: res(size(x))
    integer :: i, i1
    do i = 1, size(x)
      i1 = max(i-w, 1)
      res(i) = std(x(i1:i))
    end do
  end function moving_std

  pure function reverse(x)
    ! Reverses the order of elements of x.
    real, intent(in) :: x(:)
    real :: reverse(size(x))
    reverse = x(size(x):1:-1)
  end function reverse

  pure real function std(x)
    ! Returns the standard deviation of x.
    real, intent(in) :: x(:)
    std = sqrt(average((x - average(x))**2))
  end function std

end module mod_arrays


program SunDial

  real    :: lat, slat, lng, ref
  real    :: hra, hla
  integer :: h

  real, parameter :: pi = 3.14159265358979323846

  print *, "Enter latitude"
  read *, lat
  print *, "Enter longitude"
  read *, lng
  print *, "Enter legal meridian"
  read *, ref

  print *

  slat = sin(dr(lat))
  write(*, '(A,1F6.3)') "sine of latitude: ", slat
  write(*, '(A,1F6.3)') "diff longitude: ", lng - ref

  print *, "Hour, sun hour angle, dial hour line angle from 6am to 6pm"

  do h = -6, 6
     hra = 15.0*h
     hra = hra - lng + ref
     hla = rd( atan( slat * tan( dr(hra) ) ) )
     write(*, '(" HR= ",I3,";  \t  HRA=",F7.3,";  \t  HLA= ", F7.3)'), h, hra, hla
  end do

contains

  function dr(angle)
    real :: dr
    real, intent(in) :: angle
    dr = angle*pi/180.0
  end function dr

  function rd(angle)
    real :: rd
    real, intent(in) :: angle
    rd = angle*180.0/pi
  end function rd

end program SunDial


C$Procedure      HYPTOF ( Hyperbolic time of flight )

      SUBROUTINE HYPTOF ( MA, ECC, F )

C$ Abstract
C
C     Solve the time of flight equation MA = e sinh(F) - F for the
C     hyperbolic eccentric anomaly F, given the mean anomaly, MA,
C     and the eccentricity, e.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     CONIC
C
C$ Declarations

      DOUBLE PRECISION      MA
      DOUBLE PRECISION      ECC
      DOUBLE PRECISION      F

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     MA         I   Mean anomaly at epoch.
C     ECC        I   Eccentricity.
C     F          O   Hyperbolic eccentric anomaly.
C
C$ Detailed_Input
C
C     MA          is the hyperbolic mean anomaly of an orbiting body at
C                 some epoch t,
C
C                                         3 1/2
C                       MA = (t-T)(mu/(-a) )
C
C                 where T is the time of periapsis passage, a is
C                 the semi-major axis of the orbit, and mu is the
C                 gravitational parameter of the primary body.
C
C     ECC         is the eccentricity of the orbit.
C
C$ Detailed_Output
C
C     F           is the corresponding eccentric anomaly. This is the
C                 solution to the time of flight equation
C
C                       MA = e sinh(F) - F
C
C$ Parameters
C
C      None.
C
C$ Exceptions
C
C     1) If the eccentricity (ECC) is less than one, the error
C        'SPICE(WRONGCONIC)' is signaled.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     Iterate to solve
C
C           f(F,MA,e) = e sinh(F) - F - MA = 0
C
C$ Examples
C
C     ELLTOF, HYPTOF, and PARTOF are used by CONICS.
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     [1] Roger Bate, Fundamentals of Astrodynamics, Dover, 1971.
C
C$ Author_and_Institution
C
C     I.M. Underwood  (JPL)
C     W.L. Taber      (JPL)
C
C$ Version
C
C-    SPICELIB Version 3.1.0, 13-JUL-2007 (NJB)
C
C        Bug fix: MAXLOG is now saved.
C
C-    SPICELIB Version 3.0.0, 14-DEC-1994 (WLT)
C
C        A counter was placed in the loop which bisects to a
C        solution to the hyperbolic version of Kepler's equation.
C        This addition forces the loop to terminate.  On some platforms
C        the loop would not terminate without this additional
C        check.  This was due to the compiler performing tests on
C        extended precision registers.
C
C-    SPICELIB Version 2.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 2.0.0, 19-APR-1990 (WLT)
C
C        A bad initial guess at bracketing the solution to the
C        hyperbolic time of flight equation was corrected so that
C        floating point overflows are now avoided.  In addition, the
C        Newton's method used before has been replaced by simply
C        bisection.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (IMU)
C
C-&

C$ Index_Entries
C
C     hyperbolic time of flight
C
C-&

C$ Revisions
C
C-    SPICELIB Version 3.0.0, 14-DEC-1994 (WLT)
C
C        A counter was placed in the loop which bisects to a
C        solution to the hyperbolic version of Kepler's equation.
C        This addition forces the loop to terminate.  On some platforms
C        the loop would not terminate without this additional
C        check.  This was due to the compiler performing tests on
C        extended precision registers.
C
C        This is not due to a bug in the algorithm but rather to
C        what NAIF feels is an error on the part of some compiler
C        vendors.  If the difference between two d.p. numbers is
C        zero to double precision we feel that that is the number
C        that should be used in subsequent statements---ESPECIALLY
C        in comparisons.  However, since we don't have control
C        over how compiler writers decide to compile code, we have
C        added the loop counter to guarantee that the loop solving
C        the hyperbolic Kepler's equation terminates.
C
C-    SPICELIB Version 2.0.0, 19-APR-1990 (WLT)
C
C        A bad initial guess at bracketing the solution to the
C        hyperbolic time of flight equation was corrected so that
C        floating point overflows are now avoided.  In addition, the
C        Newton's method used before has been replaced by simply
C        bisection.
C
C-    Beta Version 1.1.1, 27-JAN-1989 (IMU)
C
C        Examples section completed.
C
C-&

C$ Revisions
C
C-    Beta Version 1.1.0, 8-JAN-1989 (IMU)
C
C        The routine now verifies that the eccentricity is in the
C        proper range---(1,+infinity)---before proceeding.
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      DPMAX
      DOUBLE PRECISION      DCBRT

      LOGICAL               RETURN

C
C     Local variables
C
      INTEGER               COUNT
      INTEGER               MCOUNT

      DOUBLE PRECISION      MAXLOG

      DOUBLE PRECISION      M

      DOUBLE PRECISION      LOWER
      DOUBLE PRECISION      MIDDLE
      DOUBLE PRECISION      MIDVAL
      DOUBLE PRECISION      UPPER

      DOUBLE PRECISION      DIFF
      DOUBLE PRECISION      LASTDF

      LOGICAL               FIRST

C
C     Saved variables
C
      SAVE                  FIRST
      SAVE                  MAXLOG

C
C     Initial values
C
      DATA                  FIRST   / .TRUE. /

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'HYPTOF' )
      END IF

      IF ( FIRST ) THEN
         FIRST  = .FALSE.
         MAXLOG = LOG ( DPMAX() )
      END IF

      IF ( ECC .LT. 1.D0 ) THEN
         CALL SIGERR ( 'SPICE(WRONGCONIC)' )
         CALL CHKOUT ( 'HYPTOF'            )
         RETURN
      END IF

C
C     For reasons of numerical stability, we have to intercept cases
C     where the mean anomaly is zero or negative (since log x is not
C     defined for non-positive x). If the mean anomaly is zero, the
C     eccentric anomaly is also zero (by inspection).
C
C     Since the function e sinh(F) - F is an odd function, we can
C     solve the equation ABS(MA) = e sinh(F) - F for F and get
C     the solution to MA = e sinh(F) - F by negating F if MA is
C     less than 0.
C
      IF ( MA .EQ. 0.D0 ) THEN
         F = 0.D0
         CALL CHKOUT ( 'HYPTOF' )
         RETURN
      ELSE
         M = ABS ( MA )
      END IF

C
C     The initial bounds for the eccentric anomaly F are determined
C     as follows:
C
C     For the value of F we seek,
C
C        M = e sinh F - F
C
C     Thus
C
C        M < e sinh F =    (e/2) { Exp(F) - Exp(-F)}
C
C     Hence
C
C        2 M                1
C        ---   < Exp(F) - -----
C         e               Exp(F)
C
C     which yields
C
C
C        2 M Exp(F)
C        ----------   < Exp(F)**2 - 1
C            e
C
C     and
C
C           M**2                2M Exp(F)     M**2
C       1 + ---- <  Exp(F)**2 - ---------  +  ---- = {Exp(F) - (M/e)}**2
C           e**2                   e          e**2
C
C
C     Therefore we must have one of the following be true.
C
C
C      SQRT( 1 + (M/e)**2 )  <  Exp(F) - (M/e)
C
C    or
C
C     - SQRT( 1 + (M/e)**2 )  >  Exp(F) - (M/e)
C
C    The second case implies that
C
C     0 > (M/e) - SQRT( 1 + (M/e)**2 ) > Exp(F)
C
C    but since Exp(F) > 0 for all F it must be the case that
C
C      (M/e) + SQRT( 1 + (M/e)**2 ) < Exp(F)
C
C
C    Hence
C
C       Log ( (M/e) + SQRT(1 + (M/e)**2) )  < F
C
C
C
C     Returning to our initial equation:
C
C        M = e sinh F - F
C
C                         3        5
C                        F        F
C          =  e ( F  +  ---   +  --- + ...   )  -  F
C                        3!       5!
C
C               3
C          >  eF / 6
C
C     Thus
C
C
C             3 __________
C        F <  \/  6M / e
C
C
C     Thus our solution must satisfy the inequalities
C
C
C                                                      3 __________
C      LOG ( (M/e) + SQRT(1 + (M/e)**2) )  <   F   <   \/  6M/e
C
C
C     In addition we know that the solution must lie somewhere
C     in the region between 0 and the maximum value of F for which
C     (e sinh F - F) can be computed.  This turns out to be
C     approximately LOG( DPMAX() / e ) = LOG(DPMAX()) - LOG(e) .
C
C
      LOWER = LOG ( (M/ECC)  +  DSQRT( 1.0D0 + (M/ECC)**2 ) )
      UPPER = MIN ( DCBRT(6.0D0*M/ECC), MAXLOG - LOG (ECC ) )
      UPPER = MAX ( LOWER, UPPER )
C
C     Perform some simple checks first to avoid problems with
C     convergence of the loop below.  If LOWER is zero, then
C     M/ECC is so small that when added to 1 it doesn't make
C     any difference ( dLOG/dt = 1 at 1 after all).  So in this
C     case we will just solve the linear portion of the
C     expansion of e SINH(F) - F = M
C
C
C     Now we simply perform bisection to locate the root.
C
      MIDDLE = MAX( LOWER, MIN( UPPER, 0.5D0*UPPER + 0.5D0*LOWER ) )
      MIDVAL = ECC * SINH(MIDDLE) - MIDDLE - M

      DIFF   = UPPER - LOWER
C
C     Finally pick a reasonable upper bound on the number of loop
C     iterations we shall need to perform.
C
      MCOUNT = 100
      COUNT  = 0
      DO WHILE ( DIFF .GT. 0.0D0 .AND. COUNT .LT. MCOUNT )

C
C        Move one of the endpoints to the middle.
C
         IF ( MIDVAL .GT. 0.0D0 ) THEN

            UPPER = MIDDLE

         ELSE IF ( MIDVAL .LT. 0.0D0 ) THEN

            LOWER = MIDDLE

         ELSE

            LOWER = MIDDLE
            UPPER = MIDDLE

         END IF

C
C        Compute the next middle point.
C
         MIDDLE = MAX( LOWER, MIN( UPPER, 0.5D0*UPPER + 0.5D0*LOWER ) )
         LASTDF = DIFF
         COUNT  = COUNT + 1

C
C        If we are on an endpoint, we are ready to call it quits.
C
         IF (      ( MIDDLE .EQ. LOWER )
     .        .OR. ( MIDDLE .EQ. UPPER ) ) THEN

            DIFF   = 0.0D0

         ELSE

            DIFF   = UPPER - LOWER
            MIDVAL = ECC * SINH ( MIDDLE ) - MIDDLE - M

         END IF

      END DO

C
C     Restore the proper sign, if necessary.
C
      IF ( MA .LT. 0 ) THEN
         F = - MIDDLE
      ELSE
         F =   MIDDLE
      END IF

      CALL CHKOUT ( 'HYPTOF' )
      RETURN
      END


      SUBROUTINE MATINV (A, N)
C
C     MATINV - INVERTS A REAL SQUARE (N BY N) MATRIX A AND STORES
C        THE RESULTANT INVERSE BACK IN A.  THE METHOD USED IS GAUSS-
C        JORDAN ELIMINATION WITH COMPLETE PIVOTING (SEE, FOR EXAMPLE,
C        A.RALSTON AND H.S.WILF (1967), MATHEMATICAL METHODS FOR
C        DIGITAL COMPUTERS, VOL. 2,  ARTICLE BY J.H.WILKINSON.)
C     THIS ROUTINE IS SHARE NO. ANL F402 BY B.S.GARBOW OF ARGONNE
C     NATIONAL LABORATORY, ARGONNE, ILLINOIS
C
      DIMENSION A (20, 20)
C
      COMMON /PON /INDEX (20, 2), IPIVOT (20), PIVOT (20)
C
C.....INITIALIZE........................................................
      DETERM = 1.0
      IF (N .LT. 1) GO TO 160
      DO 100 J = 1, N
 100  IPIVOT (J) = 0
 160  CONTINUE
      IF (N .LT. 1) GO TO 165
      DO 140 I = 1, N
C.....SEARCH FOR PIVOTAL ELEMENT........................................
      TEMP = 0.0
      IF (N .LT. 1) GO TO 170
      DO 115 J1 = 1, N
      IF (IPIVOT (J1) .EQ. 1) GO TO 115
      IF (N .LT. 1) GO TO 175
      DO 110 K = 1, N
      IF (IPIVOT (K) - 1)105, 110, 155
 105  IF (ABS (TEMP) .GT. ABS (A (J1, K))) GO TO 110
      IROW = J1
      ICOLUM = K
      TEMP = A (J1, K)
 110  CONTINUE
 175  CONTINUE
 115  CONTINUE
 170  CONTINUE
      IPIVOT (ICOLUM) = IPIVOT (ICOLUM) + 1
C.....INTERCHANGE ROWS TO PUT PIVOTAL ELEMENT ON DIAGONAL...............
      IF (IROW .EQ. ICOLUM) GO TO 125
      DETERM = - DETERM
      IF (N .LT. 1) GO TO 180
      DO 120 L = 1, N
      TEMP = A (IROW, L)
      A (IROW, L) = A (ICOLUM, L)
 120  A (ICOLUM, L) = TEMP
 180  CONTINUE
 125  INDEX (I, 1) = IROW
      INDEX (I, 2) = ICOLUM
      PIVOT (I) = A (ICOLUM, ICOLUM)
      DETERM = DETERM * PIVOT (I)
      IF (DETERM .EQ. 0.0) GO TO 155
C.....DIVIDE PIVOTAL ROW BY PIVOTAL ELEMENT.............................
      A (ICOLUM, ICOLUM) = 1.0
      IF (N .LT. 1) GO TO 185
      DO 130 L1 = 1, N
 130  A (ICOLUM, L1) = A (ICOLUM, L1) / PIVOT (I)
 185  CONTINUE
C.....REDUCE NON-PIVOTAL ROWS...........................................
      IF (N .LT. 1) GO TO 190
      DO 140 I1 = 1, N
      IF (I1 .EQ. ICOLUM) GO TO 140
      TEMP = A (I1, ICOLUM)
      A (I1, ICOLUM) = 0.0
      IF (N .LT. 1) GO TO 195
      DO 135 L2 = 1, N
 135  A (I1, L2) = A (I1, L2) - A (ICOLUM, L2) * TEMP
 195  CONTINUE
 140  CONTINUE
 190  CONTINUE
 165  CONTINUE
C.....INTERCHANGE COLUMNS (TO UNDO THE SWAP TO GET MAX PIVOT ON DIAG)...
      IF (N .LT. 1) GO TO 200
      DO 150 I2 = 1, N
      LL = N + 1 - I2
      IF (INDEX (LL, 1) .EQ. INDEX (LL, 2)) GO TO 150
      IROW = INDEX (LL, 1)
      ICOLUM = INDEX (LL, 2)
      IF (N .LT. 1) GO TO 205
      DO 145 K1 = 1, N
      TEMP = A (K1, IROW)
      A (K1, IROW) = A (K1, ICOLUM)
 145  A (K1, ICOLUM) = TEMP
 205  CONTINUE
 150  CONTINUE
 200  CONTINUE
 155  RETURN
      END


!
!     file hstcyl.f90
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2005 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Fishpack                              *
!     *                                                               *
!     *                      A Package of Fortran                     *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *               for Modeling Geophysical Processes              *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
! SUBROUTINE hstcyl(a, b, m, mbdcnd, bda, bdb, c, d, n, nbdcnd, bdc, bdd,
!            elmbda, f, idimf, pertrb, ierror)
!
! DIMENSION OF           bda(n), bdb(n), bdc(m), bdd(m), f(idimf, n)
! ARGUMENTS
!
! LATEST REVISION        April 2016
!
! PURPOSE                Solves the standard five-point finite
!                        difference approximation on a staggered
!                        grid to the modified helmholtz equation
!                        in cylindrical coordinates. this equation
!
!                          (1/r)(d/dr)(r(du/dr)) + (d/dz)(du/dz)
!
!                          + lambda*(1/r**2)*u = f(r, z)
!
!                        Is a two-dimensional modified helmholtz
!                        equation resulting from the fourier transform
!                        of a three-dimensional poisson equation.
!
! USAGE                  call hstcyl(a, b, m, mbdcnd, bda, bdb, c, d, n, &
!                        nbdcnd, bdc, bdd, elmbda, f, idimf, pertrb, ierror)
!
! ARGUMENTS
! ON INPUT               a, b
!
!                          the range of r, i.e. a <= r <= b.
!                          a must be less than b and a must be
!                          be non-negative.
!
!                        m
!                          the number of grid points in the interval
!                          (a, b).  the grid points in the r-direction
!                          r-direction are given by
!                          r(i) = a + (i-0.5)dr for i=1, 2, ..., m
!                          where dr =(b-a)/m.
!                          m must be greater than 2.
!
!                        mbdcnd
!                          indicates the type of boundary conditions
!                          at r = a and r = b.
!
!                          = 1  if the solution is specified at r = a
!                               (see note below) and r = b.
!
!                          = 2  If the solution is specified at r = a
!                               (see note below) and the derivative
!                               of the solution with respect to r is
!                               specified at r = b.
!
!                          = 3  If the derivative of the solution
!                               with respect to r is specified at
!                               r = a (see note below) and r = b.
!
!                          = 4  If the derivative of the solution
!                               with respect to r is specified at
!                               r = a (see note below) and the
!                               solution is specified at r = b.
!
!                          = 5  If the solution is unspecified at
!                               r = a = 0 and the solution is
!                               specified at r = b.
!
!                          = 6  If the solution is unspecified at
!                               r = a = 0 and the derivative of the
!                               solution with respect to r is specified
!                               at r = b.
!
!                          note:
!                          If a = 0, do not use mbdcnd = 1, 2, 3, or 4,
!                          but instead use mbdcnd = 5 or 6.
!                          The resulting approximation gives the only
!                          meaningful boundary condition,
!                          i.e. du/dr = 0
!                          (see d. greenspan, 'Introductory numerical
!                          analysis of elliptic boundary value
!                          problems, ' Harper and Row, 1965, Chapter 5.)
!
!                        bda
!                          A one-dimensional array of length n that
!                          specifies the boundary values (if any)
!                          of the solution at r = a.
!
!                          When mbdcnd = 1 or 2,
!                            bda(j) = u(a, z(j)) ,       j=1, 2, ..., n.
!
!                          When mbdcnd = 3 or 4,
!                            bda(j) = (d/dr)u(a, z(j)) ,   j=1, 2, ..., n.
!
!                          When mbdcnd = 5 or 6, bda is a dummy
!                          variable.
!
!                        bdb
!                          A one-dimensional array of length n that
!                          specifies the boundary values of the
!                          solution at r = b.
!
!                          When mbdcnd = 1, 4, or 5,
!                            bdb(j) = u(b, z(j)) ,        j=1, 2, ..., n.
!
!                          When mbdcnd = 2, 3, or 6,
!                            bdb(j) = (d/dr)u(b, z(j)) ,   j=1, 2, ..., n.
!
!                        c, d
!                          The range of z, i.e. c <= z <= d.
!                          c must be less than d.
!
!                        n
!                          The number of unknowns in the interval
!                          (c, d).  the unknowns in the z-direction
!                          are given by z(j) = c + (j-0.5)dz,
!                          j=1, 2, ..., n, where dz = (d-c)/n.
!                          n must be greater than 2.
!
!                        nbdcnd
!                          Indicates the type of boundary conditions
!                          at z = c  and z = d.
!
!                          = 0  If the solution is periodic in z, i.e.
!                               u(i, j) = u(i, n+j).
!
!                          = 1  If the solution is specified at z = c
!                               and z = d.
!
!                          = 2  If the solution is specified at z = c
!                               and the derivative of the solution with
!                               respect to z is specified at z = d.
!
!                          = 3  If the derivative of the solution with
!                               respect to z is specified at z = c
!                               and z = d.
!
!                          = 4  If the derivative of the solution with
!                               respect to z is specified at z = c and
!                               the solution is specified at z = d.
!
!                        bdc
!                          A one dimensional array of length m that
!                          specifies the boundary values of the
!                          solution at z = c.
!
!                          when nbdcnd = 1 or 2,
!                            bdc(i) = u(r(i), c) ,        i=1, 2, ..., m.
!
!                          when nbdcnd = 3 or 4,
!                            bdc(i) = (d/dz)u(r(i), c),    i=1, 2, ..., m.
!
!                          when nbdcnd = 0, bdc is a dummy variable.
!
!                        bdd
!                          A one-dimensional array of length m that
!                          specifies the boundary values of the
!                          solution at z = d.
!
!                          when nbdcnd = 1 or 4,
!                            bdd(i) = u(r(i), d) ,       i=1, 2, ..., m.
!
!                          when nbdcnd = 2 or 3,
!                            bdd(i) = (d/dz)u(r(i), d) ,   i=1, 2, ..., m.
!
!                          when nbdcnd = 0, bdd is a dummy variable.
!
!                        elmbda
!                          The constant lambda in the modified
!                          helmholtz equation. If lambda is greater
!                          than 0, a solution may not exist.
!                          however, hstcyl will attempt to find a
!                          solution.  lambda must be zero when
!                          mbdcnd = 5 or 6.
!
!                        f
!                          A two-dimensional array that specifies
!                          the values of the right side of the
!                          modified helmholtz equation.
!                          for i=1, 2, ..., m   and j=1, 2, ..., n
!                            f(i, j) = f(r(i), z(j)) .
!                          f must be dimensioned at least m x n.
!
!                        idimf
!                          the row (or first) dimension of the array
!                          f as it appears in the program calling
!                          hstcyl.  this parameter is used to specify
!                          the variable dimension of f.  idimf must
!                          be at least m.
!
! ON OUTPUT
!
!                        f
!                          Contains the solution u(i, j) of the finite
!                          difference approximation for the grid point
!                          (r(i), z(j)) for  i=1, 2, ..., m, j=1, 2, ..., n.
!
!                        pertrb
!                          If a combination of periodic, derivative,
!                          or unspecified boundary conditions is
!                          specified for a poisson equation
!                          (lambda = 0), a solution may not exist.
!                          pertrb is a constant, calculated and
!                          subtracted from f, which ensures that a
!                          solution exists.  hstcyl then computes
!                          this solution, which is a least squares
!                          solution to the original approximation.
!                          this solution plus any constant is also
!                          a solution; hence, the solution is not
!                          unique. The value of pertrb should be
!                          small compared to the right side f.
!                          Otherwise, a solution is obtained to an
!                          essentially different problem.
!                          This comparison should always be made to
!                          insure that a meaningful solution has been
!                          obtained.
!
!                        ierror
!                          An error flag that indicates invalid input
!                          parameters. Except to numbers 0 and 11,
!                          a solution is not attempted.
!
!                          =  0  no error
!
!                          =  1  a < 0
!
!                          =  2  a >= b
!
!                          =  3  mbdcnd < 1 or mbdcnd > 6
!
!                          =  4  c >= d
!
!                          =  5  n <= 2
!
!                          =  6  nbdcnd < 0 or nbdcnd > 4
!
!                          =  7  a = 0 and mbdcnd = 1, 2, 3, or 4
!
!                          =  8  a > 0 and mbdcnd >= 5
!
!                          =  9  m <= 2
!
!                          = 10  idimf < m
!
!                          = 11  lambda > 0
!
!                          = 12  a=0, mbdcnd >= 5, elmbda /= 0
!
!                          Since this is the only means of indicating
!                          a possibly incorrect call to hstcyl, the
!                          user should test ierror after the call.
!
!                          = 20 If the dynamic allocation of real and
!                               complex workspace required for solution
!                               fails (for example if n, m are too large
!                               for your computer)
! I/O                    None
!
! PRECISION              64-bit precision float and 32-bit precision integer
!
! REQUIRED LIBRARY       type_FishpackWrapper.f90
! FILES                  genbun.f90, type_CyclicReductionUtility.f9090, poistg.f90
!
! STANDARD               Fortran 2008
!
! HISTORY                * Written by Roland Sweet at NCAR in 1977.
!                          released on NCAR's public software libraries
!                          in January 1980.
!                        * Revised in June 2004 by John Adams using
!                          Fortran 90 dynamically allocated workspace.
!                        * Revised in April 2016 by Jon Lo Kim Lin
!                          using object-oriented features of Fortran 2008
!
! ALGORITHM              This subroutine defines the finite-difference
!                        equations, incorporates boundary data, adjusts
!                        the right side when the system is singular and
!                        calls either poistg or genbun which solves the
!                        linear system of equations.
!
! TIMING                 For large m and n, the operation count
!                        is roughly proportional to m*n*log2(n).
!
! ACCURACY               The solution process results in a loss
!                        of no more than four significant digits
!                        for n and m as large as 64.
!                        more detailed information about accuracy
!                        can be found in the documentation for
!                        subroutine poistg which is the routine that
!                        actually solves the finite difference
!                        equations.
!
! REFERENCES             U. Schumann and R. Sweet, "A direct method for
!                        the solution of poisson's equation with neumann
!                        boundary conditions on a staggered grid of
!                        arbitrary size, " J. Comp. Phys. 20(1976),
!                        pp. 171-182.
!
submodule(staggered_helmholtz_solvers) staggered_cylindrical_solver

contains

    module subroutine hstcyl(a, b, m, mbdcnd, bda, bdb, c, d, n, nbdcnd, bdc, &
        bdd, elmbda, f, idimf, pertrb, ierror)
        !-----------------------------------------------
        ! Dummy arguments
        !-----------------------------------------------
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: mbdcnd
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: nbdcnd
        integer(ip), intent(in)     :: idimf
        integer(ip), intent(out)    :: ierror
        real(wp),    intent(in)     :: a
        real(wp),    intent(in)     :: b
        real(wp),    intent(in)     :: c
        real(wp),    intent(in)     :: d
        real(wp),    intent(in)     :: elmbda
        real(wp),    intent(out)    :: pertrb
        real(wp),    intent(in)     :: bda(:)
        real(wp),    intent(in)     :: bdb(:)
        real(wp),    intent(in)     :: bdc(:)
        real(wp),    intent(in)     :: bdd(:)
        real(wp),    intent(inout) :: f(:,:)
        !-----------------------------------------------
        ! Local variables
        !-----------------------------------------------
        type(FishpackWorkspace)  :: workspace
        !-----------------------------------------------

        ! Allocate memory
        call workspace%initialize_staggered_workspace(n, m)

        ! Solve system
        associate( rew => workspace%real_workspace )
            call hstcyl_lower_routine(a, b, m, mbdcnd, bda, bdb, c, d, n, &
                nbdcnd, bdc, bdd, elmbda, f, idimf, pertrb, ierror, rew)
        end associate

        ! Release memory
        call workspace%destroy()

    end subroutine hstcyl

    subroutine hstcyl_lower_routine(a, b, m, mbdcnd, bda, bdb, c, d, n, nbdcnd, bdc, &
        bdd, elmbda, f, idimf, pertrb, ierror, w)
        !-----------------------------------------------
        ! Dummy arguments
        !-----------------------------------------------
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: mbdcnd
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: nbdcnd
        integer(ip), intent(in)     :: idimf
        integer(ip), intent(out)    :: ierror
        real(wp),    intent(in)     :: a
        real(wp),    intent(in)     :: b
        real(wp),    intent(in)     :: c
        real(wp),    intent(in)     :: d
        real(wp),    intent(in)     :: elmbda
        real(wp),    intent(out)    :: pertrb
        real(wp),    intent(in)     :: bda(:)
        real(wp),    intent(in)     :: bdb(:)
        real(wp),    intent(in)     :: bdc(:)
        real(wp),    intent(in)     :: bdd(:)
        real(wp),    intent(inout) :: f(:,:)
        real(wp),    intent(inout) :: w(:)
        !-----------------------------------------------
        ! Local variables
        !-----------------------------------------------
        integer(ip) :: np, iwb, iwc, iwr, i, j, k, lp, local_error_flag
        real(wp)    :: dr, dr2, dt, dt2, temp
        type(CenteredCyclicReductionUtility)  :: centered_util
        type(StaggeredCyclicReductionUtility) :: staggered_util

        !
        ! Check validity of calling arguments
        !
        call hstcyl_check_input_arguments(a, b, m, mbdcnd, c, d, n, nbdcnd, &
            elmbda, idimf, ierror)

        ! Check error flag
        if (ierror /= 0) return

        ! Set radial mesh
        dr = (b - a)/m
        dr2 = dr**2

        ! Set polar mesh
        dt = (d - c)/n
        dt2 = dt**2

        np = nbdcnd + 1

        !
        ! Define a, b, c coefficients in w-array.
        !
        iwb = m
        iwc = iwb + m
        iwr = iwc + m
        do i = 1, m
            j = iwr + i
            w(j) = a + (real(i, kind=wp) - HALF)*dr
            w(i) = (a + real(i - 1, kind=wp)*dr)/(dr2*w(j))
            k = iwc + i
            w(k) = (a + real(i, kind=wp)*dr)/(dr2*w(j))
            k = iwb + i
            w(k) = elmbda/w(j)**2 - TWO/dr2
        end do
        !
        ! Enter boundary data for r-boundaries.
        !
        select case (mbdcnd)
            case (1:2)
                temp = TWO *w(1)
                w(iwb+1) = w(iwb+1) - w(1)
                f(1, :n) = f(1, :n) - temp*bda
            case (3:4)
                temp = dr*w(1)
                w(iwb+1) = w(iwb+1) + w(1)
                f(1, :n) = f(1, :n) + temp * bda
        end select

        select case (mbdcnd)
            case (1, 4:5)
                w(iwc) = w(iwc) - w(iwr)
                temp = TWO * w(iwr)
                f(m, :n) = f(m, :n) - temp * bdb
            case (2:3, 6)
                w(iwc) = w(iwc) + w(iwr)
                temp = dr * w(iwr)
                f(m, :n) = f(m, :n) - temp * bdb
        end select

        !
        ! Enter boundary data for theta-boundaries.
        !
        temp = TWO/dt2

        if (n /= 1) then

            select case (np)
                case (2:3)
                    f(:m, 1) = f(:m, 1) - temp*bdc
                case (4:5)
                    temp = ONE/dt
                    f(:m, 1) = f(:m, 1) + temp*bdc
            end select

            temp = TWO/dt2

            select case (np)
                case (2, 5)
                    f(:m, n) = f(:m, n) - temp*bdd
                case (3:4)
                    temp = ONE/dt
                    f(:m, n) = f(:m, n) - temp*bdd
            end select

        end if

        pertrb = ZERO

        if (elmbda >= ZERO ) then
            if (elmbda /= ZERO ) then
                ierror = 11
                return
            else
                select case (mbdcnd)
                    case (3, 6)
                        select case (np)
                            case (1, 4)
                                do i = 1, m
                                    temp = ZERO
                                    temp = sum(f(i, :n))
                                    j = iwr + i
                                    pertrb = pertrb + temp * w(j)
                                end do
                                pertrb = pertrb/(real(m * n, kind=wp) * HALF * (a + b))
                                f(:m, :n) = f(:m, :n) - pertrb
                        end select
                end select
            end if
        end if

        w(:m) = w(:m) * dt2
        w(iwc+1:m+iwc) = w(iwc+1:m+iwc) * dt2
        w(iwb+1:m+iwb) = w(iwb+1:m+iwb) * dt2
        f(:m, :n) = f(:m, :n)*dt2
        lp = nbdcnd
        w(1) = ZERO
        w(iwr) = ZERO

        associate( &
            iw1 => iwb + 1, &
            iw2 => iwc + 1, &
            iw3 => iwr + 1 &
            )
            !
            ! Solve the system of equations.
            !
            select case (nbdcnd)
                case (0)
                    !
                    ! Solve system with call to genbun_lower_routine
                    !
                    call centered_util%genbun_lower_routine(lp, n, 1, m, w, w(iw1:), w(iw2:), idimf, f, local_error_flag, w(iw3:))

                    ! Check error flag
                    if (local_error_flag /= 0) then
                        error stop 'fishpack library: genbun_lower_routine call failed in hstcyl_lower_routine'
                    end if

                case default
                    !
                    ! Solve system with call to poistg_lower_routine
                    !
                    call staggered_util%poistg_lower_routine(lp, n, 1, m, w, w(iw1:), w(iw2:), idimf, f, local_error_flag, w(iw3:))

                    ! Check error flag
                    if (local_error_flag /= 0) then
                        error stop 'fishpack library: poistg call failed in hstcyl_lower_routine'
                    end if
            end select

        end associate

    end subroutine hstcyl_lower_routine

    pure subroutine hstcyl_check_input_arguments(a, b, m, mbdcnd, c, d, n, nbdcnd, &
        elmbda, idimf, ierror)
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        integer(ip), intent(in)  :: m
        integer(ip), intent(in)  :: mbdcnd
        integer(ip), intent(in)  :: n
        integer(ip), intent(in)  :: nbdcnd
        integer(ip), intent(in)  :: idimf
        integer(ip), intent(out) :: ierror
        real(wp),    intent(in)  :: a
        real(wp),    intent(in)  :: b
        real(wp),    intent(in)  :: c
        real(wp),    intent(in)  :: d
        real(wp),    intent(in)  :: elmbda
        !--------------------------------------------------------------

        if (a < ZERO) then
            ierror = 1
            return
        else if (a >= b) then
            ierror = 2
            return
        else if (mbdcnd <= 0 .or. mbdcnd >= 7) then
            ierror = 3
            return
        else if (c >= d) then
            ierror = 4
            return
        else if (3 > n) then
            ierror = 5
            return
        else if (nbdcnd < 0 .or. nbdcnd >= 5) then
            ierror = 6
            return
        else if (a == ZERO .and. mbdcnd /= 5 .and. mbdcnd /= 6) then
            ierror = 7
            return
        else if (a > ZERO .and. mbdcnd >= 5) then
            ierror = 8
            return
        else if (3 > m) then
            ierror = 9
            return
        else if (idimf < m) then
            ierror = 10
            return
        else if (a == ZERO .and. mbdcnd >= 5 .and. elmbda /= ZERO) then
            ierror = 12
            return
        else
            ierror = 0
        end if

    end subroutine hstcyl_check_input_arguments

end submodule staggered_cylindrical_solver
!
! REVISION HISTORY
!
! September 1973    Version 1
! April     1976    Version 2
! January   1978    Version 3
! December  1979    Version 3.1
! February  1985    Documentation upgrade
! November  1988    Version 3.2, FORTRAN 77 changes
! June      2004    Version 5.0, Fortran 90 changes
! April     2016    Fortran 2008 changes
!


! ------------------------ BEGIN DISTAZ ----------------------
      subroutine distaz( wlongsign, alat, along, blat, blong,
     * rdeg, rkm, az, baz)
!
! compute distances, azimuths using formulas from
! Bruce Julian.
!
! latest modification: 1/27/84
!
!        11/24/07 - Trap for colocated pair in subroutine distaz
!        05/01/15 - Replaced comment characters * or C with ! (The Fortran 95 standard)

      if (alat .eq. blat .and. along .eq. blong) then
        rdeg = 0.0
        rkm = 0.0
        az = 0.0
        baz = 0.0
        return
      end if

      pi = 4.0 * atan( 1. )
      dtor = pi/ 180.
!
! convert from degrees to radians and correct sign of
! longitude so that east longitude is positive.
!
      alatr = dtor * alat
      alongr = -dtor * along * wlongsign
      blatr = dtor * blat
      blongr = -dtor * blong * wlongsign
!
! compute geocentric latitudes.
!
      alatr = atan( 0.993305 * tan( alatr ) )
      blatr = atan( 0.993305 * tan( blatr ) )
!
! compute latitude dependent quantities
!
      ca = cos( alatr )
      cb = cos( blatr )
      sa = sin( alatr )
      sb = sin( blatr )
!
! now compute other quantities
!
      a = cb * sin( blongr - alongr )
      b = ca * sb - sa * cb * cos( blongr - alongr )
      cd = ca * cb * cos( blongr - alongr ) + sa * sb
      sd = sqrt( a*a + b*b )
!
! compute distances
!
      rdeg = atan2( sd, cd )/ dtor
      rkm = 111.19 * rdeg
!
! compute azimuth (from a to b) and make it positive.
!
      az = atan2( a, b )/ dtor
      if ( az .lt. 0.0 ) az = az + 360.0
!
! compute back azimuth (from b to a) and make it positive.
!
      a = ca * sin( alongr - blongr )
      b = cb * sa - sb * ca * cos( alongr - blongr )
      baz = atan2( a, b)/ dtor
      if ( baz .lt. 0.0 ) baz = baz + 360.0
!
      return
      end
! ------------------------ END DISTAZ ----------------------