!*****************************************************************************************
!>
!  Tests for scalar root functions without derivatives.
!
!### Reference
!  * G.E. Alefeld, F.A. Potra and Yixun Shi,
!    "Algorithm 748: Enclosing Zeros of Continuous Functions",
!    ACM Transactions on Mathematica1 Software,
!    Vol. 21. No. 3. September 1995. Pages 327-344.

program root_tests

    use iso_fortran_env
    use root_module, wp => root_module_rk
    use face,            only: colorize
    use pyplot_module,   only: pyplot

    implicit none

    integer :: nprob
    integer :: n
    integer :: imeth !! method counter
    integer :: ifunc !! number of function evaluations
    real(wp) :: root !! known root value
    integer :: iunit,istat,iunit_failed
    real(wp) :: ax,bx
    integer :: i !! counter
    integer :: ic !! case counter
    integer :: num_of_problems
    integer,dimension(:),allocatable :: cases_to_run
    type(pyplot) :: stats_plot   !! pyplot handler

    character(len=*),parameter :: fmt  = '(   A20,1X,A3,1X,A4,1X,A16,  1X,A25,   1X,A16,  1X,A5,1X,A5,1X,A8  )' !! format for header
    character(len=*),parameter :: dfmt = '(1P,A20,1X,I3,1X,I4,1X,E16.6,1X,E25.16,1X,E16.6,1X,I5,1X,I5,1X,E8.1)' !! format for results

    integer,parameter :: number_of_methods = 16 !! number of methods to test
    character(len=100),dimension(number_of_methods),parameter :: methods = [ &
        'bisection           ', &
        'brent               ', &
        'brentq              ', &
        'brenth              ', &
        'regula_falsi        ', &
        'illinois            ', &
        'anderson_bjorck     ', &
        'anderson_bjorck_king', &
        'ridders             ', &
        'pegasus             ', &
        'bdqrf               ', &
        'muller              ', &
        'chandrupatla        ', &
        'toms748             ', &
        'zhang               ', &
        'blendtf             '] !! method names

    integer,dimension(number_of_methods) :: number_of_wins, ivec, number_of_failures, ivec2

    number_of_wins = 0
    number_of_failures = 0

    ! open output files:
    open(newunit=iunit,        file='root_report_best.txt',     status='REPLACE', iostat=istat)
    open(newunit=iunit_failed, file='root_report_failures.txt', status='REPLACE', iostat=istat)

    ! output file headers:
    write(iunit, '(A5,1X,A5,1X,A5,1X,A)')  'nprob', 'n', 'evals', 'Best Methods'
    write(iunit_failed, '(A5,1X,A5,1X,A)') 'nprob', 'n', 'Failed Methods'

    ! plot:
    call stats_plot%initialize(grid=.true.,xlabel='Methods',ylabel='Function Evaluations',figsize=[10,5],&
                                title='Performance of each method',&
                                tight_layout=.true.)

    ! number of problems to test:
    nprob = 1 ! initialize
    n = 1
    call problems(num_of_problems=num_of_problems)

    ! run the tests:
    do nprob = 1, num_of_problems
        ! write(*,*) 'nprob: ', nprob
        ! write(*,*) 'cases_to_run: ', cases_to_run
        call problems(cases = cases_to_run)
        do ic = 1, size(cases_to_run)
            n = cases_to_run(ic)
            call test()
        end do
    end do

    ! close output files:
    close(iunit)
    close(iunit_failed)

    call stats_plot%savefig('stats_plot.pdf',istat=istat,pyfile='stats_plot.py')

    ! another summary:
    ivec  = [(i, i = 1, number_of_methods)]
    ivec2 = ivec

    ! sort them based on which had the most wins:
    call insertion_sort(number_of_wins, ivec, number_of_failures)

    write(*,*) ''
    write(*,'(A25,1X,A5,1X,A5)') repeat('-',25), repeat('-',5), repeat('-',5)
    write(*,'(A25,1X,A5,1X,A5)') 'Method', 'Win', 'Fail'
    write(*,'(A25,1X,A5,1X,A5)') repeat('-',25), repeat('-',5), repeat('-',5)
    do imeth = 1, number_of_methods
        write(*,'(A25,1X,I5,1X,I5)') trim(methods(ivec(imeth))), &
                                     number_of_wins(imeth), &
                                     number_of_failures(imeth)
    end do
    write(*,*) ''

   ! call generate_plots()  ! comment out for now...

    contains
