!********************************************************************************
!>
!   simulated annealing is a global optimization method that distinguishes
!   between different local optima.  starting from an initial point, the
!   algorithm takes a step and the function is evaluated. when minimizing a
!   function, any downhill step is accepted and the process repeats from this
!   new point. an uphill step may be accepted. thus, it can escape from local
!   optima. this uphill decision is made by the metropolis criteria. as the
!   optimization process proceeds, the length of the steps decline and the
!   algorithm closes in on the global optimum. since the algorithm makes very
!   few assumptions regarding the function to be optimized, it is quite
!   robust with respect to non-quadratic surfaces. the degree of robustness
!   can be adjusted by the user. in fact, simulated annealing can be used as
!   a local optimizer for difficult functions.
!
!### Reference
!
!  * corana et al., "minimizing multimodal functions of continuous variables
!    with the "simulated annealing" algorithm", september 1987
!    (vol. 13, no. 3, pp. 262-280),
!    acm transactions on mathematical software.
!  * goffe, ferrier and rogers, "global optimization of statistical functions
!    with simulated annealing", journal of econometrics, vol. 60, no. 1/2,
!    jan./feb. 1994, pp. 65-100.
!
!### History
!
!  * based on reference by bill goffe : 1/22/94, version: 3.2
!    See: https://www.netlib.org/opt/simann.f
!  * modifications by alan miller : fortran 90 version - 2 october 2013
!  * Jacob Williams, 8/26/2019 : modernized Fortran
!
!### TODO
!  * input rand distributation option
!  * a way to specify that some variables are not to be changed... this could be part of the distributation
!    selection (a constant option). each variable can have a different distribution.
!  * get ideas from: https://docs.scipy.org/doc/scipy/reference/generated/scipy.optimize.basinhopping.html

    module simulated_annealing_module

    use iso_fortran_env, only: dp => real64, output_unit

    implicit none

    private

    !*******************************************************
    type,public :: simulated_annealing_type

        private

        integer :: n = 0              !! number of variables in the function to be optimized.
        logical :: maximize = .false. !! denotes whether the function should be maximized or minimized.
                                      !! a true value denotes maximization while a false value denotes
                                      !! minimization.  intermediate output (see iprint) takes this into
                                      !! account.
        real(dp) :: eps = 1.0e-9_dp   !! error tolerance for termination. if the final function
                                      !! values from the last neps temperatures differ from the
                                      !! corresponding value at the current temperature by less than
                                      !! eps and the final function value at the current temperature
                                      !! differs from the current optimal function value by less than
                                      !! eps, execution terminates and ier = 0 is returned.
        integer  :: ns = 20           !! number of cycles.  after ns function evaluations, each element of
                                      !! vm is adjusted according to the input `step_mode`
                                      !! the suggested value is 20.
        integer  :: nt = 100          !! number of iterations before temperature reduction. after
                                      !! nt*ns function evaluations, temperature (t) is changed
                                      !! by the factor rt.  value suggested by corana et al. is
                                      !! max(100, 5*n).  see goffe et al. for further advice.
        integer  :: neps = 4          !! number of final function values used to decide upon
                                      !! termination.  see eps.  suggested value is 4.
        integer  :: maxevl = 10000    !! the maximum number of function evaluations.  if it is
                                      !! exceeded, ier = 1.

        logical :: use_initial_guess = .true. !! if false, the initial guess is ignored and a
                                              !! random point in the bounds is used for the first
                                              !! function evaluation

        integer :: n_resets = 2 !! number of times to run the main loop (must be >=1)

        real(dp), dimension(:),allocatable :: lb        !! the lower bound for the allowable solution variables.
        real(dp), dimension(:),allocatable :: ub        !! the upper bound for the allowable solution variables.
                                                        !! if the algorithm chooses x(i) < lb(i) or x(i) > ub(i),
                                                        !! i = 1, n, a point is from inside is randomly selected. this
                                                        !! this focuses the algorithm on the region inside ub and lb.
                                                        !! unless the user wishes to concentrate the search to a particular
                                                        !! region, ub and lb should be set to very large positive
                                                        !! and negative values, respectively.  note that the starting
                                                        !! vector x should be inside this region.  also note that lb and
                                                        !! ub are fixed in position, while vm is centered on the last
                                                        !! accepted trial set of variables that optimizes the function.
        real(dp), dimension(:),allocatable :: c         !! vector that controls the step length adjustment.  the suggested
                                                        !! value for all elements is 2.0.
        integer :: iprint = 1           !! controls printing inside [[sa]]:
                                        !!
                                        !!  * 0 - nothing printed.
                                        !!  * 1 - function value for the starting value and
                                        !!    summary results before each temperature
                                        !!    reduction. this includes the optimal
                                        !!    function value found so far, the total
                                        !!    number of moves (broken up into uphill,
                                        !!    downhill, accepted and rejected), the
                                        !!    number of out of bounds trials, the
                                        !!    number of new optima found at this
                                        !!    temperature, the current optimal x and
                                        !!    the step length vm. note that there are
                                        !!    n*ns*nt function evalutations before each
                                        !!    temperature reduction. finally, notice is
                                        !!    is also given upon achieveing the termination
                                        !!    criteria.
                                        !!  * 2 - each new step length (vm), the current optimal
                                        !!    x (xopt) and the current trial x (x). this
                                        !!    gives the user some idea about how far x
                                        !!    strays from xopt as well as how vm is adapting
                                        !!    to the function.
                                        !!  * 3 - each function evaluation, its acceptance or
                                        !!    rejection and new optima. for many problems,
                                        !!    this option will likely require a small tree
                                        !!    if hard copy is used. this option is best
                                        !!    used to learn about the algorithm. a small
                                        !!    value for maxevl is thus recommended when
                                        !!    using iprint = 3.
                                        !!
                                        !! suggested value: 1
                                        !! note: for a given value of iprint, the lower valued
                                        !! options (other than 0) are utilized.
        integer :: iseed1 = 1234    !! the first seed for the random number generator.
        integer :: iseed2 = 5678    !! the second seed for the random number generator.
                                    !! different values for iseed1 and iseed2 will lead
                                    !! to an entirely different sequence of trial points
                                    !! and decisions on downhill moves (when maximizing).
                                    !! see goffe et al. on how this can be used to test
                                    !! the results of [[sa]].
        integer   :: step_mode = 1  !! how to vary `vm` after `ns` cycles.
                                    !!
                                    !! * 1 : original method: adjust vm so that approximately
                                    !!   half of all evaluations are accepted
                                    !! * 2 : keep vm constant
                                    !! * 3 : adjust by a constant `vms` factor
        real(dp)  :: vms = 0.1_dp         !! for `step_mode=3`, the factor to adjust `vm`
        integer   :: iunit = output_unit  !! unit number for prints.

        procedure(sa_func),pointer :: fcn => null()  !! the user's function

    contains

        private

        procedure,public :: initialize => initialize_sa
        procedure,public :: optimize   => sa
        procedure,public :: destroy    => destroy_sa

        procedure :: func
        procedure :: perturb_and_evaluate

    end type simulated_annealing_type
    !*******************************************************

    !*******************************************************
    abstract interface
        subroutine sa_func(me, x, f, istat)
            !! interface to function to be maximized/minimized
            import :: dp, simulated_annealing_type
            implicit none
            class(simulated_annealing_type),intent(inout) :: me
            real(dp),dimension(:),intent(in) :: x
            real(dp), intent(out)            :: f
            integer, intent(out)             :: istat !! status flag:
                                                      !!
                                                      !! * 0 : valid function evaluation
                                                      !! * -1 : invalid function evaluation.
                                                      !!   try a different input vector.
                                                      !! * -2 : stop the optimization process

        end subroutine sa_func
    end interface
    !*******************************************************

    public :: print_vector
    public :: dp

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

!********************************************************************************
!>
!  Destructor.

    subroutine destroy_sa(me)

    implicit none

    class(simulated_annealing_type),intent(out) :: me

    end subroutine destroy_sa
!********************************************************************************

!********************************************************************************
!>
!  Initialize the class.
!
!  See the definition of [[simulated_annealing_type]] for the options.
!  Any options not set here will use the default values in the type.

    subroutine initialize_sa(me,fcn,n,lb,ub,c,&
                             maximize,eps,ns,nt,neps,maxevl,&
                             iprint,iseed1,iseed2,step_mode,vms,iunit,&
                             use_initial_guess,n_resets)

    implicit none

    class(simulated_annealing_type),intent(inout) :: me
    procedure(sa_func)                            :: fcn
    integer, intent(in)                           :: n
    real(dp), dimension(n), intent(in)            :: lb
    real(dp), dimension(n), intent(in)            :: ub
    real(dp), dimension(n), intent(in),optional   :: c
    logical, intent(in),optional                  :: maximize
    real(dp), intent(in),optional                 :: eps
    integer, intent(in),optional                  :: ns
    integer, intent(in),optional                  :: nt
    integer, intent(in),optional                  :: neps
    integer, intent(in),optional                  :: maxevl
    integer, intent(in),optional                  :: iprint
    integer, intent(in),optional                  :: iseed1
    integer, intent(in),optional                  :: iseed2
    integer,intent(in),optional                   :: step_mode
    real(dp), intent(in), optional                :: vms
    integer, intent(in), optional                 :: iunit
    logical, intent(in), optional                 :: use_initial_guess
    integer, intent(in), optional                 :: n_resets

    call me%destroy()

    me%fcn => fcn
    me%n  = n
    me%lb = lb
    me%ub = ub

    ! check validity of bounds:
    if (any(me%lb > me%ub)) then
        error stop 'Error: at least one LB > UB.'
    end if

    allocate(me%c(n))
    if (present(c)) then
        me%c = c
    else
        me%c = 2.0_dp
    end if

    if (present(maximize)          ) me%maximize = maximize
    if (present(eps)               ) me%eps = eps
    if (present(ns)                ) me%ns = ns
    if (present(nt)                ) me%nt = nt
    if (present(neps)              ) me%neps = neps
    if (present(maxevl)            ) me%maxevl = maxevl
    if (present(iprint)            ) me%iprint = iprint
    if (present(iseed1)            ) me%iseed1 = iseed1
    if (present(iseed2)            ) me%iseed2 = iseed2
    if (present(step_mode)         ) me%step_mode = step_mode
    if (present(vms)               ) me%vms = vms
    if (present(iunit)             ) me%iunit = iunit
    if (present(use_initial_guess) ) me%use_initial_guess = use_initial_guess
    if (present(n_resets)          ) me%n_resets = n_resets

    end subroutine initialize_sa
!********************************************************************************

!********************************************************************************
!>
!  Continuous simulated annealing global optimization algorithm
!
!### Brief Overview
!
!  sa tries to find the global optimum of an n dimensional function.
!  it moves both up and downhill and as the optimization process
!  proceeds, it focuses on the most promising area.
!
!  to start, it randomly chooses a trial point within the step length
!  vm (a vector of length n) of the user selected starting point. the
!  function is evaluated at this trial point and its value is compared
!  to its value at the initial point.
!
!  in a maximization problem, all uphill moves are accepted and the
!  algorithm continues from that trial point. downhill moves may be
!  accepted; the decision is made by the metropolis criteria. it uses t
!  (temperature) and the size of the downhill move in a probabilistic
!  manner. the smaller t and the size of the downhill move are, the more
!  likely that move will be accepted. if the trial is accepted, the
!  algorithm moves on from that point. if it is rejected, another point
!  is chosen instead for a trial evaluation.
!
!  each element of vm periodically adjusted so that half of all
!  function evaluations in that direction are accepted.
!
!  a fall in t is imposed upon the system with the rt variable by
!  t(i+1) = rt*t(i) where i is the ith iteration. thus, as t declines,
!  downhill moves are less likely to be accepted and the percentage of
!  rejections rise. given the scheme for the selection for vm, vm falls.
!  thus, as t declines, vm falls and sa focuses upon the most promising
!  area for optimization.
!
!  the parameter t is crucial in using sa successfully. it influences
!  vm, the step length over which the algorithm searches for optima. for
!  a small initial t, the step length may be too small; thus not enough
!  of the function might be evaluated to find the global optima. the user
!  should carefully examine vm in the intermediate output (set iprint =
!  1) to make sure that vm is appropriate. the relationship between the
!  initial temperature and the resulting step length is function
!  dependent.
!
!  to determine the starting temperature that is consistent with
!  optimizing a function, it is worthwhile to run a trial run first. set
!  rt = 1.5 and t = 1.0. with rt > 1.0, the temperature increases and vm
!  rises as well. then select the t that produces a large enough vm.
!
!### Notes
!  * as far as possible, the parameters here have the same name as in
!    the description of the algorithm on pp. 266-8 of corana et al.
!  * the suggested input values generally come from corana et al. to
!    drastically reduce runtime, see goffe et al., pp. 90-1 for
!    suggestions on choosing the appropriate rt and nt.
!
!### History
!  * differences compared to version 2.0:
!     1. if a trial is out of bounds, a point is randomly selected
!        from lb(i) to ub(i). unlike in version 2.0, this trial is
!        evaluated and is counted in acceptances and rejections.
!        all corresponding documentation was changed as well.
!  * differences compared to version 3.0:
!     1. if vm(i) > (ub(i) - lb(i)), vm is set to ub(i) - lb(i).
!        the idea is that if t is high relative to lb & ub, most
!        points will be accepted, causing vm to rise. but, in this
!        situation, vm has little meaning; particularly if vm is
!        larger than the acceptable region. setting vm to this size
!        still allows all parts of the allowable region to be selected.
!  * differences compared to version 3.1:
!     1. test made to see if the initial temperature is positive.
!     2. write statements prettied up.
!     3. references to paper updated.

    subroutine sa(me, x, rt, t, vm, xopt, fopt, nacc, nfcnev, ier)

    implicit none

    class(simulated_annealing_type),intent(inout) :: me
    real(dp), dimension(me%n), intent(inout)  :: x       !! on input: the starting values for the variables of the
                                                         !! function to be optimized. [Will be replaced by final point]
    real(dp), intent(in)                      :: rt      !! the temperature reduction factor.  the value suggested by
                                                         !! corana et al. is .85. see goffe et al. for more advice.
    real(dp), intent(inout)                   :: t       !! on input, the initial temperature. see goffe et al. for advice.
                                                         !! on output, the final temperature. Note that if `t=0`, then
                                                         !! all downhill steps will be rejected
    real(dp), dimension(me%n), intent(inout)  :: vm      !! the step length vector. on input it should encompass the region of
                                                         !! interest given the starting value x.  for point x(i), the next
                                                         !! trial point is selected is from x(i) - vm(i)  to  x(i) + vm(i).
                                                         !! since vm is adjusted so that about half of all points are accepted,
                                                         !! the input value is not very important (i.e. is the value is off,
                                                         !! sa adjusts vm to the correct value).
    real(dp), dimension(me%n), intent(out)  :: xopt      !! the variables that optimize the function.
    real(dp), intent(out)                   :: fopt      !! the optimal value of the function.
    integer, intent(out)                    :: nacc      !! the number of accepted function evaluations.
    integer, intent(out)                    :: nfcnev    !! the total number of function evaluations. in a minor
                                                         !! point, note that the first evaluation is not used in the
                                                         !! core of the algorithm; it simply initializes the
                                                         !! algorithm.
    integer, intent(out)                    :: ier       !! the error return number:
                                                         !!
                                                         !!  * 0 - normal return; termination criteria achieved.
                                                         !!  * 1 - number of function evaluations (nfcnev) is
                                                         !!    greater than the maximum number (maxevl).
                                                         !!  * 3 - the initial temperature is not positive.
                                                         !!  * 4 - user stop in problem function.
                                                         !!  * 99 - should not be seen; only used internally.

    real(dp),dimension(me%n)    :: xp            !! perturbed `x` vector
    real(dp),dimension(me%neps) :: fstar         !! array of optimals found so far
    real(dp)                    :: f             !! function value
    real(dp)                    :: fp            !! function value
    real(dp)                    :: p             !! for metropolis criteria
    real(dp)                    :: pp            !! for metropolis criteria
    real(dp)                    :: ratio         !! ratio of `nacp` to `ns`
    integer                     :: nup           !! number of uphill steps
    integer                     :: ndown         !! number of accepted downhill steps
    integer                     :: nrej          !! number of rejected downhill steps
    integer                     :: nnew          !! new optimal for this temperature
    integer                     :: i, j, m, k    !! counter
    integer                     :: totmov        !! total moves
    integer                     :: nacp          !! number of accepts steps in a complete `ns` cycle
    logical                     :: quit          !! if the termination criteria was achieved
    integer                     :: unit          !! unit for printing
    real(dp)                    :: t_original    !! original input value of `t`
    real(dp),dimension(me%n)    :: vm_original   !! original input value of `vm`
    logical                     :: first

    ! initialize:
    unit        = me%iunit
    nfcnev      = 0
    ier         = 99
    xopt        = x
    fopt        = huge(1.0_dp)
    vm          = abs(vm)
    t_original  = t
    vm_original = vm

    ! if the initial temperature is not positive, notify the user and
    ! return to the calling routine.
    if (t < 0.0_dp) then
        if (me%iprint>0) write(unit,'(A)') 'Error: The initial temperature must be non-negative.'
        ier = 3
        return
    end if

    ! if the initial value is out of bounds, then just put
    ! the violated ones on the nearest bound.
    where (x > me%ub)
        x = me%ub
    else where (x < me%lb)
        x = me%lb
    end where

    !  initialize the random number generator
    call rand_init(me%iseed1,me%iseed2)

    ! evaluate the function with input x and return value as f.
    ! keep trying if necessary until there is a valid function
    ! evaluation.
    call me%perturb_and_evaluate(x,vm,xp,f,nfcnev,ier,first=.true.)
    select case (ier)
    case(1,4)
        return
    end select

    f = me%func(f)
    xopt = xp ! it may have been perturbed above
    fopt = f
    if (me%iprint >= 1) then
        write(unit, '(A)') '  '
        call print_vector(unit,xp,me%n,'initial x')
        write(unit, '(A,1X,G25.18)')  '  initial f: ', me%func(f)
    end if

    reset: do k = 1, me%n_resets

        if (me%iprint >= 1) then
            write(unit,'(A)')       ''
            write(unit,'(A)')       '=========================================='
            write(unit,'(A,1X,I5)') ' main loop ', k
            write(unit,'(A)')       '=========================================='
            write(unit,'(A)')       ''
        end if

        ! restart the main loop
        fstar = huge(1.0_dp)
        t     = t_original
        vm    = vm_original
        nacc  = 0
        nacp  = 0

        ! the first function eval for a new main cycle
        first = k > 1

        main : do
            !  start the main loop. note that it terminates if (i) the algorithm
            !  succesfully optimizes the function or (ii) there are too many
            !  function evaluations (more than maxevl).
            nup = 0
            nrej = 0
            nnew = 0
            ndown = 0

            nt_loop : do m = 1, me%nt
                ns_loop : do j = 1, me%ns

                    !  evaluate the function with the trial point xp and return as fp.
                    call me%perturb_and_evaluate(x,vm,xp,fp,nfcnev,ier,first=first)
                    first = .false.
                    select case (ier)
                    case(1,4)
                        x    = xopt
                        fopt = me%func(fopt)
                        return
                    end select

                    fp = me%func(fp)
                    if (me%iprint >= 3) then
                        write(unit,'(A)') ' '
                        call print_vector(unit,x,me%n,'current x')
                        write(unit,'(A,G25.18)') ' current f: ', me%func(f)
                        call print_vector(unit,xp,me%n,'trial x')
                        write(unit,'(A,G25.18)') ' resulting f: ', me%func(fp)
                    end if

                    if (fp >= f) then
                        ! function value increased: accept the new point

                        if (me%iprint >= 3) write(unit,'(A)') '  point accepted'
                        x = xp
                        f = fp
                        nacc = nacc + 1
                        nacp = nacp + 1
                        nup = nup + 1

                        !  if greater than any other point, record as new optimum.
                        if (fp > fopt) then
                            if (me%iprint >= 3) write(unit,'(A)') '  new optimum'
                            xopt = xp
                            fopt = fp
                            nnew = nnew + 1
                        end if

                    else
                        ! if the point is lower, use the metropolis criteria to decide on
                        ! acceptance or rejection.
                        ! NOTE: if t=0, all downhill steps are rejected (monotonic)

                        if (t/=0.0_dp) then
                            p = exprep((fp - f)/t)
                            pp = uniform_random_number()
                            if (pp < p) then
                                if (me%iprint >= 3) then
                                    if (me%maximize) then
                                        write(unit,'(A)')  '  though lower, point accepted'
                                    else
                                        write(unit,'(A)')  '  though higher, point accepted'
                                    end if
                                end if
                                x = xp
                                f = fp
                                nacc = nacc + 1
                                nacp = nacp + 1
                                ndown = ndown + 1
                                cycle  ! accepted
                            end if
                        end if

                        ! rejected:
                        nrej = nrej + 1
                        if (me%iprint >= 3) then
                            if (me%maximize) then
                                write(unit,'(A)') '  lower point rejected'
                            else
                                write(unit,'(A)') '  higher point rejected'
                            end if
                        end if

                    end if

                end do ns_loop ! j - ns loop

                select case (me%step_mode)
                case(1)
                    ! adjust vm so that approximately half of all evaluations are accepted.
                    ratio = real(nacp,dp) /real(me%ns,dp)
                    do i = 1, me%n
                        if (ratio > 0.6_dp) then
                            vm(i) = vm(i)*(1.0_dp + me%c(i)*(ratio - 0.6_dp)/0.4_dp)
                        else if (ratio < 0.4_dp) then
                            vm(i) = vm(i)/(1.0_dp + me%c(i)*((0.4_dp - ratio)/0.4_dp))
                        end if
                        if (vm(i) > (me%ub(i)-me%lb(i))) then
                            vm(i) = me%ub(i) - me%lb(i)
                        end if
                    end do
                    if (me%iprint >= 2) then
                        write(unit,'(/A)') '---------------------------------------------------'
                        write(unit,'(A)')  ' intermediate results after step length adjustment '
                        write(unit,'(A/)') '---------------------------------------------------'
                        call print_vector(unit, vm,   me%n, 'new step length (vm)')
                        call print_vector(unit, xopt, me%n, 'current optimal x')
                        call print_vector(unit, x,    me%n, 'current x')
                        write(unit,'(A)') ' '
                    end if
                case (2)
                    ! keep vm as is
                case (3)
                    ! use the constant factor:
                    vm = abs(me%vms) * vm
                case default
                    error stop ' invalid value of step_mode'
                end select

                nacp = 0

            end do nt_loop ! m - nt loop

            if (me%iprint >= 1) then
                totmov = nup + ndown + nrej
                write(unit,'(/A)')      '--------------------------------------------------------'
                write(unit,'(A)')       ' intermediate results before next temperature reduction '
                write(unit,'(A/)')      '--------------------------------------------------------'
                write(unit,'(A,G12.5)') '  current temperature:            ', t
                if (me%maximize) then
                    write(unit,'(A,G25.18)') '  max function value so far:  ', fopt
                    write(unit,'(A,I8)')     '  total moves:                ', totmov
                    write(unit,'(A,I8)')     '     uphill:                  ', nup
                    write(unit,'(A,I8)')     '     accepted downhill:       ', ndown
                    write(unit,'(A,I8)')     '     rejected downhill:       ', nrej
                    write(unit,'(A,I8)')     '  new maxima this temperature:', nnew
                else
                    write(unit,'(A,G25.18)') '  min function value so far:  ', -fopt
                    write(unit,'(A,I8)')     '  total moves:                ', totmov
                    write(unit,'(A,I8)')     '     downhill:                ', nup
                    write(unit,'(A,I8)')     '     accepted uphill:         ', ndown
                    write(unit,'(A,I8)')     '     rejected uphill:         ', nrej
                    write(unit,'(A,I8)')     '  new minima this temperature:', nnew
                end if
                call print_vector(unit,xopt, me%n, 'current optimal x')
                call print_vector(unit,vm,   me%n, 'step length (vm)')
                write(unit, '(A)') ' '
            end if

            !  check termination criteria.
            fstar(1) = f
            quit = ((fopt-f)<=me%eps) .and. (all(abs(f-fstar)<=me%eps))

            !  terminate sa if appropriate.
            if (quit) then
                x = xopt
                ier = 0
                fopt = me%func(fopt)
                if (me%iprint >= 1) then
                    write(unit,'(/A)') '----------------------------------------------'
                    write(unit,'(A)')  '  sa achieved termination criteria. ier = 0.  '
                    write(unit,'(A/)') '----------------------------------------------'
                end if
                exit
            end if

            !  if termination criteria is not met, prepare for another loop.
            t = abs(rt)*t
            do i = me%neps, 2, -1
                fstar(i) = fstar(i-1)
            end do
            f = fopt
            x = xopt

        end do main

    end do reset

    end subroutine sa