!*****************************************************************************************

    subroutine test()

        implicit none

        real(wp) :: xzero,fzero,error
        integer :: iflag
        character(len=1000) :: line
        integer,dimension(number_of_methods) :: fevals !! func evals for each case
        real(wp),dimension(number_of_methods) :: cases_per_sec !! speed of each case
        integer :: best_feval
        real(wp) :: best_cases_per_second
        character(len=:),allocatable :: best,failures
        logical :: root_found
        real(wp) :: tstart, tfinish  !! for `cpu_time`
        integer :: irepeat !! test repeat counter
        integer :: i
        real(wp) :: atol, rtol, ftol

        integer,parameter :: n_repeat = 1  !! number of times to repeat each test for timing purposes
        real(wp),parameter :: tol_for_check = 1.0e-7_wp  !! for pass/fail check
        integer,parameter :: maxiter = 1000 !! maximum number of iterations

        select case (wp)
        case(real32)
            atol = 1.0e-5_wp
            rtol = 1.0e-5_wp
            ftol = 1.0e-5_wp
        case(real64)
            atol = 1.0e-15_wp
            rtol = 1.0e-13_wp
            ftol = 1.0e-15_wp
        case(real128)
            atol = 1.0e-25_wp
            rtol = 1.0e-23_wp
            ftol = 1.0e-25_wp
        case default
            error stop 'unknown real kind'
        end select

        write(output_unit,fmt) &
            repeat('-',20),repeat('-',3),repeat('-',4),repeat('-',16),&
            repeat('-',25),repeat('-',16),repeat('-',5),repeat('-',5),repeat('-',8)

        write(output_unit,fmt) &
            'method','function','n','error','x','f','evals','iflag','runs/sec'

        write(output_unit,fmt) &
            repeat('-',20),repeat('-',3),repeat('-',4),repeat('-',16),&
            repeat('-',25),repeat('-',16),repeat('-',5),repeat('-',5),repeat('-',8)

        do imeth = 1, number_of_methods

            call problems(ax=ax, bx=bx, xroot=root)

            call cpu_time(tstart)
            do irepeat = 1, n_repeat
                ifunc = 0 ! reset func evals counter
                call root_scalar(methods(imeth),func,ax,bx,xzero,fzero,iflag,bisect_on_failure=.true., &
                                 atol = atol, rtol = rtol, ftol = ftol, maxiter = maxiter)
            end do
            call cpu_time(tfinish)

            error = xzero-root
            write(line, dfmt) trim(methods(imeth)),nprob,n,error,xzero,fzero,ifunc,iflag,n_repeat / (tfinish-tstart)

            root_found = abs(fzero) <= tol_for_check !.and. abs(error) <= tol_for_check

            if (root_found) then
                write(output_unit, '(A)') trim(line)
            else
                write(output_unit, '(A)') colorize(trim(line), color_fg='red') ! failed case
            end if

            ! save results for this case:
            if (iflag==0 .and. root_found) then
                fevals(imeth) = ifunc
                cases_per_sec(imeth) = n_repeat / (tfinish-tstart)
            else
                fevals(imeth) = huge(1)
                cases_per_sec(imeth) = huge(1.0_wp)
            end if

        end do

        ! update plot:
        call stats_plot%add_plot([(real(i,wp), i=1,number_of_methods)],real(fevals,wp),&
                                    label='',linestyle='-',linewidth=2,istat=istat)

        ! get the best and the failures for the output files:

        ! best in terms of lowest function evals:
        best_feval = minval(fevals)
        if (best_feval==huge(1)) best_feval = -1 ! if none of them converged
        best = ''
        failures = ''
        do imeth = 1, number_of_methods
            if (fevals(imeth) == best_feval) then
                if (best=='') then
                    best = trim(methods(imeth))
                else
                    best = best//', '//trim(methods(imeth))
                end if
                number_of_wins(imeth) = number_of_wins(imeth) + 1
            elseif (fevals(imeth) == huge(1)) then
                if (failures=='') then
                    failures = trim(methods(imeth))
                else
                    failures = failures//', '//trim(methods(imeth))
                end if
                number_of_failures(imeth) = number_of_failures(imeth) + 1
            end if
        end do

    !     ! best in terms of fastest cpu time:
    !     best_cases_per_second = maxval(cases_per_sec)
    !     if (best_cases_per_second==huge(1.0_wp)) best_cases_per_second = -1 ! if none of them converged
    !     best = ''
    !     failures = ''
    !     do imeth = 1, number_of_methods
    !         if (cases_per_sec(imeth) == best_cases_per_second) then
    !             if (best=='') then
    !                 best = trim(methods(imeth))
    !             else
    !                 best = best//', '//trim(methods(imeth))
    !             end if
    !             number_of_wins(imeth) = number_of_wins(imeth) + 1
    !         elseif (cases_per_sec(imeth) == huge(1.0_wp)) then
    !             if (failures=='') then
    !                 failures = trim(methods(imeth))
    !             else
    !                 failures = failures//', '//trim(methods(imeth))
    !             end if
    !             number_of_failures(imeth) = number_of_failures(imeth) + 1
    !         end if
    !     end do

    ! output the report:
    if (best /= '')     write(iunit, '(I5,1X,I5,1X,I5,1X,A)')  nprob, n, best_feval, 'Best: '//trim(best)
    if (failures /= '') write(iunit_failed, '(I5,1X,I5,1X,A)') nprob, n, 'Failures: '//trim(failures)

    end subroutine test

    subroutine problems(x, ax, bx, fx, xroot, cases, num_of_problems, latex)

    !! returns all the information about the test case.

    implicit none

    real(wp),intent(in),optional  :: x       !! indep variable
    real(wp),intent(out),optional :: ax, bx  !! bounds
    real(wp),intent(out),optional :: fx      !! function value `f(x)`
    real(wp),intent(out),optional :: xroot   !! value of indep variable at the root
    integer,dimension(:),allocatable,intent(out),optional :: cases !! list of `n` cases to test
    integer,intent(out),optional :: num_of_problems  !! total number of problems
    character(len=:),allocatable,intent(out),optional :: latex !! LaTeX string of `f(x)`

    real(wp),parameter :: pi = acos(-1.0_wp)

    real(wp) :: a, b, root, f, dn, di, xi, t1, emx, ex
    integer :: i !! counter
    integer,dimension(:),allocatable :: ns

    dn = real(n, wp)
    ns = [1] ! default case
    if (present(latex)) latex = ''

    select case (nprob)
    case (1)
        a = pi/2.0_wp
        b = pi
        root = 1.8954942670339809E+00_wp
        if (present(x)) f = sin(x) - x/2.0_wp
        if (present(latex)) latex = '\sin x - x/2'
    case (2:11)

        select case (nprob)
        case(2)
            a = 1.0_wp + 1.0e-9_wp
            b = (2.0_wp)*(2.0_wp) - 1.0e-9_wp
            root = 3.0229153472730570E+00_wp
        case (3)
            a = (2.0_wp)*(2.0_wp) + 1.0e-9_wp
            b = (3.0_wp)*(3.0_wp) - 1.0e-9_wp
            root = 6.6837535608080781E+00_wp
        case (4)
            a = (3.0_wp)*(3.0_wp) + 1.0e-9_wp
            b = (4.0_wp)*(4.0_wp) - 1.0e-9_wp
            root = 1.1238701655002212E+01_wp
        case (5)
            a = (4.0_wp)*(4.0_wp) + 1.0e-9_wp
            b = (5.0_wp)*(5.0_wp) - 1.0e-9_wp
            root = 1.9676000080623409E+01_wp
        case (6)
            a = (5.0_wp)*(5.0_wp) + 1.0e-9_wp
            b = (6.0_wp)*(6.0_wp) - 1.0e-9_wp
            root = 2.9828227326504754E+01_wp
        case (7)
            a = (6.0_wp)*(6.0_wp) + 1.0e-9_wp
            b = (7.0_wp)*(7.0_wp) - 1.0e-9_wp
            root = 4.1906116195289413E+01_wp
        case (8)
            a = (7.0_wp)*(7.0_wp) + 1.0e-9_wp
            b = (8.0_wp)*(8.0_wp) - 1.0e-9_wp
            root = 5.5953595800143094E+01_wp
        case (9)
            a = (8.0_wp)*(8.0_wp) + 1.0e-9_wp
            b = (9.0_wp)*(9.0_wp) - 1.0e-9_wp
            root = 7.1985665586587795E+01_wp
        case (10)
            a = (9.0_wp)*(9.0_wp) + 1.0e-9_wp
            b = (10.0_wp)*(10.0_wp) - 1.0e-9_wp
            root = 9.0008868539166666E+01_wp
        case (11)
            a = (10.0_wp)*(10.0_wp) + 1.0e-9_wp
            b = (11.0_wp)*(11.0_wp) - 1.0e-9_wp
            root = 1.1002653274833019E+02_wp
        end select
        if (present(x)) then
            f = 0.0_wp
            do i = 1, 20
                di = real(i,wp)
                f = f + ((2.0_wp*di - 5.0_wp)**2)/(x - di*di)**3
            end do
            f = -2.0_wp*f
        end if
        if (present(latex)) latex = '-2 \sum_{i=1}^{20} ((2i - 5)^2)/(x - i^2)^3'
    case (12)
        a = -9.0_wp
        b = 31.0_wp
        root = 0.0_wp
        if (present(x)) f = -40.0_wp*x*exp(-1.0_wp*x)
        if (present(latex)) latex = '-40 x \mathrm{e}^{-x}'
    case (13)
        a = -9.0_wp
        b = 31.0_wp
        root = 0.0_wp
        if (present(x)) f = -100.0_wp*x*exp(-2.0_wp*x)
        if (present(latex)) latex = '-100 x \mathrm{e}^{-2 x}'
    case (14)
        a = -9.0_wp
        b = 31.0_wp
        root = 0.0_wp
        if (present(x)) f = -200.0_wp*x*exp(-3.0_wp*x)
        if (present(latex)) latex = '-200 x \mathrm{e}^{-3 x}'
    case (15)
        a = 0.0_wp
        b = 5.0_wp
        ns = [4, 6, 8, 10, 12]
        if (present(xroot)) then
            select case (n)
            case(4);  root = 6.6874030497642202E-01_wp
            case(6);  root = 7.6472449133173001E-01_wp
            case(8);  root = 8.1776543395794250E-01_wp
            case(10); root = 8.5133992252078460E-01_wp
            case(12); root = 8.7448527222116784E-01_wp
            case default
                write(*,*) 'invalid n: ', n ; error stop
            end select
        end if
        if (present(x)) f = x**n - 0.2_wp
        if (present(latex)) latex = 'x^n - 0.2'
    case (16:17)
        select case (nprob)
        case(16)
            a = 0.0_wp
            b = 5.0_wp
            ns = [4, 6, 8, 10, 12]
        case (17)
            a = -0.95_wp
            b = 4.05_wp
            root = 1.0_wp
            ns = [8, 10, 12, 14]
        end select
        root = 1.0_wp
        if (present(x)) f = x**n - 1.0_wp
        if (present(latex)) latex = 'x^n - 1'
    case (18)  ! note: 18-24 are also in Dowell & Jarratt
        a = 0.0_wp
        b = 1.5_wp
        root = pi / 6.0_wp
        if (present(x)) f = sin(x) - 0.5_wp
        if (present(latex)) latex = '\sin x - 0.5'
    case (19)
        a = 0.0_wp
        b = 1.0_wp
        ns = [1,2,3,4,5,20,40,60,80,100]
        if (present(xroot)) then
            select case (n)
            case(1);    root = 4.2247770964123666E-01_wp
            case(2);    root = 3.0669941048320373E-01_wp
            case(3);    root = 2.2370545765466297E-01_wp
            case(4);    root = 1.7171914751950839E-01_wp
            case(5);    root = 1.3825715505682408E-01_wp
            case(20);   root = 3.4657359020853851E-02_wp
            case(40);   root = 1.7328679513998633E-02_wp
            case(60);   root = 1.1552453009332422E-02_wp
            case(80);   root = 8.6643397569993164E-03_wp
            case(100);  root = 6.9314718055994531E-03_wp
            case default; write(*,*) 'invalid n: ', n ; error stop
            end select
        end if
        if (present(x)) f = 2.0_wp*x*exp(-dn) - 2.0_wp*exp(-dn*x) + 1.0_wp
        if (present(latex)) latex = '2 x \mathrm{e}^{-n} - 2 \mathrm{e}^{-n x} + 1'
    case (20)
        a = 0.0_wp
        b = 1.0_wp
        ns = [5,10,20]
        if (present(xroot)) then
            select case (n)
            case(5);    root = 3.8402551840621900E-02_wp
            case(10);   root = 9.9000099980004999E-03_wp
            case(20);   root = 2.4937500390620117E-03_wp
            case default; write(*,*) 'invalid n: ', n ; error stop
            end select
        end if
        if (present(x)) f = (1.0_wp + (1.0_wp - dn)**2)*x - (1.0_wp - dn*x)**2
        if (present(latex)) latex = '(1 + (1 - n)^2)x - (1 - n x)^2'
    case (21)
        a = 0.0_wp
        b = 1.0_wp
        ns = [2,5,10,15,20]
        if (present(xroot)) then
            select case (n)
            case(2);    root = 0.5_wp
            case(5);    root = 3.4595481584824202E-01_wp
            case(10);   root = 2.4512233375330724E-01_wp
            case(15);   root = 1.9554762353656561E-01_wp
            case(20);   root = 1.6492095727644095E-01_wp
            case default; write(*,*) 'invalid n: ', n ; error stop
            end select
        end if
        if (present(x)) f = x**2 - (1.0_wp - x)**n
        if (present(latex)) latex = 'x^2 - (1-x)^n'
    case (22)
        a = 0.0_wp
        b = 1.0_wp
        ns = [1,2,4,5,8,15,20]
        if (present(xroot)) then
            select case (n)
            case(1);    root = 2.7550804099948439E-01_wp
            case(2);    root = 1.3775402049974219E-01_wp
            case(4);    root = 1.0305283778156444E-02_wp
            case(5);    root = 3.6171081789040635E-03_wp
            case(8);    root = 4.1087291849639540E-04_wp
            case(15);   root = 2.5989575892907627E-05_wp
            case(20);   root = 7.6685951221853367E-06_wp
            case default; write(*,*) 'invalid n: ', n ; error stop
            end select
        end if
        if (present(x)) f = (1.0_wp + (1.0_wp - dn)**4)*x - (1.0_wp - dn*x)**4
        if (present(latex)) latex = '(1 + (1 - n)^4) x - (1 - n x)^4'
    case (23)
        a = 0.0_wp
        b = 1.0_wp
        ns = [1,5,10,15,20]
        if (present(xroot)) then
            select case (n)
            case(1);    root = 4.0105813754154704E-01_wp
            case(5);    root = 5.1615351875793357E-01_wp
            case(10);   root = 5.3952222690841584E-01_wp
            case(15);   root = 5.4818229434065527E-01_wp
            case(20);   root = 5.5270466667848779E-01_wp
            case default; write(*,*) 'invalid n: ', n ; error stop
            end select
        end if
        if (present(x)) f = (x - 1.0_wp)*exp(-dn*x) + x**n
        if (present(latex)) latex = '(x - 1) \mathrm{e}^{-n x} + x^n'
    case (24)
        a = 0.01_wp
        b = 1.0_wp
        ns = [2,5,15,20]
        if (present(xroot)) then
            select case (n)
            case(2);    root = 0.5_wp
            case(5);    root = 0.2_wp
            case(15);   root = 1.0_wp / 15.0_wp !6.6666666666667e-02_wp
            case(20);   root = 5.0e-02_wp
            case default; write(*,*) 'invalid n: ', n ; error stop
            end select
        end if
        if (present(x)) f = (dn*x - 1.0_wp)/((dn - 1.0_wp)*x)
        if (present(latex)) latex = '\frac{n x - 1}{(n - 1)x}'
    case (25)
        a = 1.0_wp
        b = 100.0_wp
        ns = [2,3,4,5,6,7,9,11,13,15,17,19,21,23,25,27,29,31,33]
        root = real(n,wp)
        if (present(x)) f = x**(1.0_wp/dn) - dn**(1.0_wp/dn)
        if (present(latex)) latex = 'x^{1/n} - n^{1/n}'
    case (26)
        a = -1.0_wp
        b = 4.0_wp
        root = 0.0_wp    ! this is just almost impossible to get
        if (present(x)) then
            if (x == 0.0_wp) then
                f = 0.0_wp
            else
                f = x/exp(1.0_wp/(x*x))
            end if
        end if
        if (present(latex)) latex = '\left\{ \begin{array}{cl} 0 & \mathrm{if~}x=0 \\'//&
                                    ' x \mathrm{e}^{-1/x^2} & \mathrm{otherwise} \end{array} \right.'
    case (27)
        a = -10000.0_wp
        b = pi/2.0_wp
        root = 6.2380651896161232E-01_wp
        ns = [(i, i = 1, 40)]
        if (present(x)) then
            if (x >= 0.0_wp) then
                f = (x/1.5_wp + sin(x) - 1.0_wp)*dn/20.0_wp
            else
                f = (-1.0_wp*dn)/20.0_wp
            end if
        end if
        if (present(latex)) latex = '\left\{ \begin{array}{cl} (x/1.5 + \sin(x) - 1) n/20 & \mathrm{if~}x \ge 0 \\'//&
                                    ' -n/20 & \mathrm{otherwise} \end{array} \right.'
    case (28)
        a = -10000.0_wp
        b = 1.0e-4_wp
        ns = [ [(i, i = 20,40)], [(i*100, i = 1, 10)] ]
        if (present(xroot)) then
            select case (n)
            case(20);   root = 5.9051305594219711E-05_wp
            case(21);   root = 5.6367155339936997E-05_wp
            case(22);   root = 5.3916409455591910E-05_wp
            case(23);   root = 5.1669892394942247E-05_wp
            case(24);   root = 4.9603096699144557E-05_wp
            case(25);   root = 4.7695285287638997E-05_wp
            case(26);   root = 4.5928793239948664E-05_wp
            case(27);   root = 4.4288479195664783E-05_wp
            case(28);   root = 4.2761290257883239E-05_wp
            case(29);   root = 4.1335913915953798E-05_wp
            case(30);   root = 4.0002497338019804E-05_wp
            case(31);   root = 3.8752419296206685E-05_wp
            case(32);   root = 3.7578103559957998E-05_wp
            case(33);   root = 3.6472865219959233E-05_wp
            case(34);   root = 3.5430783356531827E-05_wp
            case(35);   root = 3.4446594929961498E-05_wp
            case(36);   root = 3.3515605877800376E-05_wp
            case(37);   root = 3.2633616249437209E-05_wp
            case(38);   root = 3.1796856858425998E-05_wp
            case(39);   root = 3.1001935436965348E-05_wp
            case(40);   root = 3.0245790670210096E-05_wp
            case(100);  root = 1.2277994232461524E-05_wp
            case(200);  root = 6.1695393904408653E-06_wp
            case(300);  root = 4.1198585298292822E-06_wp
            case(400);  root = 3.0924623877272168E-06_wp
            case(500);  root = 2.4752044261050178E-06_wp
            case(600);  root = 2.0633567678512711E-06_wp
            case(700);  root = 1.7690120078154264E-06_wp
            case(800);  root = 1.5481615698859100E-06_wp
            case(900);  root = 1.3763345366022352E-06_wp
            case(1000); root = 1.2388385788997142E-06_wp
            case default; write(*,*) 'invalid n: ', n ; error stop
            end select
        end if
        if (present(x)) then
            if (x >= (1.0e-3_wp)*2.0_wp/(dn + 1.0_wp)) then
                f = exp(1.0_wp) - 1.859_wp
            elseif (x >= 0.0_wp) then
                f = exp((dn + 1.0_wp)*0.5_wp*x*1000.0_wp) - 1.859_wp
            else
                f = -0.859_wp
            end if
        end if
        if (present(latex)) latex = '\left\{ \begin{array}{cl} '//&
                                    ' \mathrm{e} - 1.859 & \mathrm{if~} x \ge 0.002/(n + 1) \\'//&
                                    ' \mathrm{e}^{500 (n + 1) x} - 1.859 & x \ge 0\\'//&
                                    ' -0.859 & \mathrm{otherwise}'//&
                                    ' \end{array} \right.'
    case (29)
        ! Zhang test case
        a = 0.0_wp
        b = 4.0_wp
        root = 8.6547403310161445E-01_wp
        if (present(x)) f = cos(x) - x**3
        if (present(latex)) latex = '\cos x - x^3'

    ! 30-36 : Gottlieb's paper [table 1 & 2]
    case (30)
        a = 0.0_wp
        b = 1.0_wp
        root = asin(2.0_wp/3.0_wp)
        if (present(x)) f = 3.0_wp * sin(x) - 2.0_wp
        if (present(latex)) latex = '3 \sin x - 2'
    case (31)
        a = -1.0_wp
        b = 1.0_wp
        root = 5.6714329040978387E-01_wp
        if (present(x)) f = x*exp(x) - 1.0_wp
        if (present(latex)) latex = 'x \mathrm{e}^x - 1'
    case (32)
        a = 0.1_wp
        b = 0.9_wp
        root = 8.0413309750366432E-01_wp
        if (present(x)) f = 11.0_wp * x**11 - 1.0_wp
        if (present(latex)) latex = '11 x^{11} - 1'
    case (33)
        a = 2.8_wp
        b = 3.1_wp
        root = 3.0_wp
        if (present(x)) f = exp(x**2 + 7.0_wp*x - 30.0_wp) - 1.0_wp
        if (present(latex)) latex = '\mathrm{e}^{x^2 + 7x - 30} - 1'
    case (34)
        a = -1.3_wp
        b = -0.5_wp
        root = -6.2944648407333333E-01_wp
        if (present(x)) f = 1.0_wp/x - sin(x) + 1.0_wp
        if (present(latex)) latex = '1/x - \sin x + 1'
    case (35)
        a = 2.0_wp
        b = 3.0_wp
        root = 2.0945514815423266E+00_wp
        if (present(x)) f = x**3 - 2.0_wp*x - 5.0_wp
        if (present(latex)) latex = 'x^3 - 2 x - 5'
    case (36)
        a = 0.5_wp
        b = 2.0_wp
        root = 1.0_wp
        if (present(x)) f = 1.0_wp/x - 1.0_wp
        if (present(latex)) latex = '1/x - 1'
    case (37)
        a = -10.0_wp
        b = 10.0_wp
        root = 1.0_wp
        if (present(x)) f = x**3 - 5.0_wp*x**2 + 12.0_wp*x - 8.0_wp
        if (present(latex)) latex = 'x^3 - 5 x^2 + 12 x - 8'
    case (38)
        a = 0.0_wp
        b = 10.0_wp
        root = 1.0_wp
        if (present(x)) f = x**5 - 61.0_wp*x**4 + 1368.0_wp*x**3 - &
                            13548.0_wp*x**2 + 54256.0_wp*x - 42016.0_wp ! x in [0, 10]
        if (present(latex)) latex = 'x^5 - 61 x^4 + 1368 x^3 - 13548 x^2 + 54256 x - 42016'
    case (39)
        a = 0.0_wp
        b = 10.0_wp
        root = 1.0_wp
        if (present(x)) f = x**5-61.0_wp*x**4+6801.0_wp/5.0_wp*x**3-66531.0_wp/&
                            5.0_wp*x**2+5205601.0_wp/100.0_wp*x-4005001.0_wp/100.0_wp
        if (present(latex)) latex = 'x^5 - 61 x^4 + 6801 x^3 / 5 - 66531 x^2 / 5 + 5205601 x / 100 - 4005001/100'
    case (40)
        a = 0.0_wp
        b = 10.0_wp
        root = 1.0_wp
        if (present(x)) f = (x-1.0_wp)**5
        if (present(latex)) latex = '(x-1)^5'
    case (41)
        !From: http://www.mth.pdx.edu/~daescu/mth451_551/Muller_bisection.pdf
        a = -2.0_wp
        b = 3.0_wp
        root = 0.0_wp
        if (present(x)) f = atan(x)
        if (present(latex)) latex = '\tan^{-1} x'
    case (42)
        !From: http://www.mth.pdx.edu/~daescu/mth451_551/Muller_bisection.pdf
        a = 0.0_wp     ! x1 is the location of the root for this case
        b = 3.0_wp
        root = 0.0_wp
        if (present(x)) f = exp(x) - 2.0_wp*x - 1.0_wp
        if (present(latex)) latex = '\mathrm{e}^{x} - 2 x - 1'
    case (43)
        a = 0.0_wp
        b = 0.7_wp
        root = 6.7771292632868404E-01_wp
        if (present(x)) f = 3.0_wp * x * sin(x*20.0_wp)*cos(x) + x - 2.0_wp
        if (present(latex)) latex = '3 x \sin(20 x) \cos x + x - 2'
    case (44)
        a = -0.7_wp
        b = 0.4_wp
        root = -6.4008369608468403E-01_wp
        if (present(x)) f = 3.0_wp * x**2 * sin(x*20.0_wp) + cos(x*2.0_wp)
        if (present(latex)) latex = '3 x^2 \sin (20x) + \cos(2x)'
    case (45)
        !case 11 from "Algorithm 748: Enclosing Zeros of Continuous Functions" (n=20)
        a = 0.01_wp
        b = 1.0_wp
        root = 0.05_wp
        ns = [20]
        if (present(x)) f = (real(n,wp)*x-1.0_wp)/((real(n,wp)-1.0_wp)*x)
        if (present(latex)) latex = '\frac{n x - 1}{(n - 1) x}'
    case (46)
        a = -10.0_wp
        b = 5.0_wp
        root = 0.0_wp
        if (present(x)) f = sin(x*10.0_wp) + sin(x*2.0_wp) + &
                            atan(x/3.0_wp)*x**2 + exp(x) - 1.0_wp
        if (present(latex)) latex = '\sin(10 x) + \sin(2 x) + \atan(x/3) x^2 + \mathrm{e}^x - 1'

    ! functions are from:
    !   T. R. Chandrupatla, "A new hybrid quadratic/bisection algorithm for finding the zero of
    !   a nonlinear function without using derivatives", Advances in Engineering Software
    !   Volume 28, Issue 3, April 1997, Pages 145-149

    case (47:48)
        select case (nprob)
        case (47)
            a = 0.5_wp
            b = 1.51_wp
        case (48)
            a =  1.0e-12_wp
            b =  1.0e12_wp
        end select
        root = 1.0_wp
        if (present(x)) f = 1.0_wp - 1.0_wp/(x**2)
        if (present(latex)) latex = '1 - 1/x^2'
    case (49:50)
        select case (nprob)
        case (49)
            a = 0.0_wp
            b = 5.0_wp
        case (50)
            a = -1.0e10_wp
            b =  1.0e10_wp
        end select
        root = 3.0_wp
        if (present(x)) f = (x-3.0_wp)**3
        if (present(latex)) latex = '(x - 3)^3'
    case (51:52)
        select case (nprob)
        case (51)
            a = 0.0_wp
            b = 5.0_wp
        case (52)
            a = -1.0e10_wp
            b =  1.0e10_wp
        end select
        root = 2.0_wp
        if (present(x)) f = 6.0_wp*(x-2.0_wp)**5
        if (present(latex)) latex = '6 (x-2)^5'
    case (53:54)
        select case (nprob)
        case (53)
            a = -1.0_wp
            b =  4.0_wp
        case (54)
            a = -10.0_wp
            b =  100.0_wp
        end select
        root = 0.0_wp
        if (present(x)) f = x**9
        if (present(latex)) latex = 'x^9'
    case (55:56)
        select case (nprob)
        case (55)
            a = -1.0_wp
            b =  4.0_wp
        case (56)
            a = -10.0_wp
            b =  100.0_wp
        end select
        root = 0.0_wp
        if (present(x)) f = x**19
        if (present(latex)) latex = 'x^{19}'
    case (57:58)
        select case (nprob)
        case (57)
            a = -1.0_wp
            b =  4.0_wp
        case (58)
            a = -10.0_wp
            b =  100.0_wp
        end select
        root = 0.0_wp
        if (present(x)) then
            if (abs(x) < 3.8e-4_wp) then  ! same as one above except for this
                f = 0.0_wp
            else
                f = x*exp(-x**(-2))
            endif
        end if
        if (present(latex)) latex = '\left\{ \begin{array}{cl} 0 & \mathrm{if~} | x | < 0.00038 \\'//&
                                    ' x \mathrm{e}^{-1/x^2} & \mathrm{otherwise} \end{array} \right.'
    case (59:60)
        select case (nprob)
        case (59)
            a = 2.0e-4_wp
            b = 2.0_wp
        case (60)
            a = 2.0e-4_wp
            b = 81.0_wp
        end select
        root = 1.0375360332870403E+00_wp
        if (present(x)) then
            xi = 0.61489_wp
            t1 = 1.0_wp-xi
            emx = exp(-x)
            f = -(3062.0_wp*t1*emx)/(xi + t1*emx) - 1013.0_wp + 1628.0_wp/x
        end if
        if (present(latex)) latex = '-\frac{3062 * 0.38511 * \mathrm{e}^{-x}}{0.61489 + 0.38511 * \mathrm{e}^{-x}} - 1013 + 1628/x'
    case (61:62)
        select case (nprob)
        case (61)
            a = 2.0e-4_wp
            b = 1.0_wp
        case (62)
            a = 2.0e-4_wp
            b = 81.0_wp
        end select
        root = 7.0320484036313581E-01_wp
        if (present(x)) then
            ex = exp(x)
            f = ex - 2.0_wp - 0.01_wp/(x*x) + 2.0e-6_wp/(x*x*x)
        end if
        if (present(latex)) latex = '\mathrm{e}^x - 2 - 0.01/x^2 + 0.000002/x^3'

    ! from A modified three-point Secant method with improved
    !      rate and characteristics of convergence
    !      July 2019

    case(63)
        a = 0.0_wp
        b = 1.5_wp
        root = 1.3652300134140968E+00_wp
        if (present(x)) f = x**3 + 4.0_wp*x**2 - 10.0_wp
        if (present(latex)) latex = 'x^3 + 4 * x^2 - 10'
    case(64)
        a = -2.0_wp
        b = -1.0_wp
        root = -1.4044916482153412E+00_wp
        if (present(x)) f = sin(x)**2 - x**2 + 1.0_wp
        if (present(latex)) latex = '\sin^2 x - x^2 + 1'
    case(65)
        a = 1.0_wp
        b = 2.1_wp
        root = 2.0_wp
        if (present(x)) f = (x - 1.0_wp)**6 - 1.0_wp
        if (present(latex)) latex = '(x - 1)^6 - 1'
    case(66)
        a = -0.9_wp
        b = -0.1_wp
        root = -6.0323197155721517E-01_wp
        if (present(x)) f = sin(x)*exp(x) + log(x**2+1.0_wp)
        if (present(latex)) latex = '\sin(x) \mathrm{e}^x + \log(x^2 + 1)'
    case(67)
        a = 1.0_wp
        b = 3.1_wp
        root = 3.0_wp
        if (present(x)) f = exp(x**2+7.0_wp*x-30.0_wp) - 1.0_wp
        if (present(latex)) latex = '\mathrm{e}^{x^2 + 7 x - 30} - 1'
    case(68)
        a = 1.0_wp
        b = 2.1_wp
        root = 1.8571838602078353E+00_wp
        if (present(x)) f = x - 3.0_wp * log(x)
        if (present(latex)) latex = 'x - 3 \log x'

    ! some simple functions
    case(69)
        a = 0.1001_wp
        b = 10.0001_wp
        root = 1.0_wp
        if (present(x)) f = x**2 - 1.0_wp
        if (present(latex)) latex = 'x^2 - 1'
    case(70)
        a = 0.0001_wp
        b = 10.0001_wp
        root = 1.0018618683298285E+00_wp
        if (present(x)) f = x**2 - 1.0038273894_wp + sin(x/10000.0_wp)
        if (present(latex)) latex = 'x^2 - 1.0038273894 + \sin (x/10000)'
    case(71:72)
        select case (nprob)
        case (71)
            a = -2.0001_wp
            b = 1.0001_wp
        case(72)
            a = -0.0001_wp  ! root very close to a
            b = 1.0001_wp
        end select
        root = 0.0_wp
        if (present(x)) f = x
        if (present(latex)) latex = 'x'

    ! D. Popovski, "A note on King's method F for finding a bracketed root", 1982.
    ! https://www.semanticscholar.org/paper/A-note-on-King's-method-F-for-finding-a-bracketed-Popovski/513ffdb3befbf48c38bb70dbec60934472cc9903
    case(73)
        a = 0.0_wp
        b = 5.0_wp
        root =  1.4655712318767680E+00_wp
        if (present(x)) f = (x - 1.0_wp)*x*x - 1.0_wp
        if (present(latex)) latex = '(x - 1) x^2 - 1'

    case(74)
        a = 0.0_wp
        b = 8.0_wp
        root =  5.0275246628429326E+00_wp
        if (present(x)) f = ((x - 3.0_wp)*x - 9.0_wp)*x - 6.0_wp
        if (present(latex)) latex = '((x - 3) x - 9) x - 6'
    case(75:78)
        select case (nprob)
        case (75)
            a = -5.0_wp
            b = -3.0_wp
            root = -3.5437609487522587E+00_wp
        case (76)
            a = -3.0_wp
            b = -2.0_wp
            root = -2.2701871608581255E+00_wp
        case (77)
            a = -2.0_wp
            b = 0.0_wp
            root = -2.0646554491023637E-01_wp
        case (78)
            a = 0.0_wp
            b = 9.0_wp
            root = 6.0204136545206206E+00_wp
        end select
        if (present(x)) f = ((x*x - 27.0_wp)*x - 54.0_wp)*x - 10.0_wp
        if (present(latex)) latex = '((x^2 - 27) x - 54 ) x - 10'
    case(79:82)
        select case (nprob)
        case (79)
            a = 0.0_wp
            b = 2.0_wp
            root =  1.1893836076828531E+00_wp
        case (80)
            a = 2.0_wp
            b = 4.0_wp
            root = 3.4254515851826428E+00_wp
        case (81)
            a = 4.0_wp
            b = 8.0_wp
            root = 6.5745484148173572E+00_wp
        case (82)
            a = 8.0_wp
            b = 9.0_wp
            root = 8.8106163923171469E+00_wp
        end select
        if (present(x)) f = (((x-20.0_wp)*x + 133.0_wp)*x - 330.0_wp)*x + 236.0_wp
        if (present(latex)) latex = '(((x-20) x + 133) x - 330) x + 236'
    case(83)
        a = 0.0_wp
        b = 3.0_wp
        root =  1.2554228710768465E+00_wp
        if (present(x)) f = (x - 1.0_wp)*x**6 - 1.0_wp
        if (present(latex)) latex = '(x - 1) x^6 - 1'
    case(84:85)
        select case (nprob)
        case(84)
            a = -5.0_wp
            b = 0.0_wp
            root = -1.3926261305968417E+00_wp
        case(85)
            a = 0.0_wp
            b = 5.0_wp
            root = 3.0001928237608510E+00_wp
        end select
        if (present(x)) f = (((x*x - 6.0_wp)*x - 8.0_wp)*x - 3.0_wp)*x**4 - 1.0_wp
        if (present(latex)) latex = '(((x^2 - 6) x - 8) x - 3) x^4 - 1'

    case(86:88)
        select case (nprob)
        case(86)
            a = 0.0_wp
            b = 2.0_wp
            root =  1.0883595391412838E+00_wp
        case(87)
            a = 2.0_wp
            b = 6.0_wp
            root = 4.6333772273659109E+00_wp
        case(88)
            a = 6.0_wp
            b = 8.0_wp
            root = 7.2609923862369942E+00_wp
        end select
        if (present(x)) f = ((x - 13.0_wp)*x + 47.0_wp)*x - 36.0_wp - sqrt(x)
        if (present(latex)) latex = '((x - 13) x + 47 ) x - 36 - \sqrt{x}'
    case(89:90)
        select case (nprob)
        case (89)
            a = 0.0_wp
            b = 2.0_wp
            root =  1.1118325591589630E+00_wp
        case (90)
            a = 2.0_wp
            b = 5.0_wp
            root = 4.5771520639572972E+00_wp
        end select
        if (present(x)) f = exp(1.0_wp-x)*(x-1.0_wp)*10.0_wp - 1.0_wp
        if (present(latex)) latex = '10 \mathrm{e}^{1-x} (x-1) - 1'

    case(91)
        a = 2.0_wp
        b = 3.0_wp
        root =  2.8424389537844471E+00_wp
        if (present(x)) f = exp(x) + x - 20.0_wp
        if (present(latex)) latex = '\mathrm{e}^x + x - 20'

    case(92)
        a = 0.0_wp
        b = 2.0_wp
        root =  1.3065586410393502E+00_wp   ! the root in the paper is wrong for this one !
        if (present(x)) f = exp(x) + x - 5.0_wp
        if (present(latex)) latex = '\mathrm{e}^x + x - 5'

    case(93:94)
        select case (nprob)
        case (93)
            a = 0.0_wp
            b = 6.0_wp
            root =  3.1094324994726575E+00_wp
        case (94)
            a = 6.0_wp
            b = 8.0_wp
            root = 7.0453708632631685E+00_wp
        end select
        if (present(x)) f = (x - 10.0_wp)*x + 23.0_wp - x**0.4_wp
        if (present(latex)) latex = '(x - 10) x + 23 - x^{0.4}'

    case(95:98)
        select case (nprob)
        case (95)
            a = 0.0_wp
            b = 1.0_wp
            root =  3.6682419352992085E-01_wp
        case (96)
            a = 1.0_wp
            b = 5.0_wp
            root = 3.5735001943758262E+00_wp
        case (97)
            a = 5.0_wp
            b = 7.0_wp
            root = 5.7880397474352980E+00_wp
        case (98)
            a = 7.0_wp
            b = 10.0_wp
            root = 9.2131701574933741E+00_wp
        end select
        if (present(x)) f = (0.04_wp*x - 0.4_wp)*x + 0.5_wp - sin(x)
        if (present(latex)) latex = '(0.04 x - 0.4) x + 0.5 - \sin x'

    ! cases from Stage paper
    ! see also #26
    case(99)
        a = -10.0_wp
        b = 10.0_wp
        root = -7.3908513321516067E-01_wp
        if (present(x)) f = cos(x) + x
        if (present(latex)) latex = '\cos x + x'
    case(100)
        a = -10.0_wp
        b = 10.0_wp
        root = 4.0_wp / 3.0_wp
        if (present(x)) f = 1.0_wp - 0.75_wp * x
        if (present(latex)) latex = '1 - 0.75 x'

    case(101)
        a = -10.0_wp
        b = 10.0_wp
        root = 2.0_wp / 3.0_wp - 0.01_wp
        if (present(x)) then
            if (x <= 2.0_wp / 3.0_wp) then
                f =  (abs(x - 2.0_wp / 3.0_wp))**0.5_wp - 0.1_wp
            else
                f = -(abs(x - 2.0_wp / 3.0_wp))**0.5_wp - 0.1_wp
            end if
        end if
        if (present(latex)) latex = '\left\{ \begin{array}{cl} |x - 2/3|^{0.5} - 0.1 & \mathrm{if~} x \le 2/3 \\'//&
                                    ' -|x - 2/3|^{0.5} - 0.1& \mathrm{otherwise} \end{array} \right.'
    ! case(102)
    !     a = -10.0_wp
    !     b = 10.0_wp
    !     root = 2.0_wp / 3.0_wp
    !     if (present(x)) then
    !         if (x <= 2.0_wp / 3.0_wp) then
    !             f = (abs(x - 2.0_wp / 3.0_wp))**0.5_wp
    !         else
    !             f = -(abs(x - 2.0_wp / 3.0_wp))**0.5_wp
    !         end if
    !     end if
    !     if (present(latex)) latex = 'TODO'
    ! case(103)
    !     a = -10.0_wp
    !     b = 10.0_wp
    !     root = 2.0_wp / 3.0_wp
    !     if (present(x)) then
    !         if (x <= 2.0_wp / 3.0_wp) then
    !             f = (abs(x - 2.0_wp / 3.0_wp))**0.2_wp
    !         else
    !             f = -(abs(x - 2.0_wp / 3.0_wp))**0.2_wp
    !         end if
    !     end if
    !     if (present(latex)) latex = 'TODO'
    case(102)
        a = -10.0_wp
        b = 10.0_wp
        root = 7.0_wp / 9.0_wp
        if (present(x)) f = (x - 7.0_wp/9.0_wp)**3 + 0.001_wp * (x - 7.0_wp/9.0_wp)
        if (present(latex)) latex = '(x - 7/9)^3 + 0.001 (x - 7/9)'

    ! P1 in BlendTF paper
    case(103)
        a = 1.0_wp
        b = 2.0_wp
        root = 1.7320508075688773E+00_wp
        if (present(x)) f = x**2 - 3.0_wp
        if (present(latex)) latex = 'x^2 - 3'
    case(104)
        a = 2.0_wp
        b = 7.0_wp
        root = 2.2360679774997897E+00_wp
        if (present(x)) f = x**2 - 5.0_wp
        if (present(latex)) latex = 'x^2 - 5'
    case(105)
        a = 3.0_wp
        b = 7.0_wp
        root = 3.1622776601683793E+00_wp
        if (present(x)) f = x**2 - 10.0_wp
        if (present(latex)) latex = 'x^2 - 10'
    case(106)
        a = 1.0_wp
        b = 4.0_wp
        root = 2.0_wp
        if (present(x)) f = x**2 - x - 2.0_wp
        if (present(latex)) latex = 'x^2 - x - 2'
    case(107)
        a = 1.0_wp
        b = 3.0_wp
        root = 1.8284271247461901E+00_wp
        if (present(x)) f = x**2 + 2.0_wp * x - 7.0_wp
        if (present(latex)) latex = 'x^2 + 2 x - 7'
    case(108)
        a = 0.0_wp
        b = 2.0_wp
        root = 1.2599210498948732E+00_wp
        if (present(x)) f = x**3 - 2.0_wp
        if (present(latex)) latex = 'x^3 - 2'
    case(109)
        a = 0.0_wp
        b = 2.0_wp
        root = 1.5243452049841444E+00_wp
        if (present(x)) f = x * exp(x) - 7.0_wp
        if (present(latex)) latex = 'x \mathrm{e}^x - 7'
    case(110)
        a = 0.0_wp
        b = 1.0_wp
        root = 7.3908513321516064E-01_wp
        if (present(x)) f = x  - cos(x)
        if (present(latex)) latex = 'x  - \cos(x)'
    case(111)
        a = 0.0_wp
        b = 2.0_wp
        root = 1.1141571408719301E+00_wp
        if (present(x)) f = x*sin(x) - 1.0_wp
        if (present(latex)) latex = 'x \sin(x) - 1'
    case(112)
        a = -2.0_wp
        b = 4.0_wp
        root = 2.0739328090912149E+00_wp
        if (present(x)) f = x*cos(x) + 1.0_wp
        if (present(latex)) latex = 'x \cos(x) + 1'
    case(113)
        a = 0.0_wp
        b = 1.3_wp
        root = 1.0_wp
        if (present(x)) f = x**10 - 1.0_wp
        if (present(latex)) latex = 'x^{10} - 1'
    case(114)
        a = 1.0_wp
        b = 2.0_wp
        root = 1.6490132683031901E+00_wp
        if (present(x)) f = x**2 + exp(x/2.0_wp) - 5.0_wp
        if (present(latex)) latex = 'x^2 + \mathrm{e}^{x/2} - 5'
    case(115)
        a = 3.0_wp
        b = 4.0_wp
        root = 3.2215883990939420E+00_wp
        if (present(x)) f = sin(x) * sinh(x) + 1.0_wp
        if (present(latex)) latex = '\sin(x) \sinh(x) + 1'
    case(116)
        a = 2.0_wp
        b = 3.0_wp
        root = 2.1253911988111299E+00_wp
        if (present(x)) f = exp(x) - 3.0_wp * x - 2.0_wp
        if (present(latex)) latex = '\mathrm{e}^x - 3 x - 2'
    case(117)
        a = 0.5_wp
        b = 1.0_wp
        root = 8.7672621539506245E-01_wp
        if (present(x)) f = sin(x) - x**2
        if (present(latex)) latex = '\sin(x) - x^2'

    case default
        write(*,*) 'invalid case: ', nprob
        error stop 'invalid case'
    end select

    if (present(num_of_problems)) num_of_problems = 117

    ! outputs:
    if (present(ax))    ax = a
    if (present(bx))    bx = b
    if (present(xroot)) xroot = root
    if (present(fx))    fx = f
    if (present(cases)) cases = ns

    end subroutine problems

    function func(x) result(f)

        implicit none

        real(wp),intent(in) :: x
        real(wp) :: f

        call problems(x=x, fx=f)
        ifunc = ifunc + 1

    end function func

    pure subroutine insertion_sort(vec, vec2, vec3)

    implicit none

    integer,dimension(:),intent(inout) :: vec  !! sort ascending
    integer,dimension(:),intent(inout) :: vec2 !! carry this one along
    integer,dimension(:),intent(inout) :: vec3 !! carry this one along

    integer :: i,j,n

    n = size(vec)

    do i = 1+1, n
        do j = i, 1+1, -1
            if ( vec(j) < vec(j-1) ) then
                call swap(vec(j), vec(j-1))
                call swap(vec2(j),vec2(j-1))
                call swap(vec3(j),vec3(j-1))
            else
                exit
            end if
        end do
    end do

    end subroutine insertion_sort

    pure elemental subroutine swap(a,b)

    implicit none

    integer,intent(inout) :: a
    integer,intent(inout) :: b

    integer :: tmp

    tmp = a
    a   = b
    b   = tmp

    end subroutine swap

    subroutine generate_plots()

    !! generate a plot of each function.

    implicit none

    integer,parameter :: n_points = 1000
    character(len=*),parameter :: ext = '.pdf' !! plot file type

    type(pyplot) :: plt   !! pytplot handler
    integer :: num_of_problems
    integer :: istat,i,ic
    character(len=10) :: s1,s2
    real(wp) :: x,ax,bx,xroot,froot,delta
    integer,dimension(:),allocatable :: cases_to_run
    real(wp),dimension(n_points) :: xvec
    real(wp),dimension(n_points) :: yvec
    character(len=:),allocatable :: filename, title, latex

    write(*,*) 'generate_plots...'

    n = 1  ! initialize
    nprob = 1
    call problems(num_of_problems=num_of_problems)

    do nprob = 1, num_of_problems

        write(*,*) 'case', nprob, '/', num_of_problems

        call problems(cases=cases_to_run,latex=latex)
        write(s1,'(I10)') nprob; s1 = trim(adjustl(s1)) ! int to str

        do ic = 1, size(cases_to_run)

            n = cases_to_run(ic)

            write(s2,'(I10)') n; s2 = trim(adjustl(s2)) ! int to str

            call problems(ax=ax, bx=bx, xroot=xroot)
            call problems(x=xroot, fx=froot)
            delta = (bx-ax)/(n_points-1)

            do i = 1, n_points
                xvec(i) = ax + delta * (i-1)
                call problems(x=xvec(i), fx=yvec(i))
            end do

            if (size(cases_to_run)==1) then
                title = 'Case '//trim(s1)//' : $f(x) = '//latex//'$'
                filename = 'plottest_'//'CASE='//trim(s1)//ext
            else
                title = 'Case '//trim(s1)//' (n='//trim(s2)//')'//' : $f(x) = '//latex//'$'
                filename = 'plottest_'//'CASE='//trim(s1)//'_N='//trim(s2)//ext
            end if

            call plt%initialize(grid=.true.,xlabel='x',ylabel='f(x)',figsize=[10,5],&
                                title=title,legend=.true.,&
                                tight_layout=.true.,&
                                real_fmt = '(E30.16E3)',&
                                usetex=.true.,raw_strings=.true.)
            call plt%add_plot(xvec,yvec,label='f(x)',linestyle='-',markersize=5,linewidth=2,istat=istat)
            call plt%add_plot([xroot],[froot],label='root',linestyle='.',markersize=10,linewidth=2,istat=istat)
            call plt%savefig(filename,istat=istat)

        end do

    end do

    end subroutine generate_plots