!********************************************************************************

!********************************************************************************
!>
!  Perturb the `x` vector and evaluate the function.
!
!  If the function evaluation is not valid, it will perturb
!  and try again. Until a valid function is obtained or the
!  maximum number of function evaluations is reached.

    subroutine perturb_and_evaluate(me,x,vm,xp,fp,nfcnev,ier,first)

    implicit none

    class(simulated_annealing_type),intent(inout) :: me
    real(dp),dimension(:),intent(in)  :: x       !! input optimization variable vector to perturb
    real(dp),dimension(:),intent(in)  :: vm      !! step length vector
    real(dp),dimension(:),intent(out) :: xp      !! the perturbed `x` value
    real(dp),intent(out)              :: fp      !! the value of the user function at `xp`
    integer,intent(inout)             :: nfcnev  !! total number of function evaluations
    integer,intent(inout)             :: ier     !! status output code
    logical,intent(in),optional       :: first   !! to use the input `x` the first time

    integer :: i         !! counter
    integer :: istat     !! user function status code
    logical :: first_try !! local copy of `first`
    real(dp) :: lower    !! lower bound to use for random interval
    real(dp) :: upper    !! upper bound to use for random interval

    if (present(first)) then
        first_try = first
    else
        first_try = .false.
    end if

    do

        if (first_try) then
            if (me%use_initial_guess) then
                ! use the initial guess
                ! [note if this evauation fails, the subsequent ones
                !  are perturbed from this one]
                xp = x
                first_try = .false.
            else
                ! a random point in the bounds:
                ! [if it fails, a new random one is tried next time]
                do i = 1, me%n
                    xp(i) = uniform(me%lb(i),me%ub(i))
                    !xp(i) = me%lb(i) + (me%ub(i)-me%lb(i))*uniform_random_number()
                end do
            end if
        else
            ! perturb all of them:
            do i = 1, me%n
                lower = max( me%lb(i), x(i) - vm(i) )
                upper = min( me%ub(i), x(i) + vm(i) )
                xp(i) = uniform(lower,upper)
                !xp(i) = lower + (upper-lower)*uniform_random_number()
            end do
        end if

        ! evaluate the function with the trial
        ! point xp and return as fp.
        call me%fcn(xp, fp, istat)

        ! function eval counter:
        nfcnev = nfcnev + 1

        !  if too many function evaluations occur, terminate the algorithm.
        if (nfcnev > me%maxevl) then
            if (me%iprint>0) then
                write(me%iunit, '(A)') ' too many function evaluations; consider'
                write(me%iunit, '(A)') ' increasing maxevl or eps, or decreasing'
                write(me%iunit, '(A)') ' nt or rt. these results are likely to be'
                write(me%iunit, '(A)') ' poor.'
            end if
            ier = 1
            return
        end if

        select case (istat)
        case(-2)
            ! user stop
            write(me%iunit, '(A)') ' user stopped in function.'
            ier = 4
            exit
        case(-1)
            ! try another one until we get a valid evaluation
            cycle
        case default
            ! continue
        end select

        exit ! finished

    end do

    end subroutine perturb_and_evaluate
!********************************************************************************

!********************************************************************************
!>
!  if the function is to be minimized, switch the sign of the function.
!  note that all intermediate and final output switches the sign back
!  to eliminate any possible confusion for the user.

    pure function func(me,f)

    implicit none

    class(simulated_annealing_type),intent(in) :: me
    real(dp),intent(in) :: f
    real(dp) :: func

    if (me%maximize) then
        func = f
    else
        func = -f
    end if

    end function func
!********************************************************************************

!********************************************************************************
!>
!  this function replaces `exp()` to avoid underflow and overflow.
!
!  note that the maximum and minimum values of
!  exprep are such that they has no effect on the algorithm.
!
!### History
!  * Jacob Williams, 8/30/2019 : new version of this routine that uses IEEE flags.

    pure function exprep(x) result(f)

    use, intrinsic :: ieee_exceptions

    implicit none

    logical,dimension(2) :: flags
    type(ieee_flag_type),parameter,dimension(2) :: out_of_range = &
                                                    [ieee_overflow,ieee_underflow]

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

    call ieee_set_halting_mode(out_of_range,.false.)

    f = exp(x)

    call ieee_get_flag(out_of_range,flags)
    if (any(flags)) then
        call ieee_set_flag(out_of_range,.false.)
        if (flags(1)) then
            f = huge(1.0_dp)
        else
            f = 0.0_dp
        end if
    end if

    end function exprep
!********************************************************************************

!********************************************************************************
!>
!  Initialize the intrinsic random number generator.
!
!### Author
!  * Jacob Williams, 8/30/2019

    subroutine rand_init(seed1,seed2)

    implicit none

    integer,intent(in) :: seed1  !! the first seed for the random number generator.
    integer,intent(in) :: seed2  !! the second seed for the random number generator.

    integer,dimension(:),allocatable :: s
    integer :: n
    integer :: i

    if (seed1==0 .and. seed2==0) then
        call random_seed()
    else
        call random_seed(size = n)
        allocate(s(n))
        s(1) = seed1
        if (n>1) then
            s(2) = seed2
            do i = 3, n ! just in case
                s(i) = seed1 + seed2 + i
            end do
        end if
        call random_seed(put=s)
    end if

    end subroutine rand_init
!********************************************************************************

!********************************************************************************
!>
!  Get a new uniform random number from [0,1].
!
!### Author
!  * Jacob Williams, 8/30/2019

    function uniform_random_number() result(f)

    implicit none

    real(dp) :: f

    call random_number(f)

    end function uniform_random_number
!********************************************************************************

!********************************************************************************
!>
!  Uniform random number on the interval `[xl,xu]`.

    function uniform(xl,xu)

    implicit none

    real(dp),intent(in) :: xl !! lower bound
    real(dp),intent(in) :: xu !! upper bound
    real(dp) :: uniform

    uniform = xl + (xu-xl)*uniform_random_number()

    end function uniform
!********************************************************************************

!********************************************************************************
!>
!  this subroutine prints the double precision vector named vector.
!  elements 1 thru ncols will be printed. name is a character variable
!  that describes vector. note that if name is given in the call to
!  print_vector, it must be enclosed in quotes. if there are more than 10
!  elements in vector, 10 elements will be printed on each line.

    subroutine print_vector(iunit, vector, ncols, name)

    implicit none

    integer, intent(in)                     :: iunit
    integer, intent(in)                     :: ncols
    real(dp), dimension(ncols), intent(in)  :: vector
    character(len=*), intent(in)            :: name

    integer :: i, lines, ll

    write(iunit,'(/,25X,A)') trim(name)

    if (ncols > 10) then
        lines = int(ncols/10.0_dp)
        do i = 1, lines
            ll = 10*(i - 1)
            write(iunit,'(10(G12.5,1X))') vector(1+ll:10+ll)
        end do
        write(iunit,'(10(G12.5,1X))') vector(11+ll:ncols)
    else
        write(iunit,'(10(G12.5,1X))') vector(1:ncols)
    end if

    end subroutine print_vector
!********************************************************************************

!********************************************************************************
    end module simulated_annealing_module
!********************************************************************************


!
! Project Euler Problem 2: Even Fibonacci numbers
!
! D. C. Groothuizen Dijkema - November, 2019
!

subroutine run
  implicit none
  integer :: fib_0,fib_1,sum,tmp
  integer, parameter :: limit=4000000

  fib_0=1
  fib_1=1
  sum=0

  do while (fib_0.lt.limit)
    if (mod(fib_0,2).eq.0) then
      sum=sum+fib_0
    end if
    tmp=fib_0
    fib_0=fib_1
    fib_1=fib_0+tmp
  end do

  print *,"The sum of all even Fibonacci numbers less than four million is:",sum

end subroutine run

program fibonacci
  implicit none
  integer :: beginning,end,rate

  call system_clock(beginning,rate)
  call run
  call system_clock(end)
  print *,"Elapsed time:",real(end-beginning)/real(rate)

end program


module hyper
use, intrinsic:: ieee_arithmetic
use, intrinsic:: iso_fortran_env, only: stderr=>error_unit
use assert, only: wp
use rat, only: SWITCH_RAT_TO_REAL
use global

implicit none (type, external)

interface sech
procedure sech_r, sech_c
end interface sech

interface asech
procedure asech_r, asech_c
end interface asech

interface csch
procedure csch_r, csch_c
end interface csch

interface acsch
procedure acsch_r, acsch_c
end interface acsch

interface coth
procedure coth_r, coth_c
end interface coth

interface acoth
procedure acoth_r, acoth_c
end interface acoth

contains

!***********************************************************************************************************************************
!  SECH
!
!  Hyperbolic secant.
!***********************************************************************************************************************************

elemental real(wp) FUNCTION SECH_r(X) result(sech)
real(wp), INTENT (IN) :: X

sech = 1._wp/COSH(X)
END FUNCTION SECH_r

elemental complex(wp) FUNCTION SECH_c(Z) RESULT(sech)
COMPLEX(wp), INTENT (IN) :: Z

sech = 1._wp/cosh(Z)
END FUNCTION SECH_c

!***********************************************************************************************************************************
!  ASECH
!
!  Inverse hyperbolic secant.
!***********************************************************************************************************************************

elemental real(wp) FUNCTION ASECH_r(y) result(asech)
real(wp), INTENT (IN) :: Y

asech = ACOSH(1._wp/Y)
END FUNCTION ASECH_r

elemental complex(wp) FUNCTION ASECH_c(Y) result(asech)
COMPLEX(wp), INTENT (IN) :: Y

asech = ACOSH(1._wp/Y)

END FUNCTION ASECH_c

!***********************************************************************************************************************************
!  CSCH
!
!  Hyperbolic cosecant.
!***********************************************************************************************************************************

elemental real(wp) FUNCTION CSCH_r(X) RESULT (Y)
real(wp), INTENT (IN) :: X

Y = 1._wp/SINH(X)
END FUNCTION CSCH_r

elemental complex(wp) FUNCTION CSCH_c(Z) RESULT (Y)
COMPLEX(wp), INTENT (IN) :: Z

Y = 1._wp / SINH(Z)
END FUNCTION CSCH_c

!***********************************************************************************************************************************
!  ACSCH
!
!  Inverse hyperbolic cosecant.
!***********************************************************************************************************************************

elemental real(wp) FUNCTION ACSCH_r(Y) RESULT (X)
real(wp), INTENT (IN) :: Y

X = ASINH(1._wp/Y)
END FUNCTION ACSCH_r

elemental complex(wp) FUNCTION ACSCH_c(Y) RESULT (X)
COMPLEX(wp), INTENT (IN) :: Y

X = ASINH(1._wp/Y)

END FUNCTION ACSCH_c

!***********************************************************************************************************************************
!  COTH
!
!  Hyperbolic cotangent.
!***********************************************************************************************************************************

elemental real(wp) FUNCTION COTH_r(X) result(coth)
real(wp), INTENT (IN) :: X

coth = 1._wp/TANH(X)
END FUNCTION COTH_r

elemental complex(wp) FUNCTION COTH_c(Z) result(coth)
COMPLEX(wp), INTENT (IN) :: Z

COTH = 1._wp / tanh(Z)
END FUNCTION COTH_c

!***********************************************************************************************************************************
!  ACOTH
!
!  Inverse hyperbolic cotangent.
!***********************************************************************************************************************************

elemental real(wp) FUNCTION ACOTH_r(Y) result(acoth)
real(wp), INTENT (IN) :: Y

ACOTH = ATANH(1._wp/Y)
END FUNCTION ACOTH_r

elemental complex(wp) FUNCTION ACOTH_c(Z) result(acoth)
COMPLEX(wp), INTENT(IN) :: Z

acoth = 0.5_wp*LOG((Z+1._wp)/(Z-1._wp))
END FUNCTION ACOTH_c

!-------------------------------------------------
subroutine hasin(domain_mode)
integer, intent(in) :: domain_mode

SELECT CASE (DOMAIN_MODE)
  CASE (1)
     LASTX = STACK(1)
     STACK(1) = ASINH(STACK(1))
  CASE (2)
     CLASTX = CSTACK(1)
     CSTACK(1) = ASINH(CSTACK(1))
  CASE (3)
     CALL SWITCH_RAT_TO_REAL
     LASTX = STACK(1)
     STACK(1) = ASINH(STACK(1))
END SELECT

end subroutine hasin

subroutine hacos(domain_mode)
integer, intent(in) :: domain_mode

   SELECT CASE (DOMAIN_MODE)
      CASE (1)
         IF (STACK(1) < 1._wp) THEN
            write(stderr, *) '  ACOSH Error'
         ELSE
            LASTX = STACK(1)
            STACK(1) = ACOSH(STACK(1))
         END IF
      CASE (2)
         CLASTX = CSTACK(1)
         CSTACK(1) = ACOSH(CSTACK(1))
      CASE (3)
         IF (RNSTACK(1) < RDSTACK(1)) THEN
            write(stderr, *) '  ACOSH Error'
         ELSE
            CALL SWITCH_RAT_TO_REAL
            LASTX = STACK(1)
            STACK(1) = ACOSH(STACK(1))
         END IF
   END SELECT
end subroutine hacos

subroutine hatan(domain_mode)
integer, intent(in) :: domain_mode

SELECT CASE (DOMAIN_MODE)
  CASE (1)
     IF (ABS(STACK(1)) >= 1._wp) THEN
        write(stderr, *) '  ATANH Error'
     ELSE
        LASTX = STACK(1)
        STACK(1) = ATANH(STACK(1))
     END IF
  CASE (2)
     CLASTX = CSTACK(1)
     CSTACK(1) = ATANH(CSTACK(1))
  CASE (3)
     IF (ABS(RNSTACK(1)) >= ABS(RDSTACK(1))) THEN
        write(stderr, *) '  ATANH Error'
     ELSE
        CALL SWITCH_RAT_TO_REAL
        LASTX = STACK(1)
        STACK(1) = ATANH(STACK(1))
     END IF
END SELECT

end subroutine hatan

end module hyper


! leggaus.f90
! author: sunder

! ---------------------------------------------------------------------------------------------------------
! Gauss-Legendre quadrature points (x) and weights (w) in interval (x1, x2) for n points
! ---------------------------------------------------------------------------------------------------------

pure subroutine gauleg(x1, x2, x, w, n)
    use constants, only : m_pi
    implicit none
    ! Argument list
    integer, intent(in)           ::  n
    double precision, intent (in) :: x1, x2
    double precision, intent(out) :: x(n), w(n)
    ! Local variables
    double precision :: EPS
    integer  :: i,j,m
    double precision :: p1, p2, p3, pp, xl, xm, z, z1

    parameter (EPS=1.0D-15)

    m  = (n+1)/2
    xm = 0.5*(x2+x1)
    xl = 0.5*(x2-x1)
    do i=1,m
        z = COS(m_pi*(i-0.25d0)/(n+0.5d0))
    1    continue
        p1 = 1.0d0
        p2 = 0.0d0
        do j = 1,n
            p3 = p2
            p2 = p1
            p1 = ((2.0d0*j-1.0d0)*z*p2-(j-1.0d0)*p3)/dble(j)
        end do
        pp = dble(n)*(z*p1-p2)/(z*z-1.0d0)
        z1 = z
        z  = z1-p1/pp
        if(abs(z-z1).GT.EPS)goto 1
        x(i)    = xm-xl*z
        x(n+1-i)= xm+xl*z
        w(i)    = 2.0d0*xl/((1.-z*z)*pp*pp)
        w(n+1-i)= w(i)
    end do
    return
end subroutine gauleg


! Computes an approximation of Pi with a Monte Carlo algorithm
! OpenMP version
! Vincent Magnin, 2021-04-22
! Last modification: 2021-05-09
! MIT license
! $ gfortran -Wall -Wextra -std=f2018 -pedantic -O3 -fopenmp m_xoroshiro128plus.f90 pi_monte_carlo_openmp.f90
! $ ifort -O3 -qopenmp m_xoroshiro128plus.f90 pi_monte_carlo_openmp.f90

program pi_monte_carlo_openmp
    use, intrinsic :: iso_fortran_env, only: wp=>real64, int64
    use m_xoroshiro128plus
    use omp_lib, only: omp_get_thread_num
    implicit none
    type(rng_t)     :: rng          ! xoroshiro128+ pseudo-random number generator
    real(wp)        :: x, y         ! Coordinates of a point
    integer(int64)  :: n            ! Total number of points
    integer(int64)  :: k = 0        ! Points into the quarter disk
    integer(int64)  :: i            ! Loop counter
    integer         :: t1, t2       ! Clock ticks
    real            :: count_rate   ! Clock ticks per second
    integer         :: thread       ! OpenMP thread number

    n = 1000000000

    call system_clock(t1, count_rate)

    !$OMP PARALLEL DEFAULT(NONE) SHARED(n) PRIVATE(thread, i, x, y, rng) REDUCTION(+: k)
    thread = omp_get_thread_num()
    ! Each thread will have its own RNG seed:
    call rng%seed([ -1337_i8, 9812374_i8 ] + 10*thread)
    x = rng%U01()

    !$OMP DO SCHEDULE(STATIC)
    do i = 1, n
        ! Computing a random point (x,y) into the square 0<=x<1, 0<=y<1:
        x = rng%U01()
        y = rng%U01()

        ! Is it in the quarter disk (R=1, center=origin) ?
        if ((x**2 + y**2) < 1.0_wp) k = k + 1
    end do
    !$OMP END DO
    print '(a, i0, a, i0)', "k", thread, " = ", k
    !$OMP END PARALLEL

    write(*,*)
    write(*, '(a, i0, a, i0)', advance='no') "4 * ", k, " / ", n
    write(*, '(a, f17.15)') " = ", (4.0_wp * k) / n

    call system_clock(t2)
    write(*,'(a, f6.3, a)') "Execution time: ", (t2 - t1) / count_rate, " s"
    write(*,'(a)') "---------------------------------------------------"
end program pi_monte_carlo_openmp


program  problem_1
    integer i
    integer total
    total = 0
    do i=0,999
        if (MODULO(i, 3) == 0 .OR. MODULO(i, 5) == 0) then
            total = total + i
        end if
    end  do
    print *,"Problem 1:", total
end program problem_1


module optimize

! Optimization algorithms

use types, only: dp
use utils, only: stop_error
implicit none
private
public bisect,secant

interface
    real(dp) function func(x)
    import :: dp
    implicit none
    real(dp), intent(in) :: x
    end function
end interface

contains

real(dp) function bisect(f, a, b, tol) result(c)
! Solves f(x) = 0 on the interval [a, b] using the bisection method
procedure(func) :: f
real(dp), intent(in) :: a, b, tol
real(dp) :: a_, b_, fa, fb, fc
a_ = a; b_ = b
fa = f(a_)
fb = f(b_)
if (fa * fb >= 0) then
    call stop_error("bisect: f(a) and f(b) must have opposite signs")
end if
do while (b_ - a_ > tol)
    c = (a_ + b_) / 2
    fc = f(c)
    if (abs(fc) < tiny(1.0_dp)) return   ! We need to make sure f(c) is not zero below
    if (fa * fc < 0) then
        b_ = c
        fb = fc
    else
        a_ = c
        fa = fc
    end if
end do
c = (a_ + b_)/2
end function

real(dp) function secant(f, a,b,tol, maxiter) result (c)
!Solves f(x) = 0 on using the a and b as starting values
procedure(func) :: f
real(dp),intent(in) :: a,b,tol
integer,optional :: maxiter

integer :: maxiter_
real(dp) :: xstart, xnext
real(dp) :: fstart, fnext
integer ::  i

if(present(maxiter)) then
    maxiter_ = maxiter
else
    maxiter_ = 100
endif

xstart = a
xnext = b
fstart = f(xstart)
if(abs(fstart ) < tiny(1.0_dp)) then
    c = xstart
    return
endif
fnext = f(xnext)
if(abs(fnext ) < tiny(1.0_dp)) then
    c = xnext
    return
endif

do i = 1, maxiter_

    if( abs(fnext - fstart) < tiny(1.0_dp)) then
       call stop_error("secant: division by zero")
    endif
    c = (xstart*fnext - xnext*fstart)/(fnext - fstart)
    if (abs(c - xnext) < tol) return ! root found
    !update variables
    xstart = xnext
    fstart = fnext
    xnext = c
    fnext = f(c)
enddo
!max iterations number reached
call stop_error("secant: method did not converge")
end function secant

end module


      SUBROUTINE RECCEL(CELL,RCELL)
      IMPLICIT NONE
C***********************************************************************
C-----------------------------------------------------------------------
C PURPOSE: ESTABLISH RECIPROCAL CELL PARAMETERS FROM REAL CELL PARAMS
C =======  USING FORMULAE OF STOUT+JENSEN - "X-RAY STRUCTURE ANALYSIS",
C          MACMILLAN CO. (1968),  P.31, OR INT. TABLES VOL I P.13.
C-----------------------------------------------------------------------
C CALLS      : 0
C =====
C-----------------------------------------------------------------------
C ARGUMENTS:
C =========
C  CELL(I)  - Real array containing real space lattice parameters
C  RCELL(O) - Real array containing derived reciprocal space lattice
C             parameters
C-----------------------------------------------------------------------
      REAL CELL(6),RCELL(6)
      DOUBLE PRECISION DC1,DC2,DC3,DC4,DC5,DC6
      DOUBLE PRECISION CASQ,CBSQ,CCSQ,CBA,ALBTGM,VOLUME,XNUM,DEN,TEMP
C-----------------------------------------------------------------------
C
C-- Convert cell parameters to double precision
C
      DC1 = DBLE(CELL(1))
      DC2 = DBLE(CELL(2))
      DC3 = DBLE(CELL(3))
      DC4 = DBLE(CELL(4))
      DC5 = DBLE(CELL(5))
      DC6 = DBLE(CELL(6))
C
C-- Calculate real cell volume. Remember all angles should already be
C   in radians.
C
      CASQ = COS(DC4)**2
      CBSQ = COS(DC5)**2
      CCSQ = COS(DC6)**2
      CBA = DC1*DC2*DC3
      ALBTGM = COS(DC4)*COS(DC5)*COS(DC6)
      VOLUME = CBA*(SQRT(1.0D0-CASQ-CBSQ-CCSQ+2.0D0*ALBTGM))
C
C-- Calculate reciprocal cell sides
C
      RCELL(1) = SNGL(DC2*DC3*SIN(DC4)/VOLUME)
      RCELL(2) = SNGL(DC1*DC3*SIN(DC5)/VOLUME)
      RCELL(3) = SNGL(DC1*DC2*SIN(DC6)/VOLUME)
C
C-- Calculate reciprocal cell angles
C
      XNUM = COS(DC5)*COS(DC6) - COS(DC4)
      DEN = SIN(DC5)*SIN(DC6)
      TEMP = XNUM/DEN
      RCELL(4) = SNGL(ACOS(TEMP))

      XNUM = COS(DC4)*COS(DC6) - COS(DC5)
      DEN = SIN(DC4)*SIN(DC6)
      TEMP = XNUM/DEN
      RCELL(5) = SNGL(ACOS(TEMP))

      XNUM = COS(DC4)*COS(DC5) - COS(DC6)
      DEN = SIN(DC4)*SIN(DC5)
      TEMP = XNUM/DEN
      RCELL(6) = SNGL(ACOS(TEMP))

      RETURN
      END