!*****************************************************************************************
    end program root_tests
!*****************************************************************************************


!------------------------------------------------------------------------------------------
! File:      S3M_Module_Tools_Interp.f90
! Author(s): Fabio Delogu.
!
! Created on April 28, 2017, 4:12 PM
!
! Module to define interpolation tools
!------------------------------------------------------------------------------------------

!------------------------------------------------------------------------------------------
! Module header
module S3M_Module_Tools_Interp

    !------------------------------------------------------------------------------------------
    ! External module(s) and implicit none
    use S3M_Module_Tools_Debug

    implicit none
    !------------------------------------------------------------------------------------------

contains

    !------------------------------------------------------------------------------------------
    ! Subroutine to space linearly an array to two numbers
    subroutine linspace(xmin,xmax,x)

        real(kind = 4), intent(in)      :: xmin,xmax
        real(kind = 4), intent(out)     :: x(:)
        integer(kind = 4)               :: i,n

        n = size(x)
        if (n == 1) then
            if(xmin /= xmax) then
                call mprintf(.true., iERROR, 'Cannot call linspace with n=1 and xmin /= xmax')
                stop
            else
                x = xmin
            end if
        else
            do i=1,n
                x(i) = (xmax-xmin) * real(i-1,kind = 4) / real(n-1,kind = 4) + xmin
            end do
        end if

    end subroutine linspace
    !------------------------------------------------------------------------------------------

    !------------------------------------------------------------------------------------------
    ! Subroutine to evaluate the nearest neighbor interpolant
    subroutine nearest_interp_1d ( nd, xd, yd, ni, xi, yi, ki)

        ! The nearest neighbor interpolant L(ND,XD,YD)(X) is the piecewise
        ! constant function which interpolates the data (XD(I),YD(I)) for I = 1
        ! to ND.

        ! Input, integer ND, the number of data points.
        ! ND must be at least 1.

        ! Input, double precision XD(ND), the data points.
        ! Input, double precision YD(ND), the data values.
        ! Input, integer NI, the number of interpolation points.
        ! Input, double precision XI(NI), the interpolation points.
        ! Output, double precision YI(NI), the interpolated values.

        integer(kind = 4)   ::  nd
        integer(kind = 4)   ::  ni

        real(kind = 4)      ::  d
        real(kind = 4)      ::  d2
        integer(kind = 4)   ::  i
        integer(kind = 4)   ::  j
        integer(kind = 4)   ::  k
        real(kind = 4)      ::  xd(nd)
        real(kind = 4)      ::  xi(ni)
        real(kind = 4)      ::  yd(nd)
        real(kind = 4)      ::  yi(ni)
        integer(kind = 4)   ::  ki(ni)

        do i = 1, ni

            k = 1
            d = abs ( xi(i) - xd(k) )

            do j = 2, nd

                d2 = abs ( xi(i) - xd(j) )

                if ( d2 .lt. d ) then
                    k = j
                    d = d2
                end if

            end do

            yi(i) = yd(k)
            ki(i) = k

        end do

    end subroutine nearest_interp_1d
    !------------------------------------------------------------------------------------