!##############################################################################
! PROGRAM GaussLegendre
!
! ## Numerical integration with Gauss-Legendre quadrature
!
! 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 GaussLegendre

    use toolbox

    implicit none
    integer, parameter :: n = 10
    real*8, parameter :: a = 0d0, b = 2d0
    real*8 :: x(0:n), w(0:n), f(0:n)

    ! calculate nodes and weights
    call legendre(0d0, 2d0, x, w)

    ! calculate function values at nodes
    f = cos(x)

    ! Output numerical and analytical solution
    write(*,'(a,f10.6)')' Numerical:  ',sum(w*f, 1)
    write(*,'(a,f10.6)')' Analytical: ',sin(2d0)-sin(0d0)

end program


! A[r,s] * B[s,t] = C[r,t]
subroutine matrix_multiply2(A,r,s,B,t,C)
	integer :: r, s, t
	real, intent(in) :: A(r,s)
	real, intent(in) :: B(s,t)
	real, intent(inout) :: C(r,t)

	C = matmul(A,B)
end subroutine matrix_multiply2


	SUBROUTINE initialdata(Nx,dt,c,x,u,uold)
	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This subroutine gets initial data for nonlinear Klein-Gordon equation
	! in 1 dimensions
	! u_{tt}-u_{xx}+u=Es*u^3
	!
	! The boundary conditions are u(x=-Lx*\pi)=u(x=Lx*\pi),
	! The initial condition is u=sqrt(2)*sech((x(i)-c*t)/sqrt(1-c**2)
	!
	! INPUT
	!
	! .. Parameters ..
	!  Nx	= number of modes in x - power of 2 for FFT
        !  dt   = timestep
        !  c    = wavespeed
	! .. Vectors ..
	!  x	= x locations
	!
	! OUTPUT
	!
	! .. Arrays ..
	!  u 	= initial solution
	!  uold = approximate solution at previous timestep
	!
	! LOCAL VARIABLES
	!
	! .. Scalars ..
	!  i	= loop counter in x direction
	!
	! 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
	! OpenMP library
	!USE omp_lib
	IMPLICIT NONE
	! Declare variables
	INTEGER(KIND=4), INTENT(IN)				:: Nx
	REAL(KIND=8), DIMENSION(1:NX), INTENT(IN) 		:: x
	REAL(KIND=8), DIMENSION(1:NX), INTENT(OUT)		:: u,uold
	INTEGER(kind=4)						:: i
        REAL(KIND=8), INTENT(IN)                                :: c,dt
        REAL(KIND=8)                                            :: t=0.0d0
	DO i=1,Nx
		u(i)=sqrt(2.0d0)/(cosh((x(i)-c*t)/sqrt(1.0d0-c**2)))
                !u(i)=sqrt(2.0d0)/cosh(x(i)+t)
	END DO
        t=-1.0d0*dt;
	DO i=1,Nx
		uold(i)=sqrt(2.0d0)/(cosh((x(i)-c*t)/sqrt(1.0d0-c**2)))
                !uold(i)=sqrt(2.0d0)/cosh(x(i)+t)
	END DO

	END SUBROUTINE initialdata


!> Contains procedures for creating positions of molecules on a periodic
!! crystal lattice.
module m_crystal
implicit none

contains

!> Returns positions @p xs, @p ys, @p zs for a hexagonally close-packed
!! crystal with @p nx, @p ny and @p nz particles in x-, y- and
!! z-directions, respectively. The distance between particles in the
!! hexagonal layers is @p a and the distance between layers is @p d.
!! If @p center is .true. the coordinates are transformed so that the
!! origin is in the middle of the crystal. Otherwise all coordinates are
!! non-negative.
!!
!! @post xs(i), ys(i), zs(i) is the position of the i:th point (or
!! particle) in the crystal.
!!
subroutine hexagonally_close_packed(nx, ny, nz, a, d, center, xs, ys, zs)
  integer, intent(in) :: nx, ny, nz
  real(8), intent(in) :: a, d
  logical, intent(in) :: center
  real(8), intent(out) :: xs(nx, ny, nz), ys(nx, ny, nz), zs(nx, ny, nz)
  integer :: i
  real(8) :: h !< The distance between adjacent rows in the same layer
  real(8) :: m !< The distance between corresponding rows in adjacent
               !< layers.
  xs = 0.0
  ys = 0.0
  zs = 0.0
  !! First create coordinates, then center.
  !! Create first row in first layer
  xs(:, 1, 1) = [(i * a, i = 0, nx - 1)]
  !! Create other rows in the first layer
  do i = 3, ny, 2
     xs(:, i, 1) = xs(:, 1, 1)
  end do
  do i = 2, ny, 2
     xs(:, i, 1) = xs(:, 1, 1) + 0.5 * a
  end do

  h = sqrt(3.0) / 2 * a
  do i = 1, ny
     ys(:, i, 1) = (i - 1) * h
  end do

  !! Add distances between layers
  do i = 1, nz
     zs(:, :, i) = (i - 1) * d
  end do

  !! For every other layer, x and y are the same.
  !! Odd layers:
  do i = 1, nz, 2
     xs(:, :, i) = xs(:, :, 1)
     ys(:, :, i) = ys(:, :, 1)
  end do
  m = a / (2 * sqrt(3.0))
  !! Even layers:
  do i = 2, nz, 2
     xs(:, :, i) = xs(:, :, 1) + 0.5 * a
     ys(:, :, i) = ys(:, :, 1) + m
  end do
  if (center) then
     xs = xs - maxval(xs) / 2.0
     ys = ys - maxval(ys) / 2.0
     zs = zs - maxval(zs) / 2.0
  end if
end subroutine hexagonally_close_packed

end module m_crystal


program era_sieve

implicit none
integer*4 :: N ! The natural number up to which prime numbers will be calculated
integer*4 :: ii, jj ! indexing variables
integer*4 :: allocate_status
logical, allocatable :: is_prime(:)
logical :: true = 1.gt.0, false = 0.gt.1

write(*,*) "Up to which number do you wish to get primes? Enter an integer N>=2."
read(*,*) N

! N should be at least 2
if (N.lt.2) stop "***The upper limit should be at least 2***"

allocate(is_prime(2:N),stat = allocate_status)
if (allocate_status .ne. 0) stop "***Not enough memory to allocate sieve vector***"
is_prime = (/(true, ii =2, N)/)

ii = 2

! Eratosthenes Sieve
do while (ii .le. sqrt(real(N,4))) ! Casting N as real to calculate sqrt(N)
	if (is_prime(ii)) then
		jj = ii**2
		do while (jj .le. N) ! Spotting multiples of ii starting from ii**2
			is_prime(jj) = false
			jj = jj + ii
		end do
	end if
	ii = ii + 1
end do

do ii = 2,N
	if (is_prime(ii)) then
		write(*,*) ii
	end if
end do

write(*,*) "Enter any number to normally exit the program."
read(*,*) N

end program era_sieve


      subroutine mapc2m_bilinear(blockno,xc,yc,xp,yp,zp,center)
      implicit none

      double precision xc,yc,xp,yp,zp
      integer blockno
      double precision center(2)

      double precision quad(0:1,0:1,2)
      double precision a00(2), a01(2),a10(2), a11(2)
      double precision ll(2), lr(2), ul(2), ur(2)
      double precision shiftx(0:3), shifty(0:3)
      integer m, i, j

      data ll/0,0/, ul/0, 1/, lr/1, 0/, ur/1,1/
      data shiftx/-1,0,-1,0/, shifty/-1,-1,0,0/

c     # Maps [0,1]x[0,1] to a bilinear map with physical
c     # corners at [quad(0,0,:), quad(0,1,:), quad(1,0,:), quad(1,1,:)]

      do m = 1,2
         quad(0,0,m) = ll(m)
         quad(1,0,m) = lr(m)
         quad(0,1,m) = ul(m)
         quad(1,1,m) = ur(m)
      enddo

      do i = 0,1
         do j = 0,1
            quad(i,j,1) = quad(i,j,1) + shiftx(blockno)
            quad(i,j,2) = quad(i,j,2) + shifty(blockno)
         enddo
      enddo

      do m = 1,2
         if (blockno .eq. 0) then
            quad(1,1,m) = center(m)
         elseif (blockno .eq. 1) then
            quad(0,1,m) = center(m)
         elseif (blockno .eq. 2) then
            quad(1,0,m) = center(m)
         elseif (blockno .eq. 3) then
            quad(0,0,m) = center(m)
         endif
      enddo

      do m = 1,2
         a00(m) = quad(0,0,m)
         a01(m) = quad(1,0,m) - quad(0,0,m)
         a10(m) = quad(0,1,m) - quad(0,0,m)
         a11(m) = quad(1,1,m) - quad(1,0,m) -
     &         quad(0,1,m) + quad(0,0,m)
      enddo

c     #  T(xi,eta) = a00 + a01*xi + a10*eta + a11*xi*eta

      xp = a00(1) + a01(1)*xc + a10(1)*yc + a11(1)*xc*yc
      yp = a00(2) + a01(2)*xc + a10(2)*yc + a11(2)*xc*yc
      zp = 0

      end


program test

  use stochoptim, only: Evolutionary

  implicit none

  real(kind = 8), parameter :: pi = 3.141592653589793238460d0
  integer(kind = 4), parameter :: n_dim = 5, popsize = 10, max_iter = 500
  real(kind = 8), dimension(:), allocatable :: lower, upper
  type(Evolutionary) :: ea

  ! Define search boundaries
  allocate(lower(n_dim), upper(n_dim))
  lower = -5.12
  upper = 5.12

  ! Initialize evolutionary optimizer
  ea = Evolutionary(rastrigin, lower, upper, &
                    popsize = popsize, max_iter = max_iter)

  ! Optimize
  call ea % optimize(solver = "cpso")

  ! Display results
  call ea % print()

contains

  function rastrigin(x) result(f)
    real(kind = 8), dimension(:), intent(in) :: x
    integer(kind = 4) :: n_dim
    real(kind = 8) :: f, sum1

    n_dim = size(x)
    sum1 = sum( x**2 - 10.0d0 * cos( 2.0d0 * pi * x ) )
    f = 10.0d0 * n_dim + sum1
    return
  end function rastrigin

end program test


SUBROUTINE rmax ( a, n, real_max, imax )
!
!  Purpose:
!    To find the maximum value in an array, and the location
!    of that value in the array.
!
IMPLICIT NONE

! Data dictionary: declare calling parameter types & definitions
INTEGER, INTENT(IN) :: n             ! No. of vals in array a.
REAL, INTENT(IN), DIMENSION(n) :: a  ! Input data.
REAL, INTENT(OUT) :: real_max        ! Maximum value in a.
INTEGER, INTENT(OUT) :: imax         ! Location of max value.

! Data dictionary: declare local variable types & definitions
INTEGER :: i                         ! Index variable

! Initialize the maximum value to first value in array.
real_max = a(1)
imax = 1

! Find the maximum value.
DO i = 2, n
   IF ( a(i) > real_max ) THEN
      real_max = a(i)
      imax = i
   END IF
END DO

END SUBROUTINE rmax

SUBROUTINE rmin ( a, n, real_min, imin )
!
!  Purpose:
!    To find the minimum value in an array, and the location
!    of that value in the array.
!
IMPLICIT NONE

! Data dictionary: declare calling parameter types & definitions
INTEGER, INTENT(IN) :: n             ! No. of vals in array a.
REAL, INTENT(IN), DIMENSION(n) :: a  ! Input data.
REAL, INTENT(OUT) :: real_min        ! Minimum value in a.
INTEGER, INTENT(OUT) :: imin         ! Location of min value.

! Data dictionary: declare local variable types & definitions
INTEGER :: i                         ! Index variable

! Initialize the minimum value to first value in array.
real_min = a(1)
imin = 1

! Find the minimum value.
DO I = 2, n
   IF ( a(i) < real_min ) THEN
      real_min  = a(i)
      imin = i
   END IF
END DO

END SUBROUTINE rmin

SUBROUTINE ave_sd ( a, n, ave, std_dev, error )
!
!  Purpose:
!    To calculate the average and standard deviation of an array.
!
IMPLICIT NONE

! Data dictionary: declare calling parameter types & definitions
INTEGER, INTENT(IN) :: n             ! No. of vals in array a.
REAL, INTENT(IN), DIMENSION(n) :: a  ! Input data.
REAL, INTENT(OUT) :: ave             ! Average of a.
REAL, INTENT(OUT) :: std_dev         ! Standard deviation.
INTEGER, INTENT(OUT) :: error        ! Flag: 0 -- no error
                                     !       1 -- sd invalid
                                     !       2 -- ave & sd invalid

! Data dictionary: declare local variable types & definitions
INTEGER :: i                         ! Loop index
REAL :: sum_x                        ! Sum of input values
REAL :: sum_x2                       ! Sum of input values squared

! Initialize the sums to zero.
sum_x  = 0.
sum_x2 = 0.

! Accumulate sums.
DO I = 1, n
   sum_x  = sum_x + a(i)
   sum_x2 = sum_x2 + a(i)**2
END DO

! Check to see if we have enough input data.
IF ( n >= 2 ) THEN ! we have enough data

   ! Calculate the mean and standard deviation
   ave   = sum_x / REAL(n)
   std_dev = SQRT( (REAL(n) * sum_x2 - sum_x**2) &
           / (REAL(n) * REAL(n-1)) )
   error = 0

ELSE IF ( n == 1 ) THEN ! no valid std_dev

   ave   = sum_x
   std_dev = 0.              ! std_dev invalid
   error = 1

ELSE

   ave = 0.                  ! ave invalid
   std_dev = 0.              ! std_dev invalid
   error = 2

END IF
END SUBROUTINE ave_sd

SUBROUTINE median ( a, n, med )
!
!  Purpose:
!    To calculate the median value of an array.
!
IMPLICIT NONE

! Data dictionary: declare calling parameter types & definitions
INTEGER, INTENT(IN) :: n             ! No. of vals in array a.
REAL, INTENT(IN), DIMENSION(n) :: a  ! Input data.
REAL, INTENT(OUT) :: med             ! Median value of a.

! Sort the data into ascending order.
CALL sort ( a, n )

! Get median.
IF ( MOD(n,2) == 0 ) THEN
   med = ( a(n/2) + a(n/2+1) ) / 2.
ELSE
   med = a(n/2+1)
END IF
END SUBROUTINE median


module gamma_dist
  use gamma
  implicit none
  private p_gamma, q_gamma
contains

  function logpdf_gamma(shape, rate, x, lgamshape) result(result)
    double precision, intent(in) :: shape, rate, x, lgamshape
    double precision :: result
    result = shape * log(rate) + (shape-1.0d0) * log(x) - rate * x - lgamshape
  end function logpdf_gamma

  function pdf_gamma(shape, rate, x, lgamshape) result(result)
    double precision, intent(in) :: shape, rate, x, lgamshape
    double precision :: result
    result = exp(logpdf_gamma(shape, rate, x, lgamshape))
  end function pdf_gamma

  function p_gamma(a, x, loggamma_a)
    double precision, intent(in) :: a, x, loggamma_a
    double precision :: p_gamma
    integer :: k
    double precision :: res, term, previous
    if (x >= 1.0d0 + a) then
       p_gamma = 1.0d0 - q_gamma(a, x, loggamma_a)
       return
    end if
    if (x == 0.0d0) then
       p_gamma = 0.0d0
       return
    end if
    term = exp(a * log(x) - x - loggamma_a) / a
    res = term
    do k = 1, 1000
       term = term * x / (a+k)
       previous = res
       res = res + term
       if (res == previous) then
          p_gamma = res
          return
       end if
    end do
    p_gamma = res
  end function p_gamma

  function q_gamma(a, x, loggamma_a)
    double precision, intent(in) :: a, x, loggamma_a
    double precision :: q_gamma
    integer :: k
    double precision :: res, w, temp, previous, la, lb
    la = 1.0d0
    lb = 1.0d0 + x - a
    if (x < 1.0d0 + a) then
       q_gamma = 1.0d0 - p_gamma(a, x, loggamma_a)
       return
    end if
    w = exp(a * log(x) - x - loggamma_a)
    res = w / lb
    do k = 2, 1000
       temp = ((k-1.0d0-a)*(lb-la) + (x+k)*lb)/k
       la = lb
       lb = temp
       w = w * (k-1.0d0-a)/k
       temp = w / (la * lb)
       previous = res
       res = res + temp
       if (res == previous) then
          q_gamma = res
          return
       end if
    end do
    q_gamma = res
  end function q_gamma

  function cdf_gamma(shape, rate, x, lgamshape) result(result)
    double precision, intent(in) :: shape, rate, x, lgamshape
    double precision :: result
    result = p_gamma(shape, rate*x, lgamshape)
  end function cdf_gamma

  function ccdf_gamma(shape, rate, x, lgamshape) result(result)
    double precision, intent(in) :: shape, rate, x, lgamshape
    double precision :: result
    result = q_gamma(shape, rate*x, lgamshape)
  end function ccdf_gamma

end module gamma_dist


MODULE MULTIPOLE

    USE CONSTANTS
    USE FACT
    USE GAUSSIAN
    USE OVERLAP

    IMPLICIT NONE

    CONTAINS

    FUNCTION Sije(e,a,b,aa,bb,Rai,Rbi,Rpi,Rci)
        ! --------------------------------------------------
        ! Compute dipole moment of order E along direction I
        ! --------------------------------------------------
        !
        ! Source:
        !   T. Helgaker, P. Jørgensen and J. Olsen
        !   Molecular Electronic-Structure Theory
        !   Wiley
        !   2000
        !
        ! ---------------------------------------------------

        IMPLICIT NONE

        ! INPUT
        INTEGER, intent(in) :: e                        ! Dipole order
        INTEGER, intent(in) :: a,b                      ! Angular momentum coefficients of the Gaussians along direction i
        REAL*8, intent(in) :: aa, bb                    ! Exponential coefficients of the Gaussians
        REAL*8, intent(in) :: Rai, Rbi                  ! Centers of the Gaussians
        REAL*8, intent(in) :: Rpi                       ! Center of Gaussian product
        REAL*8, intent(in) :: Rci                       ! Center of the multipole

        ! INTERMEDIATE VARIABLE
        REAL*8, dimension(-1:a+1,-1:b+1,-1:e+1) :: S    ! Vector of overlap coefficients
        INTEGER :: i, j, k
        REAL*8 :: factor

        ! OUTPUT
        REAL*8 :: Sije                                  ! Dipole integral

        S(-1,:,:) = 0.0D0
        S(:,-1,:) = 0.0D0
        S(:,:,-1) = 0.0D0

        S(0,0,0) = S00(aa,bb,Rai,Rbi)

        DO i = 0, a
            DO j = 0, b
                DO k = 0, e
                    factor = 1.0D0 / (2 * (aa+bb)) * (i * S(i-1,j,k) + j * S(i,j-1,k) + k * S(i,j,k-1))

                    S(i+1,j,k) = (Rpi - Rai) * S(i,j,k) + factor
                    S(i,j+1,k) = (Rpi - Rbi) * S(i,j,k) + factor
                    S(i,j,k+1) = (Rpi - Rci) * S(i,j,k) + factor
                END DO
            END DO
        END DO

        Sije = S(a,b,e)

    END FUNCTION Sije

    FUNCTION multipole_coeff_OS(ax,ay,az,bx,by,bz,aa,bb,Ra,Rb,e,f,g,Rc) result(S)
        ! -------------------------------------------------------------------
        ! Compute multipole integral between two Cartesian Gaussian functions
        ! -------------------------------------------------------------------
        !
        ! Source:
        !   T. Helgaker, P. Jørgensen and J. Olsen
        !   Molecular Electronic-Structure Theory
        !   Wiley
        !   2000
        !
        ! -------------------------------------------------------------------

        IMPLICIT NONE

        ! INPUT
        INTEGER, intent(in) :: ax, ay, az, bx, by, bz   ! Angular momentum coefficients
        REAL*8, intent(in) :: aa, bb                    ! Exponential Gaussian coefficients
        REAL*8, dimension(3), intent(in) :: Ra, Rb      ! Gaussian centers
        INTEGER , intent(in) :: e, f, g                 ! Multipole order along x, y and z
        REAL*8, dimension(3), intent(in) :: Rc          ! Multipole center

        ! INTERMEDIATE VARIABLES
        REAL*8 :: pp ! Gaussian produc exponential coefficient
        REAL*8, dimension(3) :: Rp ! Gaussian produc center
        REAL*8 :: cp ! Gaussian product multiplicative constant

        ! OUTPUT
        REAL*8 :: S

        CALL gaussian_product(aa,bb,Ra,Rb,pp,Rp,cp) ! Compute PP, RP and CP

        S = 1
        S = S * Sije(e,ax,bx,aa,bb,Ra(1),Rb(1),Rp(1),Rc(1))       ! Overlap along x
        S = S * Sije(f,ay,by,aa,bb,Ra(2),Rb(2),Rp(2),Rc(2))       ! Overlap along y
        S = S * Sije(g,az,bz,aa,bb,Ra(3),Rb(3),Rp(3),Rc(3))       ! Overlap along z
        S = S * norm(ax,ay,az,aa) * norm(bx,by,bz,bb)             ! Normalization of Gaussian functions

    END FUNCTION multipole_coeff_OS

    SUBROUTINE S_multipole_i(Kf,c,basis_D,basis_A,basis_L,basis_R,dir,e,R,S)
        ! ----------------------------------------------
        ! Compute overlap matrix between basis function.
        ! ----------------------------------------------

        IMPLICIT NONE

        ! TODO Allow flexibility for basis sets other than STO-3G
        INTEGER, intent(in) :: c                        ! Number of contractions per basis function

        ! INPUT
        INTEGER, intent(in) :: Kf                       ! Number of basis functions
        REAL*8, dimension(Kf,3), intent(in) :: basis_R  ! Basis set niclear positions
        INTEGER, dimension(Kf,3), intent(in) :: basis_L ! Basis set angular momenta
        REAL*8, dimension(Kf,3), intent(in) :: basis_D  ! Basis set contraction coefficients
        REAL*8, dimension(Kf,3), intent(in) :: basis_A  ! Basis set exponential contraction coefficients
        REAL*8, dimension(3), intent(in) :: R           ! Multipole center
        INTEGER,  intent(in) :: dir                     ! Multipole direction
        INTEGER,  intent(in) :: e                       ! Multipole exponent along direction DIR

        ! INTERMEDIATE VARIABLES
        INTEGER :: i,j,k,l
        REAL*8 :: tmp
        INTEGER, dimension(3) :: multi_dir              ! Mulrtipole exponent along direction DIR

        ! OUTPUT
        REAL*8, dimension(Kf,Kf), intent(out) :: S

        IF (dir .EQ. 1) THEN

            multi_dir = (/e, 0, 0/)

        ELSE IF (dir .EQ. 2) THEN

            multi_dir = (/0, e, 0/)

        ELSE IF (dir .EQ. 3) THEN

            multi_dir = (/0, 0, e/)

        END IF

        S(:,:) = 0.0D0

        DO i = 1,Kf
            DO j = 1,Kf
                DO k = 1,c
                    DO l = 1,c
                        tmp = basis_D(i,k) * basis_D(j,l)
                        tmp = tmp * multipole_coeff_OS( basis_L(i,1),&  ! lx for basis function i
                                                        basis_L(i,2),&  ! ly for basis function i
                                                        basis_L(i,3),&  ! lz for basis function i
                                                        basis_L(j,1),&  ! lx for basis function j
                                                        basis_L(j,2),&  ! ly for basis function j
                                                        basis_L(j,3),&  ! lz for basis function j
                                                        basis_A(i,k),&  ! Exponential coefficient for basis function i, contraction k
                                                        basis_A(j,l),&  ! Exponential coefficient for basis function j, contraction l
                                                        basis_R(i,:),&  ! Center of basis function i
                                                        basis_R(j,:),&  ! Center of basis function j
                                                        multi_dir(1),&  ! Multipole exponent along x
                                                        multi_dir(2),&  ! Multipole exponent along y
                                                        multi_dir(3),&  ! Multipole exponent along z
                                                        R)              ! Multipole center

                        S(i,j) = S(i,j) + tmp
                    END DO ! l
                END DO ! k
            END DO ! j
        END DO ! i

    END SUBROUTINE S_multipole_i

    SUBROUTINE dipole(Kf,c,Nn,basis_D,basis_A,basis_L,basis_R,P,Rn,Zn,mu)
        ! ----------------------------
        ! Compute multipole vector
        ! ----------------------------
        !
        ! Source:
        !   A. Szabo and N. S. Ostlund
        !   Modern Quantum Chemistry
        !   Dover
        !   1996
        !
        ! ----------------------------

        ! TODO Allow flexibility for basis sets other than STO-3G
        INTEGER, intent(in) :: c                        ! Number of contractions per basis function

        ! INPUT
        INTEGER, intent(in) :: Kf                       ! Number of basis functions
        INTEGER, intent(in) :: Nn                       ! Number of nuclei
        REAL*8, dimension(Kf,3), intent(in) :: basis_R  ! Basis set niclear positions
        INTEGER, dimension(Kf,3), intent(in) :: basis_L ! Basis set angular momenta
        REAL*8, dimension(Kf,3), intent(in) :: basis_D  ! Basis set contraction coefficients
        REAL*8, dimension(Kf,3), intent(in) :: basis_A  ! Basis set exponential contraction coefficients
        REAL*8, dimension(Kf,Kf), intent(in) :: P       ! Density matrix
        REAL*8, dimension(Nn,3), intent(in) :: Rn       ! Nuclear positions
        INTEGER, dimension(Nn), intent(in) :: Zn

        ! INTERMEDIATE VARIABLES
        REAL*8, dimension(Kf,Kf) :: S
        REAL*8, dimension(3) :: R
        INTEGER :: i, j, k

        ! OUTPUT
        REAL*8, dimension(3), intent(out) :: mu

        mu(:) = 0.0D0

        R(:) = 0.0D0

        ! -----------
        ! X component
        ! -----------
        CALL S_multipole_i(Kf,c,basis_D,basis_A,basis_L,basis_R,1,1,R,S)

        DO i = 1, Kf
            DO j = 1, Kf
                mu(1) = mu(1) - P(i,j) * S(j,i)
            END DO
        END DO

        ! -----------
        ! Y component
        ! -----------
        CALL S_multipole_i(Kf,c,basis_D,basis_A,basis_L,basis_R,2,1,R,S)

        DO i = 1, Kf
            DO j = 1, Kf
                mu(2) = mu(2) - P(i,j) * S(j,i)
            END DO
        END DO

        ! -----------
        ! Z component
        ! -----------
        CALL S_multipole_i(Kf,c,basis_D,basis_A,basis_L,basis_R,3,1,R,S)

        DO i = 1, Kf
            DO j = 1, Kf
                mu(3) = mu(3) - P(i,j) * S(j,i)
            END DO
        END DO

        ! Take into account nuclear charges
        DO k = 1, Nn
            mu = mu + Zn(k) * Rn(k,:)
        END DO

    END SUBROUTINE

END MODULE MULTIPOLE


SUBROUTINE decsf(x,y,zz,fi0,tet0,FI,TET,h)
! this program calculates fi and tet of a point in global coordinates from
! given x, y, z coordinates relatively the point fi0, tet0
REAL PI/3.1415926/, rz/6371./
PER=PI/180.

sqr=(rz-zz)*(rz-zz)-x*x-y*y

!write(*,*)' dz=',rz-sqrt(sqr)

if(sqr.lt.0.) then
	write(*,*)' problem in DECSF:'
	write(*,*)' x=',x,' y=',y,' zz=',zz
	pause
end if

z=sqrt(sqr)
!write(*,*)' z=',z,'sqr=',sqr
X1=x
Y1=-Y*SIN(tet0*PER)+Z*COS(tet0*PER)
Z1=Y*COS(tet0*PER)+Z*SIN(tet0*PER)
!write(*,*)' x1=',x1,' y1=',y1,' z1=',z1
if(x1.eq.0.) then
	fi=fi0
else
	IF(X1.GT.0..AND.Y1.GT.0.)PA=0.
	IF(X1.LT.0.)PA=-PI
	IF(X1.GT.0..AND.Y1.LT.0.)PA=2.*PI
	ff=atan(y1/x1)/per
	FI=fi0-(ff+PA/PER)+90.
end if
!write(*,*)' fi=',fi
if(fi.gt.360.)fi=fi-360.

if(abs(fi-fi0).gt.abs(fi-fi0-360)) fi=fi-360
if(abs(fi-fi0).gt.abs(fi-fi0+360)) fi=fi+360

r=sqrt(x1*x1+y1*y1+z1*z1)
TET=ASIN(Z1/r)/PER
h=rz-r
RETURN
END


      SUBROUTINE GAULEG(X1,X2,X,W,N)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*4 X1,X2,X(N),W(N)
C given the lower and upper limits of the integration, X1 and X2, and N (n-points Gaussian),
C this routine returns arrays X(1:N) and W(1:N), the adscissas and weights of
C the Gauss-Legendre n-point quadrature formula.
      PARAMETER (EPS=3.D-14)
      M=(N+1)/2
      XM=0.5D0*(X2+X1)
      XL=0.5D0*(X2-X1)
      DO 12 I=1,M
        Z=COS(3.141592654D0*(I-.25D0)/(N+.5D0))
1       CONTINUE
          P1=1.D0
          P2=0.D0
          DO 11 J=1,N
            P3=P2
            P2=P1
            P1=((2.D0*J-1.D0)*Z*P2-(J-1.D0)*P3)/J
11        CONTINUE
          PP=N*(Z*P1-P2)/(Z*Z-1.D0)
          Z1=Z
          Z=Z1-P1/PP
        IF(ABS(Z-Z1).GT.EPS)GO TO 1
        X(I)=XM-XL*Z
        X(N+1-I)=XM+XL*Z
        W(I)=2.D0*XL/((1.D0-Z*Z)*PP*PP)
        W(N+1-I)=W(I)
12    CONTINUE
      RETURN
      END


C The actual YPRIME subroutine in FORTRAN
C
C Copyright 1984-2000 The MathWorks, Inc.
C
C

      SUBROUTINE YPRIME(YP, T, Y)
      REAL*8 YP(4), T, Y(4)

      REAL*8 MU, MUS, R1, R2

      MU = 1.0/82.45
      MUS = 1.0 - MU

      R1 = SQRT((Y(1)+MU)**2 + Y(3)**2)
      R2 = SQRT((Y(1)-MUS)**2 + Y(3)**2)

      YP(1) = Y(2)
      YP(2) = 2*Y(4) + Y(1) - MUS*(Y(1)+MU)/(R1**3) -
     & MU*(Y(1)-MUS)/(R2**3)

      YP(3) = Y(4)
      YP(4) = -2*Y(2) + Y(3) - MUS*Y(3)/(R1**3) -
     & MU*Y(3)/(R2**3)

      RETURN
      END


! Modified to add f_quartic and fprime_quartic for quartic function,
! and to add epsilon as a module variable.

module functions

    implicit none
    real(kind=8) :: epsilon
    save

contains

real(kind=8) function f_sqrt(x)
    implicit none
    real(kind=8), intent(in) :: x

    f_sqrt = x**2 - 4.d0

end function f_sqrt

real(kind=8) function fprime_sqrt(x)
    implicit none
    real(kind=8), intent(in) :: x

    fprime_sqrt = 2.d0 * x

end function fprime_sqrt

real(kind=8) function f_quartic(x)
    implicit none
    real(kind=8), intent(in) :: x

    f_quartic = (x - 1.d0)**4 - epsilon

end function f_quartic

real(kind=8) function fprime_quartic(x)
    implicit none
    real(kind=8), intent(in) :: x

    fprime_quartic = 4.d0 * (x - 1.d0)**3

end function fprime_quartic

end module functions


C     Polynomial Interpolation subroutine
C     Taken from "Numerical Recipes", 2nd Edition by Press, Teukolsky, Vetterling & Flannery.

      SUBROUTINE polint(xa,ya,n,x,y,dy)

      INTEGER n,NMAX
      REAL dy,x,y,xa(n),ya(n)
C	NMAX is the maximum anticipated polynomial order
      PARAMETER (NMAX=10)
      INTEGER i,m,ns
      REAL den,dif,dift,ho,hp,w,c(NMAX),d(NMAX)

      ns=1
      dif=abs(x-xa(1))
      do 11 i=1,n
        dift=abs(x-xa(i))
        if (dift.lt.dif) then
          ns=i
          dif=dift
        endif
        c(i)=ya(i)
        d(i)=ya(i)
11    continue
      y=ya(ns)
      ns=ns-1
      do 13 m=1,n-1
        do 12 i=1,n-m
          ho=xa(i)-x
          hp=xa(i+m)-x
          w=c(i+1)-d(i)
          den=ho-hp
          if(den.eq.0.)write(6,*)'WARNING: polint failed'
          den=w/den
          d(i)=hp*den
          c(i)=ho*den
12      continue
        if (2*ns.lt.n-m)then
          dy=c(ns+1)
        else
          dy=d(ns)
          ns=ns-1
        endif
        y=y+dy
13    continue
      return
      END


ccccccccccccccccccccccccccccccccccccccccccccccccccc
c      PROGRAM Quartic
      SUBROUTINE Quartic(q)
ccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Finds the roots of the quartic polynomial   c
c             a*q**4 + b*q**2 + c*q + d             c
ccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE

c     Variables
      COMPLEX*16 a, b, c, d, A1, B1, D1, D2, P, QPlus, QMin, q(4), F, G

c     PARAMETERS
      DOUBLE PRECISION One, Two, Four, Eight, Twelve, Twnt7, Sevnt2,
     $     Tto1O3, Tto2O3, Root6, amp
c     Integer-double Parameters
      PARAMETER(One = 1.d0, Two = 2.d0, Four = 4.d0, Eight = 8.d0)
      PARAMETER(Twelve = 12.d0, Twnt7 = 27.d0, Sevnt2 = 72.d0)
c     Irrational Parameters - Tto1O3 = 2**(1/3)
c                           - Tto1O3 = 2**(2/3)
c                           - Root6  = Sqrt(6)
      PARAMETER(Tto1O3 = 1.259921049894873, Tto2O3 = 1.587401051968199)
      PARAMETER(Root6 = 2.449489742783178)

      a = q(1)
      b = q(2)
      c = q(3)
      d = q(4)

c      a = 1.d0
c      b = 2.d0
c      c = 3.d0
c      d = 4.d0

      F  = b**2+ Twelve*a*d
      G  = Two*b**3 + Twnt7*a*c**2 - Sevnt2*a*b*d

      A1 = (G + SQRT(-Four*F**3 + G**2))**(1.d0/3.d0)
      B1 = Two*Tto1O3*F

      P  = SQRT( (-Four*b + B1/A1 + Tto2O3*A1)/a )

      D1 = Eight*b + B1/A1 + Tto2O3*A1
      D2 = Twelve*Root6*c/P

      QPlus = SQRT( -(D1 + D2)/a )
      QMin  = SQRT( -(D1 - D2)/a )

      amp = 1.d0/(Two*Root6)

      q(1) = amp*(P - QPlus)
      q(2) = amp*(P + QPlus)
      q(3) = -amp*(P + QMin)
      q(4) = amp*(-P + QMin)

c      PRINT*, q(1)
c      PRINT*, q(2)
c      PRINT*, q(3)
c      PRINT*, q(4)

      RETURN
      END


program sieve
    use iso_fortran_env
    implicit none

    integer(kind=int64), parameter:: i_max = 7812500
    integer(kind=int64), parameter:: b_max = 64*i_max
    integer(kind=int64), parameter:: n_max = 2*b_max+1
    integer(kind=int64), parameter:: n_up = sqrt(real(n_max))+1
    integer(kind=int64), parameter:: b_up = n_up/2

    integer(kind=int64):: i, j, b
    integer(kind=int64), dimension(i_max):: is_prime

    ! the b-th bit (0-63) of is_prime(i) contains whether
    ! 2*(64*(i-1)+b)+3 is a prime number or not.
    ! The sieve is done on odd numbers from 3 to
    ! 2*b_max+1.

    do b = 0, 63
        is_prime(1) = ibset(is_prime(1), b)
    enddo
    is_prime(2:i_max) = is_prime(1)

    do b = 1, b_up
        if (.not. btest(is_prime(1+(b-1)/64), mod(b-1, 64))) cycle
        do j = ((2*b+1)**2-1)/2, b_max, 2*b+1
            i = 1 + (j-1)/64
            is_prime(i) = ibclr(is_prime(i), mod(j-1, 64))
        end do
    end do

    open(unit=11, file='sieve.out')
    do b = 0, b_max-1
        if (btest(is_prime(1+b/64), mod(b, 64))) write(11, '(I10)') 2*b+3
    end do
    close(11)
end program sieve


PROGRAM trajectoire
	IMPLICIT NONE

	REAL :: t=0.
	INTEGER ::i, n !nombre d'itération
	REAL, PARAMETER :: xa=0., ya=10., u0=2., v0=0., deltat=0.1
	INTEGER, PARAMETER :: nmax=100000
	REAL, PARAMETER :: g=9.81
	REAL, DIMENSION(0:nmax) ::u, v, y, x

	u(0)=u0
	v(0)=v0
	x(0)=xa
	y(0)=ya

	i=0
	DO WHILE(y(i)>0.)
		i=i+1
		u(i)=u(i-1)
		v(i)=-g*deltat+v(i-1)
		x(i) = deltat*u(i)+x(i-1)
		y(i) = deltat*v(i)+y(i-1)
	END DO
	n = i

	PRINT*, "ti     xi     yi"
	DO i=0,n
		PRINT*, i*deltat, x(i), y(i)
	END DO

	PRINT*, "Le temps de chute est", n*deltat, "et la portée est", x(n)
END PROGRAM trajectoire


MODULE mc_toolbox

  !  Here one can specify parameters to be used  by the functions
  INTEGER(KIND=4), PARAMETER :: GSEED=12345
  REAL(KIND=8), PARAMETER :: MEANVAL=0.00
  REAL(KIND=8), PARAMETER :: SDEV=2.00

  CONTAINS
    FUNCTION rgamma(a)
      ! This function returns a random number with a Gamma PDF using
      ! the method described by Marsaglia and Tsang 2000.
      IMPLICIT NONE

      ! Data dictionary: Calling parameters
      REAL(KIND=8), INTENT(IN) :: a
      REAL(KIND=8)             :: rgamma

      ! Data dictionary: Local variables
      REAL(KIND=8)             :: d,c,v
      REAL(KIND=8)             :: x,u

      d = a-1./3.
      c = 1./SQRT(9.*d)
      rgamma = 0.
      DO
        v = 0.
        DO WHILE ( v .LE. 0. )
          x = R8_NORMAL_AB(MEANVAL,SDEV)
          v = 1. + c*x
        END DO
!        PRINT *, 'x=',x,'and v=',v
        v = v*v*v
!        u = RANDOM()
        CALL RANDOM_NUMBER(u)
        IF ( u .LT. 1.-0.331*(x*x)*(x*x) ) THEN
!          PRINT *, 'Success-1!'
          rgamma = (d*v)
          GOTO 10
        ELSE IF ( DLOG(u) .LT. 0.5*x*x+d*(1.-v+DLOG(v)) ) THEN
!          PRINT *, 'Success-2!'
          rgamma = (d*v)
          GOTO 10
        END IF
      END DO
10    RETURN
    END FUNCTION rgamma

FUNCTION r8_normal_01 ()
!*****************************************************************************80
!
!! R8_NORMAL_01 returns a unit pseudonormal R8.
!
!  Discussion:
!
!    The standard normal probability distribution function (PDF) has
!    mean 0 and standard deviation 1.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    06 August 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the random
!    number generator.
!
!    Output, real ( kind = 8 ) R8_NORMAL_01, a normally distributed
!    random value.
!
  implicit none

  real ( kind = 8 ) r1
  real ( kind = 8 ) r2
  real ( kind = 8 ) r8_normal_01
  real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
  real ( kind = 8 ) x

!  r1 = RANDOM()
!  r2 = RAND()
  ! Here we'll use a couple of random numbers generated using the built in
  ! RNG of the compiler and previously defined seed
  CALL RANDOM_NUMBER(r1)
  CALL RANDOM_NUMBER(r2)
  x = sqrt( - 2.0D+00 * DLOG( r1 ) ) * cos( 2.0D+00 * r8_pi * r2 )

  r8_normal_01 = x

  return
END FUNCTION r8_normal_01

FUNCTION r8_uniform_01 ( seedy )

!*****************************************************************************80
!
!! R8_UNIFORM_01 returns a unit pseudorandom R8.
!
!  Discussion:
!
!    This routine implements the recursion
!
!      seed = 16807 * seed mod ( 2^31 - 1 )
!      r8_uniform_01 = seed / ( 2^31 - 1 )
!
!    The integer arithmetic never requires more than 32 bits,
!    including a sign bit.
!
!    If the initial seed is 12345, then the first three computations are
!
!      Input     Output      R8_UNIFORM_01
!      SEED      SEED
!
!         12345   207482415  0.096616
!     207482415  1790989824  0.833995
!    1790989824  2035175616  0.947702
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    31 May 2007
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Paul Bratley, Bennett Fox, Linus Schrage,
!    A Guide to Simulation,
!    Second Edition,
!    Springer, 1987,
!    ISBN: 0387964673,
!    LC: QA76.9.C65.B73.
!
!    Bennett Fox,
!    Algorithm 647:
!    Implementation and Relative Efficiency of Quasirandom
!    Sequence Generators,
!    ACM Transactions on Mathematical Software,
!    Volume 12, Number 4, December 1986, pages 362-376.
!
!    Pierre L'Ecuyer,
!    Random Number Generation,
!    in Handbook of Simulation,
!    edited by Jerry Banks,
!    Wiley, 1998,
!    ISBN: 0471134031,
!    LC: T57.62.H37.
!
!    Peter Lewis, Allen Goodman, James Miller,
!    A Pseudo-Random Number Generator for the System/360,
!    IBM Systems Journal,
!    Volume 8, 1969, pages 136-143.
!
!  Parameters:
!
!    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
!    should NOT be 0.
!    On output, SEED has been updated.
!
!    Output, real ( kind = 8 ) R8_UNIFORM_01, a new pseudorandom variate,
!    strictly between 0 and 1.
!
  implicit none

  integer ( kind = 4 ) k
  real ( kind = 8 ) r8_uniform_01
  integer ( kind = 4 ) seedy

  PRINT *, '*******/Now in R8_UNIFORM_01/*******'
  PRINT *, 'Seed is:',seedy
  k = seedy / 127773
  PRINT *, 'k=',k
  seedy = 16807 * ( seedy - k * 127773 ) - k * 2836
  PRINT *, 'seedy now =',seedy

  if ( seedy < 0 ) then
    seedy = seedy + 2147483647
  end if
!
!  Although SEED can be represented exactly as a 32 bit integer,
!  it generally cannot be represented exactly as a 32 bit real number!
!
  r8_uniform_01 = real ( seedy, kind = 8 ) * 4.656612875D-10
  PRINT *, 'The uniform RN is:',r8_uniform_01
  return
END FUNCTION r8_uniform_01

FUNCTION r8_normal_ab ( a, b)
!*****************************************************************************80
!
!! R8_NORMAL_AB returns a scaled pseudonormal R8.
!
!  Discussion:
!
!    The normal probability distribution function (PDF) is sampled,
!    with mean A and standard deviation B.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    06 August 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = 8 ) A, the mean of the PDF.
!
!    Input, real ( kind = 8 ) B, the standard deviation of the PDF.
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the random
!    number generator.
!
!    Output, real ( kind = 8 ) R8_NORMAL_AB, a sample of the normal PDF.
!
  implicit none

  real ( kind = 8 ) a
  real ( kind = 8 ) b
  real ( kind = 8 ) r1
  real ( kind = 8 ) r2
  real ( kind = 8 ) r8_normal_ab
  real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
  real ( kind = 8 ) x

!  r1 = RANDOM()
  CALL RANDOM_NUMBER(r1)
  CALL RANDOM_NUMBER(r2)
!  r2 = RANDOM()
  x = sqrt ( - 2.0D+00 * log ( r1 ) ) * cos ( 2.0D+00 * r8_pi * r2 )

  r8_normal_ab = a + b * x

  return
END FUNCTION r8_normal_ab

END MODULE mc_toolbox


program demo_draw2
   use M_draw,    only : prefsize, vinit, ortho2, clear, getkey
   use M_draw,    only : move2, draw2, vexit, color,linewidth
   use M_draw,    only  : D_BLACK,   D_WHITE
   use M_draw,    only  : D_RED,     D_GREEN,    D_BLUE
   use M_draw,    only  : D_YELLOW,  D_MAGENTA,  D_CYAN
   !
   ! The Archimedean spiral is the locus of points corresponding
   ! to the locations over time of a point moving away from a
   ! fixed point with a constant speed along a line which rotates
   ! with constant angular velocity.
   !    r=A+B*theta
   ! Changing the parameter A will turn the spiral,
   ! while B controls the distance between successive turnings.
   !
   implicit none
   integer        :: i
   real           :: x,y,radius,theta
   real,parameter :: rotate=0.0, gap=2.0
   integer        :: ipaws

   call prefsize(400,400)
   call vinit(' ') ! start graphics using device $M_draw_DEVICE
   call ortho2(-150.0,150.0,-150.0,150.0)
   call color(D_MAGENTA)
   call clear()
   call move2(0.0,0.0)
   call color(D_BLACK)
   call linewidth(40)
   do i=0,360*10,5
      theta=d2r(real(i))
      ! equation in polar coordinates
      radius=rotate+gap*theta
      ! convert polar coordinates to cartesian
      call polar_to_cartesian(radius,theta,x,y)
      ! draw from current position to end of next segment
      call draw2(x,y)
   enddo
   ipaws=getkey()
   ! exit graphics mode
   call vexit()