end module S3M_Module_Tools_Interp
!------------------------------------------------------------------------------------------


      DOUBLE PRECISION FUNCTION PHO_BESSI1(X)
C**********************************************************************
C
C      Bessel Function I1
C
C**********************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION ax , besli1 , X , y
      SAVE

      ax = ABS(X)

      IF ( ax.LT.3.75D0 ) THEN
         y = (X/3.75D0)**2
         besli1 = ax*
     &            (0.5D0+y*(0.87890594D0+y*(0.51498869D0+y*(0.15084934D0
     &            +y*(0.2658733D-1+y*(0.301532D-2+y*0.32411D-3))))))
      ELSE
         y = 3.75D0/ax
         besli1 = 0.2282967D-1 +
     &            y*(-0.2895312D-1+y*(0.1787654D-1-y*0.420059D-2))
         besli1 = 0.39894228D0 +
     &            y*(-0.3988024D-1+y*(-0.362018D-2+y*(0.163801D-2+
     &            y*(-0.1031555D-1+y*besli1))))
         besli1 = besli1*EXP(ax)/SQRT(ax)
      END IF
      IF ( X.LT.0.D0 ) besli1 = -besli1

      PHO_BESSI1 = besli1

      END FUNCTION


 	!--------------------------------------------------------------------
	!
	! PURPOSE
	!
	! This program numerically solves the 2D incompressible Navier-Stokes
	! on a Square Domain [0,1]x[0,1] using pseudo-spectral methods and
	! Crank-Nicolson timestepping. The numerical solution is compared to
	! the exact Taylor-Green Vortex Solution.
	!
	! AUTHORS
	!
	! B. Cloutier, B.K. Muite, P. Rigge
	! 4 June 2012
	!
	! Periodic free-slip boundary conditions and Initial conditions:
	!	u(x,y,0)=sin(2*pi*x)cos(2*pi*y)
	!	v(x,y,0)=-cos(2*pi*x)sin(2*pi*y)
	! Analytical Solution (subscript denote derivatives):
	!	u(x,y,t)=sin(2*pi*x)cos(2*pi*y)exp(-8*pi^2*t/Re)
	!	v(x,y,t)=-cos(2*pi*x)sin(2*pi*y)exp(-8*pi^2*t/Re)
	!   u_y(x,y,t)=-2*pi*sin(2*pi*x)sin(2*pi*y)exp(-8*pi^2*t/Re)
	!	v_x(x,y,t)=2*pi*sin(2*pi*x)sin(2*pi*y)exp(-8*pi^2*t/Re)
	!	omega=v_x-u_y
	!
	! .. Parameters ..
	!  Nx				= number of modes in x - power of 2 for FFT
	!  Ny				= number of modes in y - power of 2 for FFT
	!  nplots			= number of plots produced
	!  plotgap			= number of timesteps inbetween plots
	!  Re 				= dimensionless Renold's number
	!  ReInv			= 1/Re for optimization
	!  dt				= timestep size
	!  dtInv			= 1/dt for optimization
	!  tol				= determines when convergences is reached
	!  scalemodes		= 1/(Nx*Ny), scaling after preforming FFTs
	! .. Scalars ..
	!  i				= loop counter in x direction
	!  j				= loop counter in y direction
	!  n				= loop counter for timesteps direction
	!  allocatestatus	= error indicator during allocation
	!  time				= times at which data is saved
	!  chg				= error at each iteration
	! .. Arrays ..
	!  omeg				= vorticity	in real space
	!  omeghat			= 2D Fourier transform of vorticity
	!						at next iterate
	!  omegoldhat		= 2D Fourier transform of vorticity at previous
	!						iterate
	!  nl				= nonlinear term
	!  nlhat			= nonlinear term in Fourier space
	!  nloldhat			= nonlinear term in Fourier space
	!						at previous iterate
	!  omegexact		= taylor-green vorticity at
	!						at final step
	!  psihat			= 2D Fourier transform of streamfunction
	!						at next iteration
	!  temp1/temp2/temp3= reusable complex/real space used for
	!						calculations. This reduces number of
	!						arrays stored.
	! .. Vectors ..
	!  kx				= fourier frequencies in x direction
	!  ky				= fourier frequencies in y direction
	!  x				= x locations
	!  y				= y locations
	!  name_config		= array to store filename for data to be saved
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External libraries required
	!       Cuda FFT
	!       OpenACC
	!       FFTW3           -- Fastest Fourier Transform in the West
	!                       (http://www.fftw.org/)
	!       OpenMP

	module precision
	! Precision control

	integer, parameter, public :: Single = kind(0.0) ! Single precision
	integer, parameter, public :: Double = kind(0.0d0) ! Double precision

	integer, parameter, public :: fp_kind = Double
	!integer, parameter, public :: fp_kind = Single

	end module precision

	module cufft

	integer, public :: CUFFT_FORWARD = -1
	integer, public :: CUFFT_INVERSE = 1
	integer, public :: CUFFT_R2C = Z'2a' ! Real to Complex (interleaved)
	integer, public :: CUFFT_C2R = Z'2c' ! Complex (interleaved) to Real
	integer, public :: CUFFT_C2C = Z'29' ! Complex to Complex, interleaved
	integer, public :: CUFFT_D2Z = Z'6a' ! Double to Double-Complex
	integer, public :: CUFFT_Z2D = Z'6c' ! Double-Complex to Double
	integer, public :: CUFFT_Z2Z = Z'69' ! Double-Complex to Double-Complex

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	! cufftPlan2d(cufftHandle *plan, int nx,int ny, cufftType type)
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	interface cufftPlan2d
	subroutine cufftPlan2d(plan, nx, ny, type) bind(C,name='cufftPlan2d')
	use iso_c_binding
	integer(c_int):: plan
	integer(c_int),value:: nx, ny, type
	end subroutine cufftPlan2d
	end interface cufftPlan2d

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	! cufftDestroy(cufftHandle plan)
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	interface cufftDestroy
	subroutine cufftDestroy(plan) bind(C,name='cufftDestroy')
	use iso_c_binding
	integer(c_int),value:: plan
	end subroutine cufftDestroy
	end interface cufftDestroy

	interface cufftExecD2Z
    subroutine cufftExecD2Z(plan, idata, odata) &
          & bind(C,name='cufftExecD2Z')
       use iso_c_binding
       use precision
       integer(c_int),  value  :: plan
       real(fp_kind),   device :: idata(1:nx,1:ny)
       complex(fp_kind),device :: odata(1:nx/2+1,1:ny)
    end subroutine cufftExecD2Z
	end interface cufftExecD2Z

	interface cufftExecZ2D
    subroutine cufftExecZ2D(plan, idata, odata) &
          & bind(C,name='cufftExecZ2D')
       use iso_c_binding
       use precision
       integer(c_int),value:: plan
       complex(fp_kind),device:: idata(1:nx/2+1,1:ny)
       real(fp_kind),device :: odata(1:nx,1:ny)
    end subroutine cufftExecZ2D
	end interface cufftExecZ2D
	end module cufft

	PROGRAM main
	USE precision
	USE cufft
	USE openacc

	IMPLICIT NONE
    INTEGER(kind=4), PARAMETER 			::  Nx=512
	INTEGER(kind=4), PARAMETER 			::  Ny=512
	REAL(kind=8), PARAMETER			::  dt=0.000125d0
	REAL(kind=8), PARAMETER			::  dtInv=1.0d0/REAL(dt,kind(0d0))
	REAL(kind=8), PARAMETER	&
		::  pi=3.14159265358979323846264338327950288419716939937510d0
	REAL(kind=8), PARAMETER			::  Re=1.0d0
	REAL(kind=8), PARAMETER			::	ReInv=1.0d0/REAL(Re,kind(0d0))
	REAL(kind=8), PARAMETER			::	tol=0.1d0**10
	REAL(kind=8)					::  scalemodes
	REAL(kind=8)					::  chg
	INTEGER(kind=4), PARAMETER		::	nplots=1, plotgap=20
	COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE		::  kx,ky
	REAL(kind=8), DIMENSION(:), ALLOCATABLE			::  x,y,time
	REAL(kind=8), DIMENSION(:,:), ALLOCATABLE		:: omeg,nl, temp2, temp3, omegexact
	COMPLEX(kind=8), DIMENSION(:,:), ALLOCATABLE	:: omegoldhat, nloldhat,&
													   omeghat,nlhat, psihat,temp1
	INTEGER(kind=4)								::  i,j,n,t, allocatestatus
	INTEGER(kind=4)								::  pland2z,planz2d
	INTEGER(kind=4)								::  count, iol
	CHARACTER*100			 					::  name_config
	INTEGER(kind=4)								::  start, finish, count_rate
	INTEGER(kind=4)								::  ierr,vecsize,gangsize
	INTEGER(kind=8)								::  planfxy,planbxy

	vecsize=32
	gangsize=16
  	PRINT *,'Grid:',Nx,'X',Ny
	PRINT *,'dt:',dt
	ALLOCATE(time(1:nplots+1),kx(1:Nx),ky(1:Ny),x(1:Nx),y(1:Ny),&
			omeg(1:Nx,1:Ny),omegoldhat(1:Nx/2+1,1:Ny),&
			nloldhat(1:Nx/2+1,1:Ny),temp3(1:Nx,1:Ny),omeghat(1:Nx/2+1,1:Ny),&
			nl(1:Nx,1:Ny),nlhat(1:Nx/2+1,1:Ny), psihat(1:Nx/2+1,1:Ny),&
			temp1(1:Nx/2+1,1:Ny),omegexact(1:Nx,1:Ny),temp2(1:Nx,1:Ny),&
			stat=AllocateStatus)
	IF (AllocateStatus .ne. 0) STOP
	PRINT *,'allocated space'

	CALL cufftPlan2D(pland2z,nx,ny,CUFFT_D2Z)
	CALL cufftPlan2D(planz2d,nx,ny,CUFFT_Z2D)

	PRINT *,'Setup 2D FFTs'

	! setup fourier frequencies in x-direction
	!$acc data copy(kx,ky,x,y,time,temp3,omeg,nl,temp1,temp2,omegoldhat,nloldhat,omeghat,nlhat,psihat)
	PRINT *, 'Copied arrays over to device'
	!$acc kernels loop
	DO i=1,Nx/2+1
		kx(i)= 2.0d0*pi*cmplx(0.0d0,1.0d0)*REAL(i-1,kind(0d0))
	END DO
	!$acc end kernels
	kx(1+Nx/2)=0.0d0
	!$acc kernels loop
	DO i = 1,Nx/2 -1
		kx(i+1+Nx/2)=-kx(1-i+Nx/2)
	END DO
	!$acc end kernels
	!$acc kernels loop
	DO i=1,Nx
		x(i)=REAL(i-1,kind(0d0))/REAL(Nx,kind(0d0))
	END DO
	!$acc end kernels
	! setup fourier frequencies in y-direction
	!$acc kernels loop
	DO j=1,Ny/2+1
		ky(j)= 2.0d0*pi*cmplx(0.0d0,1.0d0)*REAL(j-1,kind(0d0))
	END DO
	!$acc end kernels
	ky(1+Ny/2)=0.0d0
	!$acc kernels loop
	DO j = 1,Ny/2 -1
		ky(j+1+Ny/2)=-ky(1-j+Ny/2)
	END DO
	!$acc end kernels
	!$acc kernels loop
	DO j=1,Ny
		y(j)=REAL(j-1,kind(0d0))/REAL(Ny,kind(0d0))
	END DO
	!$acc end kernels
	scalemodes=1.0d0/REAL(Nx*Ny,kind(0d0))
	PRINT *,'Setup grid and fourier frequencies'

	!initial data
	!$acc kernels loop
	DO j=1,Ny
		DO i=1,NX
			omeg(i,j)=4.0d0*pi*sin(2.0d0*pi*x(i))*sin(2.0d0*pi*y(j))!+0.01d0*cos(2.0d0*pi*y(j))
		END DO
	END DO
	!$acc end kernels
	!\hat{\omega^{n,k}}
	CALL cufftExecD2Z(pland2z,omeg,omeghat)

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!get initial nonlinear term using omeghat, psihat, u, and v!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!\hat{\psi^{n+1,k+1}}
	!$acc kernels loop gang(gangsize), vector(vecsize)
	DO j=1,Ny
		DO i=1,Nx/2+1
			psihat(i,j)=-omeghat(i,j)/(kx(i)*kx(i)+ky(j)*ky(j) + 0.1d0**14)
		END DO
	END DO
	!$acc end kernels
	!\omega^{n+1,k+1}
	CALL cufftExecZ2D(planz2d,omeghat,omeg)

	!get \hat{\psi_y^{n+1,k+1}} used to get u, NOTE: u=\psi_y
	!$acc kernels loop gang(gangsize), vector(vecsize)
	DO j=1,Ny
		DO i=1,Nx/2+1
			temp1(i,j)=psihat(i,j)*ky(j)*scalemodes
		END DO
	END DO
	!$acc end kernels
	CALL cufftExecZ2D(planz2d,temp1,temp3) !u

	! \hat{\omega_x^{n,k}}
	!$acc kernels loop
	DO j=1,Ny
		DO i=1,Nx/2+1
			temp1(i,j)=omeghat(i,j)*kx(i)
		END DO
	END DO
	!$acc end kernels
	! \omega_x^{n,k}
	CALL cufftExecZ2D(planz2d,temp1,temp2)

	! first part nonlinear term in real space
	!$acc kernels loop
	DO j=1,Ny
		DO i=1,Nx
			nl(i,j)=temp3(i,j)*temp2(i,j)
		END DO
	END DO
	!$acc end kernels

	!get \hat{\psi_x^{n+1,k+1}} used to get v, NOTE: v=-\psi_x
	!$acc kernels loop gang(gangsize), vector(vecsize)
	DO j=1,Ny
		DO i=1,Nx/2+1
			temp1(i,j)=-psihat(i,j)*kx(i)*scalemodes
		END DO
	END DO
	!$acc end kernels
	CALL cufftExecZ2D(planz2d,temp1,temp3) !v

	! \hat{\omega_y^{n,k}}
	!$acc kernels loop
	DO j=1,Ny
		DO i=1,Nx/2+1
			temp1(i,j)=omeghat(i,j)*ky(j)
		END DO
	END DO
	!$acc end kernels
	! \omega_y^{n,k}
	CALL cufftExecZ2D(planz2d,temp1,temp2)

	! get the rest of nonlinear term in real space
	!$acc kernels loop
	DO j=1,Ny
		DO i=1,Nx
			nl(i,j)=(nl(i,j)+temp3(i,j)*temp2(i,j))*scalemodes
		END DO
	END DO
	!$acc end kernels
	! transform nonlinear term into fourier space
	CALL cufftExecD2Z(pland2z,nl,nlhat)
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	!$acc kernels loop
	DO j=1,Ny
		DO i=1,Nx
			temp2(i,j)=omeg(i,j)
		END DO
	END DO
	!$acc end kernels

	PRINT *,'Got initial data, starting timestepping'
	time(1)=0.0d0
	CALL system_clock(start,count_rate)
	DO t=1,nplots
		DO n=1,plotgap
			chg=1.0d0
			! save old values(__^{n,k} terms in equation)
			!$acc kernels loop gang(gangsize), vector(vecsize)
			DO j=1,Ny
				DO i=1,Nx/2+1
					nloldhat(i,j)=nlhat(i,j)
				END DO
			END DO
			!$acc end kernels
			!$acc kernels loop gang(gangsize), vector(vecsize)
			DO j=1,Ny
				DO i=1,Nx/2+1
					omegoldhat(i,j)=omeghat(i,j)
				END DO
			END DO
			!$acc end kernels
			DO WHILE (chg>tol)
				!Crank-Nicolson timestepping to get \hat{\omega^{n+1,k+1}}
				!$acc kernels loop gang(gangsize), vector(vecsize)
				DO j=1,Ny
					DO i=1,Nx/2+1
						omeghat(i,j)=( (dtInv+0.5d0*ReInv*(kx(i)*kx(i)+ky(j)*ky(j)))&
								*omegoldhat(i,j) - 0.5d0*(nloldhat(i,j)+nlhat(i,j)))/&
								(dtInv-0.5d0*ReInv*(kx(i)*kx(i)+ky(j)*ky(j)))
					END DO
				END DO
				!$acc end kernels
				CALL cufftExecZ2D(planz2d,omeghat,omeg)

				! check for convergence
				chg=0.0d0
				!$acc kernels loop gang(gangsize), vector(vecsize)
				DO j=1,Ny
					DO i=1,Nx
						chg=chg+(omeg(i,j)-temp2(i,j))*(omeg(i,j)-temp2(i,j))&
						*scalemodes*scalemodes
					END DO
				END DO
				!$acc end kernels

				!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
				!get nonlinear term using omeghat, psihat, u, and v!
				!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
				!\hat{\psi^{n+1,k+1}}
				!$acc kernels loop gang(gangsize), vector(vecsize)
				DO j=1,Ny
					DO i=1,Nx/2+1
						psihat(i,j)=-omeghat(i,j)/(kx(i)*kx(i)+ky(j)*ky(j) + 0.1d0**14)
					END DO
				END DO
				!$acc end kernels
				!\omega^{n+1,k+1}
				CALL cufftExecZ2D(planz2d,omeghat,omeg)

				!get \hat{\psi_y^{n+1,k+1}} used to get u, NOTE: u=\psi_y
				!$acc kernels loop gang(gangsize), vector(vecsize)
				DO j=1,Ny
					DO i=1,Nx/2+1
						temp1(i,j)=psihat(i,j)*ky(j)*scalemodes
					END DO
				END DO
				!$acc end kernels
				CALL cufftExecZ2D(planz2d,temp1,temp3) !u

				! \hat{\omega_x^{n,k}}
				!$acc kernels loop
				DO j=1,Ny
					DO i=1,Nx/2+1
						temp1(i,j)=omeghat(i,j)*kx(i)
					END DO
				END DO
				!$acc end kernels
				! \omega_x^{n,k}
				CALL cufftExecZ2D(planz2d,temp1,temp2)

				! first part nonlinear term in real space
				!$acc kernels loop
				DO j=1,Ny
					DO i=1,Nx
						nl(i,j)=temp3(i,j)*temp2(i,j)
					END DO
				END DO
				!$acc end kernels

				!get \hat{\psi_x^{n+1,k+1}} used to get v, NOTE: v=-\psi_x
				!$acc kernels loop gang(gangsize), vector(vecsize)
				DO j=1,Ny
					DO i=1,Nx/2+1
						temp1(i,j)=-psihat(i,j)*kx(i)*scalemodes
					END DO
				END DO
				!$acc end kernels
				CALL cufftExecZ2D(planz2d,temp1,temp3)

				! \hat{\omega_y^{n,k}}
				!$acc kernels loop
				DO j=1,Ny
					DO i=1,Nx/2+1
						temp1(i,j)=omeghat(i,j)*ky(j)
					END DO
				END DO
				!$acc end kernels
				! \omega_y^{n,k}
				CALL cufftExecZ2D(planz2d,temp1,temp2)

				! get the rest of nonlinear term in real space
				!$acc kernels loop
				DO j=1,Ny
					DO i=1,Nx
						nl(i,j)=(nl(i,j)+temp3(i,j)*temp2(i,j))*scalemodes
					END DO
				END DO
				!$acc end kernels
				! transform nonlinear term into fourier space
				CALL cufftExecD2Z(pland2z,nl,nlhat)
				!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

				!\omega^{n+1,k+1} is saved for next iteration
				!$acc kernels loop gang(gangsize), vector(vecsize)
				DO j=1,Ny
					DO i=1,Nx
						temp2(i,j)=omeg(i,j)
					END DO
				END DO
				!$acc end kernels
			END DO
		END DO
		time(t+1)=time(t)+dt*plotgap
		!PRINT *, time(t+1)
	END DO
	CALL system_clock(finish,count_rate)
	PRINT*,'Program took ',REAL(finish-start)/REAL(count_rate),&
			'for Time stepping'

	!get exact omega
	!$acc kernels loop gang(gangsize), vector(vecsize)
	DO j=1,Ny
		DO i=1,Nx
			omegexact(i,j)=4.0d0*pi*sin(2.0d0*pi*x(i))*&
				sin(2.0d0*pi*y(j))*exp(-8.0d0*ReInv*pi**2*nplots*plotgap*dt)
		END DO
	END DO
	!$acc end kernels
	!$acc end data

	!compute max error
	PRINT *,'Max Error:',maxval(abs(omeg*scalemodes-omegexact))

	!!!!!!!!!!!!!!!!!!!!!!!!
	!copy over data to disk!
	!!!!!!!!!!!!!!!!!!!!!!!!
	write(name_config,'(a,i0,a)') 'omega',1,'.datbin'
	INQUIRE(iolength=iol) omeg(1,1)
	OPEN(unit=11,FILE=name_config,form="unformatted", access="direct",recl=iol)
	count = 1
	DO j=1,Ny
		DO i=1,Nx
			WRITE(11,rec=count) omeg(i,j)*scalemodes
			count=count+1
		END DO
	END DO
	CLOSE(11)

	name_config = 'time.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO i=1,Nplots+1
		WRITE(11,*) time(i)
	END DO
	CLOSE(11)

	name_config = 'xcoord.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO i=1,Nx
		WRITE(11,*) x(i)
	END DO
	CLOSE(11)

	name_config = 'ycoord.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO j=1,Ny
		WRITE(11,*) y(j)
	END DO
	CLOSE(11)
	!!!!!!!!!!!!!!!!!!!!!!!!

	CALL cufftDestroy(pland2z)
	CALL cufftDestroy(planz2d)

	DEALLOCATE(time,temp1,temp2,temp3,kx,ky,x,y,&
			omeg,omegoldhat,omegexact, nloldhat,&
			omeghat,nl, nlhat, psihat,&
			stat=AllocateStatus)
	IF (AllocateStatus .ne. 0) STOP
	PRINT *,'Program execution complete'

	END PROGRAM main


FUNCTION LINTERP(xin,yin,xout)

  !routine to linearly interpolate a function yin(xin) at xout

  USE sps_vars; USE sps_utils, ONLY: locate
  IMPLICIT NONE
  REAL(SP), DIMENSION(:), INTENT(in) :: xin,yin
  REAL(SP), INTENT(in)  :: xout
  REAL(SP) :: linterp
  INTEGER :: klo,n

  !---------------------------------------------------------------!
  !---------------------------------------------------------------!

  n   = SIZE(xin)
  klo = MAX(MIN(locate(xin,xout),n-1),1)

  linterp = yin(klo) + (yin(klo+1)-yin(klo))*&
       (xout-xin(klo))/(xin(klo+1)-xin(klo))

END FUNCTION LINTERP


program main
    implicit none
    integer :: n
    print "(a)", "Number n is "
    read *, n
    print "(a, i0)", "n! is ", factorial(n)
contains
    recursive function factorial(i) result(answer)
        integer             :: answer
        integer, intent(in) :: i
        if (i == 0) then
            answer = 1
        else
            answer = i * factorial(i - 1)
        end if
    end function factorial
end program main


!##############################################################################
! PROGRAM portfoliochoice_MCM
!
! ## Portfolio choice with Monte Carlo minimization (MCM)
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
program portfoliochoice_MCM

    use toolbox

    implicit none
    integer, parameter :: TT = 5        ! number of time periods
    integer, parameter :: NN = 3        ! number of stocks
    integer, parameter :: NP = 100      ! number of mc portfolios
    real*8, parameter :: gamma = 10d0   ! risk aversion
    real*8, parameter :: r_f = 0.05     ! the risk free rate

    real*8 :: omega(0:NN)
    real*8 :: mu(0:NN), sig(0:NN,0:NN)
    real*8 :: mu_p, sig_p

    real*8 :: omega_mc(0:NN,NP), mu_mc(NP), sig_mc(NP)
    integer :: ii, ik, maxi

    ! get returns and their statistical properties
    call returns

    ! simulate initial portfolios
    do ii = 1, NP
        call simulate_uniform(omega_mc(:, ii), 0d0, 1d0)
        omega_mc(:, ii) = omega_mc(:, ii)/sum(omega_mc(:, ii))
    enddo

    ! perform updating steps
    do ik = 1, 1000

        ! calculate means and returns of the portfolios
        do ii = 1, NP
            mu_mc(ii)  = dot_product(mu, omega_mc(:, ii))
            sig_mc(ii) = dot_product(omega_mc(:, ii), matmul(sig, omega_mc(:, ii)))
        enddo

        ! get portfolio that maximizes investors utility
        maxi = maxloc(mu_mc - gamma/2d0*sig_mc, 1)

        ! store maximum
        omega = omega_mc(:, maxi)

        ! simulate an updated set of portfolios around maximum
        do ii = 1, NP-1

            ! get new normalized portfolio
            call simulate_uniform(omega_mc(:, ii), 0d0, 1d0)
            omega_mc(:, ii) = omega_mc(:, ii)/sum(omega_mc(:, ii))

            ! create linear combination between old and new
            omega_mc(:, ii) = 0.9d0*omega + 0.1d0*omega_mc(:, ii)
        enddo

        ! store maximum in last entry
        omega_mc(:, NP) = omega
    enddo

    ! calculate return and variance
    mu_p   = dot_product(mu, omega)
    sig_p  = dot_product(omega, matmul(sig, omega))

    ! print results
    write(*,'(a)') 'Portfolio shares:   Riskless   Stock 1   Stock 2   Stock 3      mu_p     sig_p'
    write(*,'(a,6f10.4)')'Optimal Portfolio ', omega(0), omega(1), omega(2), omega(3), mu_p, sig_p

contains

    ! get returns and statictical properties
    subroutine returns

        implicit none
        integer :: ii, ij
        real*8 :: odat(0:TT,NN), r(TT,NN)

        ! initialize price data
        odat(0,:) = (/ 1.00d0, 2.00d0, 3.00d0 /)
        odat(1,:) = (/ 1.02d0, 2.65d0, 2.80d0 /)
        odat(2,:) = (/ 1.17d0, 2.40d0, 4.50d0 /)
        odat(3,:) = (/ 1.08d0, 2.70d0, 4.20d0 /)
        odat(4,:) = (/ 1.16d0, 2.85d0, 3.20d0 /)
        odat(5,:) = (/ 1.26d0, 2.75d0, 4.20d0 /)

        ! compute return per period
        do ii = 1, NN
            do ij = 1, TT
                r(ij, ii) = odat(ij, ii)/odat(ij-1, ii)-1d0
            enddo
        enddo

        ! compute expected value
        do ii = 1, NN
            mu(ii) = sum(r(:, ii))/dble(TT)
        enddo

        ! compute covariance matrix
        do ii = 1, NN
            do ij = 1, NN
                sig(ii, ij) = dot_product(r(:, ii)-mu(ii), r(:, ij)-mu(ij))
            enddo
        enddo
        sig = sig/dble(TT)

        ! store risk free rate and variance
        mu(0) = r_f
        sig(0, :) = 0d0
        sig(:, 0) = 0d0

    end subroutine

end program


program main

    use open_linalg_m, only: inv, operator(.i.)

    real :: x(2, 2) = reshape([1, 2, 3, 4], [2, 2])

    x = .i.x

    do i = 1, 2
        print 100, x(i, :)
    end do

100 format(*(f6.2))

end program main

!@note: Fortran array column first
! -2.00  1.50
!  1.00 -0.50


program TemperatureConverter
implicit none

real:: f, k

write(*,*) "What is the temperature in Fahrenheit: "
read(*,*) f

k = ((5./9)*(f-32.)) + 273.15

write(*,*) "k=", k

end program


module constants
  use precision1, only : dp
  implicit none
  real(dp), parameter :: PI = 3.141592653589793238462643383279502884197_dp
  real(dp), parameter :: HALFPI = 1.57079632679489661923132169163975144209858_dp
  real(dp), parameter :: PIO3 = 1.047197551196597746154214461093167628066_dp
  real(dp), parameter :: THIRD = 0.333333333333333333333333333333333333333_dp
  real(dp), parameter :: TWOTHIRD = 0.66666666666666666666666666666666666666_dp
  real(dp), parameter :: SQRT2 = 1.41421356237309504880168872420969807856967_dp
  real(dp), parameter :: SQRT3 = 1.732050807568877293527446341505872366943_dp
  real(dp), parameter :: DEG2RAD = PI/180._dp
  real(dp), parameter :: RAD2DEG = 180._dp/PI

  real(dp), parameter :: MPC_IN_M = 3.085678e22_dp
  real(dp), parameter :: SOLAR_MASS_IN_KG = 1.989e30_dp
  real(dp), parameter :: YEAR_IN_SEC = 31557600._dp

  real(dp), parameter :: MU = 1.0e15_dp * SOLAR_MASS_IN_KG !1 Mass unit   = 10^15 M_sun
  real(dp), parameter :: LU = MPC_IN_M                     !1 Length unit = Mpc
  real(dp), parameter :: TU = 1.0e6_dp * YEAR_IN_SEC       !1 Time unit   = 10^6 years

  real(dp), parameter :: SPEED_OF_LIGHT = 299792458._dp
  real(dp), parameter :: CS = SPEED_OF_LIGHT * TU / LU
  real(dp), parameter :: GCONS = 6.6742e-11_dp * MU * TU**2 / LU**3
  real(dp), parameter :: KAPPA = 8._dp * PI * GCONS / CS**4
  real(dp), parameter :: KAPPA_C2 = KAPPA * CS**2
end module constants


	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This program solves nonlinear Schrodinger equation in 3 dimensions
	! i*u_t+Es*|u|^2u+u_{xx}+u_{yy}+u_{zz}=0
	! using a second order time spectral splitting scheme
	!
	! The boundary conditions are u(x=0,y,z)=u(2*Lx*\pi,y,z),
	!	u(x,y=0,z)=u(x,y=2*Ly*\pi,z), u(x,y,z=0)=u(x,y,z=2*Lz*\pi)
	! The initial condition is u=exp(-x^2-y^2)
	!
	! .. Parameters ..
	!  Nx				= number of modes in x - power of 2 for FFT
	!  Ny				= number of modes in y - power of 2 for FFT
	!  Nz				= number of modes in z - power of 2 for FFT
	!  Nt				= number of timesteps to take
	!  Tmax				= maximum simulation time
	!  plotgap			= number of timesteps between plots
	!  FFTW_IN_PLACE 	= value for FFTW input
	!  FFTW_MEASURE 	= value for FFTW input
	!  FFTW_EXHAUSTIVE 	= value for FFTW input
	!  FFTW_PATIENT 	= value for FFTW input
	!  FFTW_ESTIMATE 	= value for FFTW input
	!  FFTW_FORWARD     = value for FFTW input
	!  FFTW_BACKWARD	= value for FFTW input
	!  pi = 3.14159265358979323846264338327950288419716939937510d0
	!  Lx				= width of box in x direction
	!  Ly				= width of box in y direction
	!  Lz				= width of box in z direction
	!  ES				= +1 for focusing and -1 for defocusing
	! .. Scalars ..
	!  i				= loop counter in x direction
	!  j				= loop counter in y direction
	!  k				= loop counter in z direction
	!  n				= loop counter for timesteps direction
	!  allocatestatus	= error indicator during allocation
	!  start			= variable to record start time of program
	!  finish			= variable to record end time of program
	!  count_rate		= variable for clock count rate
	!  count			= keep track of information written to disk
	!  iol				= size of array to write to disk
	!  planfxyz			= Forward 3d fft plan
	!  planbxyz			= Backward 3d fft plan
	!  dt				= timestep
	!  modescalereal	= Number to scale after backward FFT
	!  ierr				= error code
	! .. Arrays ..
	!  unax 			= approximate solution
	!  vnax 			= Fourier transform of approximate solution
	!  potx 			= potential
	! .. Vectors ..
	!  kx				= fourier frequencies in x direction
	!  ky				= fourier frequencies in y direction
	!  x				= x locations
	!  y				= y locations
	!  time				= times at which save data
	!  name_config		= array to store filename for data to be saved
	!  fftfxy			= array to setup 2D Fourier transform
	!  fftbxy			= array to setup 2D Fourier transform
	!
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!
	! External libraries required
	! FFTW3	 -- Fast Fourier Transform in the West Library
	!			(http://www.fftw.org/)
	PROGRAM main
	! Declare variables
	IMPLICIT NONE
	INTEGER(kind=4), PARAMETER	::  Nx=2**5
	INTEGER(kind=4), PARAMETER 	::  Ny=2**5
	INTEGER(kind=4), PARAMETER 	::  Nz=2**5
	INTEGER(kind=4), PARAMETER	::  Nt=50
	INTEGER(kind=4), PARAMETER	::  plotgap=10
	REAL(kind=8), PARAMETER	::&
		pi=3.14159265358979323846264338327950288419716939937510d0
	REAL(kind=8), PARAMETER	::  Lx=2.0d0,Ly=2.0d0,Lz=2.0d0
	REAL(kind=8), PARAMETER	::  Es=1.0d0
	REAL(kind=8)	::  dt=0.10d0/Nt
	REAL(kind=8) :: modescalereal
	COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE	::  kx,ky,kz
	REAL(kind=8),  	 DIMENSION(:), ALLOCATABLE	::  x,y,z
	COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE	::  unax,vnax,potx
	REAL(kind=8), 	 DIMENSION(:), ALLOCATABLE	::  time
	INTEGER(kind=4)	::  i,j,k,n,AllocateStatus,count,iol
		! timing
	INTEGER(kind=4)	::  start, finish, count_rate
  		! fftw variables
	INTEGER(kind=8), PARAMETER	::  FFTW_IN_PLACE = 8, FFTW_MEASURE = 0, &
		FFTW_EXHAUSTIVE = 8, FFTW_PATIENT = 32, FFTW_ESTIMATE = 64
	INTEGER(kind=8),PARAMETER	::  FFTW_FORWARD = -1, FFTW_BACKWARD=1
	INTEGER(kind=8)	::	planfxyz,planbxyz
	CHARACTER*100	::	name_config, number_file

	CALL system_clock(start,count_rate)
	ALLOCATE(unax(1:Nx,1:Ny,1:Nz),vnax(1:Nx,1:Ny,1:Nz),potx(1:Nx,1:Ny,1:Nz),&
   			kx(1:Nx),ky(1:Ny),kz(1:Nz),x(1:Nx),y(1:Ny),z(1:Nz),&
   			time(1:1+Nt/plotgap),stat=AllocateStatus)
	IF (AllocateStatus .ne. 0) STOP
	PRINT *,'allocated space'
	modescalereal=1.0d0/REAL(Nx,KIND(0d0))
	modescalereal=modescalereal/REAL(Ny,KIND(0d0))
	modescalereal=modescalereal/REAL(Nz,KIND(0d0))

	! set up ffts
	CALL dfftw_plan_dft_3d_(planfxyz,Nx,Ny,Nz,unax(1:Nx,1:Ny,1:Nz),&
		vnax(1:Nx,1:Ny,1:Nz),FFTW_FORWARD,FFTW_ESTIMATE)
 	CALL dfftw_plan_dft_3d_(planbxyz,Nx,Ny,Nz,vnax(1:Nx,1:Ny,1:Nz),&
 		unax(1:Nx,1:Ny,1:Nz),FFTW_BACKWARD,FFTW_ESTIMATE)

	PRINT *,'Setup FFTs'

	! setup fourier frequencies and grid points
	DO i=1,1+Nx/2
		kx(i)= cmplx(0.0d0,1.0)*REAL(i-1,kind(0d0))/Lx
	END DO
	kx(1+Nx/2)=0.0d0
	DO i = 1,Nx/2 -1
		kx(i+1+Nx/2)=-kx(1-i+Nx/2)
	END DO
  	DO i=1,Nx
		x(i)=(-1.0d0+2.0d0*REAL(i-1,kind(0d0))/REAL(Nx,kind(0d0)) )*pi*Lx
	END DO
	DO j=1,1+Ny/2
		ky(j)= cmplx(0.0d0,1.0d0)*REAL(j-1,kind(0d0))/Ly
	END DO
	ky(1+Ny/2)=0.0d0
	DO j = 1,Ny/2 -1
		ky(j+1+Ny/2)=-ky(1-j+Ny/2)
	END DO
  	DO j=1,Ny
		y(j)=(-1.0d0+2.0d0*REAL(j-1,kind(0d0))/REAL(Ny,kind(0d0)) )*pi*Ly
	END DO
	DO k=1,1+Nz/2
		kz(k)= cmplx(0.0d0,1.0d0)*REAL(k-1,kind(0d0))/Lz
	END DO
	kz(1+Nz/2)=0.0d0
	DO k = 1,Nz/2 -1
		kz(k+1+Nz/2)=-kz(1-k+Nz/2)
	END DO
  	DO k=1,Nz
		z(k)=(-1.0d0+2.0d0*REAL(k-1,kind(0d0))/REAL(Nz,kind(0d0)) )*pi*Lz
	END DO

	PRINT *,'Setup grid and fourier frequencies'

	DO k=1,Nz;	DO j=1,Ny; DO i=1,Nx
		unax(i,j,k)=exp(-1.0d0*(x(i)**2 +y(j)**2+z(k)**2))
	END DO; END DO; END DO

	name_config = 'uinitial.dat'
	INQUIRE(iolength=iol) unax(1,1,1)
	OPEN(unit=11,FILE=name_config,form="unformatted", &
	     access="direct",recl=iol)
	count=1
	DO k=1,Nz; DO j=1,Ny; DO i=1,Nx
		WRITE(11,rec=count) unax(i,j,k)
        count=count+1
	END DO; END DO; END DO
	CLOSE(11)

	CALL dfftw_execute_dft_(planfxyz,unax(1:Nx,1:Ny,1:Nz),vnax(1:Nx,1:Ny,1:Nz))

	PRINT *,'Got initial data, starting timestepping'
	time(1)=0
	DO n=1,Nt
		DO k=1,Nz; DO j=1,Ny; DO i=1,Nx
				vnax(i,j,k)=exp(0.50d0*dt*&
					(kz(k)*kz(k) + kx(i)*kx(i) + ky(j)*ky(j))&
					*cmplx(0.0d0,1.0d0))*vnax(i,j,k)
		END DO; END DO; END DO
		CALL dfftw_execute_dft_(planbxyz,vnax(1:Nx,1:Ny,1:Nz),&
			unax(1:Nx,1:Ny,1:Nz))

		DO k=1,Nz; DO j=1,Ny; DO i=1,Nx
			unax(i,j,k)=unax(i,j,k)*modescalereal
			potx(i,j,k)=Es*unax(i,j,k)*conjg(unax(i,j,k))
			unax(i,j,k)=exp(cmplx(0.0d0,-1.0d0)*dt*potx(i,j,k))&
					*unax(i,j,k)
		END DO; END DO; END DO
		CALL dfftw_execute_dft_(planfxyz,unax(1:Nx,1:Ny,1:Nz),&
			vnax(1:Nx,1:Ny,1:Nz))

		DO k=1,Nz; DO j=1,Ny; DO i=1,Nx
			vnax(i,j,k)=exp(0.5d0*dt*&
					(kx(i)*kx(i) + ky(j)*ky(j)+ kz(k)*kz(k))&
						*cmplx(0.0d0,1.0d0))*vnax(i,j,k)
		END DO; END DO; END DO
		IF (mod(n,plotgap)==0) THEN
			time(1+n/plotgap)=n*dt
			PRINT *,'time',n*dt
			CALL dfftw_execute_dft_(planbxyz,vnax(1:Nx,1:Ny,1:Nz),unax(1:Nx,1:Ny,1:Nz))
			DO k=1,Nz; DO j=1,Ny; DO i=1,Nx
				unax(i,j,k)=unax(i,j,k)*modescalereal
			END DO; END DO; END DO
			name_config='./data/u'
			WRITE(number_file,'(i0)') 10000000+1+n/plotgap
			ind=index(name_config,' ') -1
			name_config=name_config(1:ind)//numberfile
			ind=index(name_config,' ') -1
			name_config=name_config(1:ind)//'.dat'
			OPEN(unit=11,FILE=name_config,status="UNKNOWN")
			REWIND(11)
			DO j=1,Ny
				DO i=1,Nx
					WRITE(11,*) abs(unax(i,j))**2
				END DO
			END DO
			CLOSE(11)

		END IF
	END DO
	PRINT *,'Finished time stepping'

		! transform back final data and do another half time step
	CALL system_clock(finish,count_rate)
	PRINT*,'Program took ',REAL(finish-start)/REAL(count_rate),'for execution'

	name_config = 'tdata.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO j=1,1+Nt/plotgap
		WRITE(11,*) time(j)
	END DO
	CLOSE(11)

	name_config = 'xcoord.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO i=1,Nx
		WRITE(11,*) x(i)
	END DO
	CLOSE(11)

	name_config = 'ycoord.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO j=1,Ny
		WRITE(11,*) y(j)
	END DO
	CLOSE(11)

	name_config = 'zcoord.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO k=1,Nz
		WRITE(11,*) z(k)
	END DO
	CLOSE(11)
	PRINT *,'Saved data'

	CALL dfftw_destroy_plan_(planbxyz)
	CALL dfftw_destroy_plan_(planfxyz)
	CALL dfftw_cleanup_()

	DEALLOCATE(unax,vnax,potx,&
   			kx,ky,kz,x,y,z,&
   			time,stat=AllocateStatus)
	IF (AllocateStatus .ne. 0) STOP

	PRINT *,'Program execution complete'
	END PROGRAM main


      double precision function  DRANG ()
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-04-16 DRANG WVS SQRT(abs(TWO*log(U3))) avoids sqrt(-0.0)
c>> 1994-10-20 DRANG Krogh  Changes to use M77CON
c>> 1994-06-24 DRANG CLL Changed common to use RANC[D/S]1 & RANC[D/S]2.
c>> 1992-03-16 DRANG CLL
c>> 1991-11-26 DRANG CLL Reorganized common. Using RANCM[A/D/S].
c>> 1991-11-22 DRANG CLL Added call to RAN0, and DGFLAG in common.
c>> 1991-01-15 DRANG CLL Reordered common contents for efficiency.
C>> 1990-01-23 DRANG CLL Making names in common same in all subprogams.
C>> 1987-06-09 DRANG CLLawson  Initial code.
C
c     Returns one pseudorandom number from the Gausian (Normal)
c     distribution with zero mean and unit standard deviation.
c     Method taken from Algorithm 334, Comm. ACM, July 1968, p. 498.
c     Implemented at JPL in Univac Fortran V in 1969 by Wiley R. Bunton
c     of JPL and Stephen L. Richie of Heliodyne Corp.
c
c     Adapted to Fortran 77 for the MATH 77 library by C. L. Lawson and
c     S. Y. Chiu, JPL, April 1987, 6/9/87.
C     ------------------------------------------------------------------
c--D replaces "?": ?RANG, ?RANUA, RANC?1, RANC?2, ?PTR, ?NUMS, ?GFLAG
C     RANCD1 and RANCD2 are common blocks.
c     Uses intrinsic functions, log and sqrt.
C     Calls DRANUA to obtain an array of uniform random numbers.
c     Calls RAN0 to initialize DPTR and DGFLAG.
C     ------------------------------------------------------------------
c                        Important common variables
c
c     DPTR [integer] and DGFLAG [logical]
c
c          Will be set to DPTR = 1 and DGFLAG = .false.
c          when RAN0 is called from this subr if this
c          is the first call to RAN0.  Also set to these values when
c          RAN1 or RANPUT is called by a user.
c
c          DGFLAG will be set true on return from this subr when the
c          algorithm has values that it can save to reduce the amount
c          of computation needed the next time this function is
c          referenced.  Will be set false in the contrary case.
c
c          DPTR is the index of the last location used in the
c          common array DNUMS().  This index is counted down.
c
c     DNUMS() [floating point]  Buffer of previously computed uniform
c          random numbers.
C     ------------------------------------------------------------------
      integer M
      parameter(M = 97)
      double precision    ONE, TWO
      parameter(ONE = 1.0D0, TWO = 2.0D0)
      double precision    DNUMS(M), R, S, U3, X, XX, Y, YY
      logical FIRST
      common/RANCD2/DNUMS
      integer DPTR
      logical DGFLAG
      common/RANCD1/DPTR, DGFLAG
      save  /RANCD1/, /RANCD2/, FIRST
      save    R, X, Y
      data  FIRST/.true./
c     ------------------------------------------------------------------
      if(FIRST) then
         FIRST = .false.
         call RAN0
      endif
c
      if (.not. DGFLAG .or. DPTR .eq. 1) then
C
C     Use the Von Neuman rejection method for choosing a random point
c     (X,Y) in the unit circle, X**2 + Y**2 .le. 1.0.
c     Then the angle Theta = arctan(Y/X) is random, uniform in
c     (-Pi/2, Pi/2), and Phi = 2*Theta is random, uniform in (-Pi, Pi).
C     Define S = X**2 + Y**2, then
c     sin(Theta) = Y/sqrt(S),    cos(Theta) = X/sqrt(S),
c     sin(Phi) = 2*X*Y/S,    and cos(Phi) = (X**2 - Y**2)/S.
c
   10    continue
c                              Set X = random, uniform in [0., 1.]
      DPTR = DPTR - 1
      if(DPTR .eq. 0) then
         call DRANUA(DNUMS, M)
         DPTR = M
      endif
            X = DNUMS(DPTR)
c                              Set Y = random, uniform in [-1., 1.]
            DPTR = DPTR - 1
            if(DPTR .eq. 0) then
               call DRANUA(DNUMS,M)
               DPTR = M
            endif
            Y = TWO*DNUMS(DPTR) - ONE
c
            XX=X*X
            YY=Y*Y
            S=XX+YY
         if(S .gt. ONE) go to 10
C
C     Choose R randomly from Chi-squared distribution and
c     normalize with S.
C
c                              Set U3 = random, uniform in [0., 1.]
         DPTR = DPTR - 1
         if(DPTR .eq. 0) then
            call DRANUA(DNUMS,M)
            DPTR = M
         endif
         U3 = DNUMS(DPTR)
c        Changed -TWO*log(U3) to abs(TWO*log(U3)) because Lahey LF90
c        2.00 on a pentium produced -0.0 for -TWO*log(1.0), then got a
c        floating point exception on sqrt(-0.0).
         R = sqrt(abs(TWO*(log(U3))))/S
C
C                                Compute result as  R*Sin(PHI)
C
         DRANG = (XX-YY)*R
         DGFLAG = .true.
         return
      endif
C     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c        Come here when DGFLAG is true and DPTR is not 1.
c
C                                Compute result as  R*Cos(PHI)
      DRANG = TWO*X*Y*R
      DGFLAG=.false.
      return
      end


	SUBROUTINE GR_CVAL  ( rmin, rmax, rint, iret )
C************************************************************************
C* GR_CVAL								*
C*									*
C* This subroutine selects a contour interval, given minimum and 	*
C* maximum data values.  The selected interval will generate		*
C* five to ten contour levels.						*
C*									*
C* GR_CVAL  ( RMIN, RMAX, RINT, IRET )					*
C*									*
C* Input parameters:							*
C*	RMIN		REAL		Minimum data value		*
C*	RMAX		REAL		Maximum data value		*
C*									*
C* Output parameters:							*
C*	RINT		REAL		Contour interval		*
C*	IRET		INTEGER		Return code			*
C*					   0 = normal return		*
C*					  -8 = invalid data range	*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 2/85						*
C* M. desJardins/GSFC	 9/88	GEMPAK4					*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
C
C*	Check for errors in input.
C
	IF  ( ( ERMISS ( rmin ) ) .or. ( ERMISS ( rmax ) ) .or.
     +	      ( rmin .gt. rmax ) )  THEN
	    iret = -8
	    RETURN
	END IF
C
C*	RANGE is the range of the data.
C*	CSCAL will scale range between 1. and 10.
C*	CNRNG is the normalized (scaled) range.
C
	range = rmax - rmin
	IF  ( range .eq. 0. )  THEN
	    rint = 0.
	    RETURN
	END IF
C*
	iscal = INT ( ALOG10 (range) )
	IF  ( range .lt. 1. )  iscal = iscal - 1
	cscal = 10. ** iscal
	cnrng = range / cscal
C
C*	Compute CINT as follows:
C*	    If normalized range between 1. and 2., normalized CINT = .2
C*	    "       "     "       "     2. and 3.,  "          "   " .3
C*		etc.
C
	nrng  = INT ( cnrng )
	rint  = ( nrng+1 ) * .1 * cscal
C*
	RETURN
	END


!! red-black SOR
!!

!! Ax=b
subroutine sor2_core_1d(nxyz, ng, x, b, A, color, omg, err)
implicit none
    integer, dimension(3) :: nxyz
    integer :: ng, color, i, ix
    real    :: omg, err, ndag_e, ndag_w, ss, dd, dx
    real, dimension(    1-ng:nxyz(1)+ng ) :: x, b
    real, dimension( 3, 1-ng:nxyz(1)+ng ) :: A

    err = 0.0
    ix = nxyz(1)
    do i=1+mod(color,2), ix, 2
        ndag_e = A(1, i)
        ndag_w = A(2, i)
            dd = A(3, i)
        ss = ndag_e * x(i+1)  &
           + ndag_w * x(i-1)
        dx = ( (b(i) - ss)/dd - x(i) ) * omg
        x(i) = x(i) + dx
        err = err + dx*dx
    end do
end subroutine sor2_core_1d

!! Ax=b
subroutine sor2_core_2d(nxyz, ng, x, b, A, color, omg, err)
implicit none
    integer, dimension(3) :: nxyz
    integer :: ng, color, i, j, ix, jy
    real    :: omg, err, ndag_e, ndag_w, ndag_n, ndag_s, ss, dd, dx
    real, dimension(    1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng ) :: x, b
    real, dimension( 5, 1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng ) :: A

    ix = nxyz(1)
    jy = nxyz(2)

    do j=1, jy
    do i=1+mod(j+color,2), ix, 2
        ndag_e = A(1, i, j)
        ndag_w = A(2, i, j)
        ndag_n = A(3, i, j)
        ndag_s = A(4, i, j)
            dd = A(5, i, j)
            ss = ndag_e*x(i+1, j  ) &
               + ndag_w*x(i-1, j  ) &
               + ndag_n*x(i,   j+1) &
               + ndag_s*x(i,   j-1)
        dx = ( (b(i,j) - ss)/dd - x(i,j) ) * omg
        x(i,j) = x(i,j) + dx
        err = err + dx*dx
    end do
    end do
end subroutine sor2_core_2d

!! Ax=b
subroutine sor2_core_3d(nxyz, ng, x, b, A, color, omg, err)
implicit none
    integer, dimension(3) :: nxyz
    integer ::  ng, color, i, j, ix, jy, k, kz
    real    ::  omg, err, ndag_e, ndag_w, ndag_n, ndag_s, ndag_t, ndag_b, ss, dd, dx
    real, dimension(    1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng, 1-ng:nxyz(3)+ng ) :: x, b
    real, dimension( 7, 1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng, 1-ng:nxyz(3)+ng ) :: A

    ix = nxyz(1)
    jy = nxyz(2)
    kz = nxyz(3)
!$OMP PARALLEL &
!$OMP PRIVATE(ndag_e, ndag_w, ndag_n, ndag_s, ndag_t, ndag_b, dd, ss, dx) &
!$OMP FIRSTPRIVATE(ix, jy, kz)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
    do k=1, kz
    do j=1, jy
    do i=1+mod(j+color,2), ix, 2
        ndag_e = A(1, i, j, k)
        ndag_w = A(2, i, j, k)
        ndag_n = A(3, i, j, k)
        ndag_s = A(4, i, j, k)
        ndag_t = A(5, i, j, k)
        ndag_b = A(6, i, j, k)
            dd = A(7, i, j, k) !! diagonal
            ss = ndag_e*x(i+1, j,   k  ) &
               + ndag_w*x(i-1, j,   k  ) &
               + ndag_n*x(i,   j+1, k  ) &
               + ndag_s*x(i,   j-1, k  ) &
               + ndag_t*x(i,   j,   k+1) &
               + ndag_b*x(i,   j,   k-1)

        dx = ( (b(i,j,k) - ss)/dd - x(i,j,k) ) * omg
        x(i,j,k) = x(i,j,k) + dx
        err = err + dx*dx
    end do
    end do
    end do
!$OMP END DO
!$OMP END PARALLEL

end subroutine sor2_core_3d


PROGRAM Test_Sinc
  USE Type_Kinds           , ONLY: fp=>fp_kind
  USE File_Utility         , ONLY: Get_Lun
  USE Fundamental_Constants, ONLY: PI
  USE FFT_Spectral_Utility , ONLY: Sinc
  IMPLICIT NONE

  INTEGER,  PARAMETER :: N = 10001
  REAL(fp), PARAMETER :: TEN = 10.0_fp
  REAL(fp), PARAMETER :: XBEGIN = -TEN*PI
  REAL(fp), PARAMETER :: XEND   =  TEN*PI

  INTEGER :: i, fileId
  REAL(fp), DIMENSION(N) :: x, y, yNorm

  ! Create x array
  x = (/ (i,i=0,N-1) /) / REAL(N-1,fp)
  x = x*(XEND-XBEGIN) + XBEGIN

  ! Call the function
  y     = Sinc(x)
  yNorm = Sinc(x,Normalized=1)

  ! Output an ASCII file for viewing results
  fileId=Get_Lun()
  OPEN(fileId,FILE='Test_Sinc.dat',STATUS='UNKNOWN')
  WRITE(fileId,*) N
  DO i=1, N
    WRITE(fileId,*) x(i), y(i), yNorm(i)
  END DO
  CLOSE(fileId)

END PROGRAM Test_Sinc


program PolyDivTest
  use Polynom
  implicit none

  real, dimension(:), allocatable :: q
  real, dimension(:), allocatable :: r

  !! three tests from Wikipedia, plus an extra
  !call poly_long_div( (/ -3., 1. /), (/ -42., 0.0, -12., 1. /), q, r)
  call poly_long_div( (/ -42., 0.0, -12., 1. /), (/ -3., 1. /), q, r)
  !call poly_long_div( (/ -42., 0.0, -12., 1. /), (/ -3., 1., 1. /), q, r)
  !call poly_long_div( (/ 2., 3., 1. /), (/ 1., 1. /), q, r)

  call poly_print(q)
  call poly_print(r)
  deallocate(q, r)

end program PolyDivTest


program rayleigh_ppal !inicio del programa rayleigh_ppal

  use datasissim_interface
  use rayleigh_interface
  use residuo_interface

  implicit none

  real, dimension(:,:), allocatable :: a
  real, dimension(:), allocatable :: u, r

  integer :: n, nmaxit, ier
  real :: xlam, eps

  print*
  print*, 'Introduce o orde da matriz: '
  read*, n
  print*

  print*
  print*, 'O orde introduce e: ', n
  print*

  allocate(a(n,n), u(n), r(n))

  call datasissim(a)

  print*
  print*, 'Introduce o numero maximo de iteracions: '
  read*, nmaxit
  print*

  print*
  print*, 'O numero maximo de iteracions e: ', nmaxit
  print*

  print*
  print*, 'Introduce o epsilon para o test de parada: '
  read*, eps
  print*

  print*
  print*, 'O epsilon introducido e: ', eps
  print*

  call rayleigh(a, u, xlam, eps, nmaxit, ier)

  print*, 'Un vector propio e: ', u

  print*, 'O autovalor dominante e ', xlam

  call residuo(a, u, xlam, r)

end program


PROGRAM mclpn

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:10

!       ==========================================================
!       Purpose: This program computes the Legendre polynomials
!                Pn(z) and Pn'(z) for a complex argument using
!                subroutine CLPN
!       Input :  x --- Real part of z
!                y --- Imaginary part of z
!                n --- Degree of Pn(z), n = 0,1,...,N
!       Output:  CPN(n) --- Pn(z)
!                CPD(n) --- Pn'(z)
!       Example: z = 3.0 +2.0 i

!       n    Re[Pn(z)]     Im[Pn(z)]     Re[Pn'(z)]   Im[Pn'(z)]
!      -----------------------------------------------------------
!       0   .100000D+01   .000000D+00   .000000D+00   .000000D+00
!       1   .300000D+01   .200000D+01   .100000D+01   .000000D+00
!       2   .700000D+01   .180000D+02   .900000D+01   .600000D+01
!       3  -.270000D+02   .112000D+03   .360000D+02   .900000D+02
!       4  -.539000D+03   .480000D+03  -.180000D+03   .790000D+03
!       5  -.461700D+04   .562000D+03  -.481500D+04   .441000D+04
!       ==========================================================

IMPLICIT DOUBLE PRECISION (x,y)
IMPLICIT COMPLEX *16 (c,z)
DIMENSION cpn(0:100),cpd(0:100)
WRITE(*,*)'  Please enter Nmax, x and y (z=x+iy)'
!        READ(*,*)N,X,Y
n=5
x=3.0
y=2.0
WRITE(*,30)x,y
WRITE(*,*)
CALL clpn(n,x,y,cpn,cpd)
WRITE(*,*)'  n    Re[Pn(z)]     Im[Pn(z)]     Re[Pn''(Z)]', '   Im[Pn''(Z)]'
WRITE(*,*)' ---------------------------------------------', '--------------'
DO  k=0,n
  WRITE(*,20)k,cpn(k),cpd(k)
END DO
20      FORMAT(1X,i3,4D14.6)
30      FORMAT(3X,'x =',f5.1,',  ','y =',f5.1)
END PROGRAM mclpn

SUBROUTINE clpn(n,x,y,cpn,cpd)

!       ==================================================
!       Purpose: Compute Legendre polynomials Pn(z) and
!                their derivatives Pn'(z) for a complex
!                argument
!       Input :  x --- Real part of z
!                y --- Imaginary part of z
!                n --- Degree of Pn(z), n = 0,1,2,...
!       Output:  CPN(n) --- Pn(z)
!                CPD(n) --- Pn'(z)
!       ==================================================

INTEGER, INTENT(IN)                      :: n
DOUBLE PRECISION, INTENT(IN)             :: x
DOUBLE PRECISION, INTENT(IN OUT)         :: y
COMPLEX, INTENT(OUT)                     :: cpn(0:n)
COMPLEX, INTENT(OUT)                     :: cpd(0:n)
IMPLICIT DOUBLE PRECISION (x,y)
IMPLICIT COMPLEX *16 (c,z)

z=CMPLX(x,y)
cpn(0)=(1.0D0,0.0D0)
cpn(1)=z
cpd(0)=(0.0D0,0.0D0)
cpd(1)=(1.0D0,0.0D0)
cp0=(1.0D0,0.0D0)
cp1=z
DO  k=2,n
  cpf=(2.0D0*k-1.0D0)/k*z*cp1-(k-1.0D0)/k*cp0
  cpn(k)=cpf
  IF (DABS(x) == 1.0D0.AND.y == 0.0D0) THEN
    cpd(k)=0.5D0*x**(k)*k*(k+1.0D0)
  ELSE
    cpd(k)=k*(cp1-z*cpf)/(1.0D0-z*z)
  END IF
  cp0=cp1
  cp1=cpf
END DO
RETURN
END SUBROUTINE clpn