contains
   elemental real function d2r(degrees)

      character(len=*),parameter::ident_6="@(#)M_units::d2r(3f): Convert degrees to radians"

      doubleprecision,parameter :: RADIAN=57.2957795131d0 ! degrees
      real,intent(in)           :: degrees                ! input degrees to convert to radians
      d2r=dble(degrees)/RADIAN                       ! do the unit conversion
   end function d2r
   subroutine polar_to_cartesian(radius,inclination,x,y)
      implicit none
      character(len=*),parameter::ident_21="@(#)M_units::polar_to_cartesian(3f): convert polar coordinates to cartesian coordinates"
      real,intent(in) :: radius,inclination
      real,intent(out)  :: x,y
      if(radius.eq.0)then
         x=0.0
         y=0.0
      else
         x=radius*cos(inclination)
         y=radius*sin(inclination)
      endif
   end subroutine polar_to_cartesian
end program demo_draw2


module mod_diff

    ! Module that provides finite difference functions.

    use iso_fortran_env, only: real32

    implicit none

    private
    public :: diffc, diffu

  contains

    pure function diffc(x) result(dx)
      ! Returns a centered difference of a 1-d array,
      ! with periodic boundary condition.
      real(real32), dimension(:), intent(in) :: x
      real(real32), dimension(:), allocatable :: dx
      integer :: i, idm

      idm = size(x)
      allocate(dx(idm))

      ! periodic boundary condition
      dx(1) = 0.5*(x(2)-x(idm))
      dx(idm) = 0.5*(x(1)-x(idm-1))

      do concurrent(i = 2:idm-1)
        dx(i) = 0.5 * (x(i+1) - x(i-1))
      end do

    end function diffc

    pure function diffu(x) result(dx)
    ! Returns an upstream difference of a 1-d array,
    ! with periodic boundary condition.
    real(real32), dimension(:), intent(in) :: x
    real(real32), dimension(:), allocatable :: dx
    integer :: i, idm

    idm = size(x)
    allocate(dx(idm))

    dx(1) = x(1) - x(idm)

    do concurrent(i = 2:idm)
      dx(2:idm) = x(2:idm) - x(1:idm-1)
    end do

  end function diffu

end module mod_diff