!*****************************************************************************************
!>
!  PIKAIA is a general purpose unconstrained optimization
!  method based on a genetic algorithm.
!  This is an object-oriented version of the algorithm for Fortran 2003/2008.
!
!# See also
!  * [Original description page](http://www.hao.ucar.edu/modeling/pikaia/pikaia.php)
!  * [Original sourcecode](http://download.hao.ucar.edu/archive/pikaia/)
!
!# License
!
!    Copyright (c) 2015-2020, Jacob Williams
!    http://github.com/jacobwilliams/pikaia
!
!    All rights reserved.
!
!    Redistribution and use in source and binary forms, with or without
!    modification, are permitted provided that the following conditions are met:
!    * Redistributions of source code must retain the above copyright notice, this
!      list of conditions and the following disclaimer.
!    * Redistributions in binary form must reproduce the above copyright notice,
!      this list of conditions and the following disclaimer in the documentation
!      and/or other materials provided with the distribution.
!    * Neither the name of pikaia nor the names of its
!      contributors may be used to endorse or promote products derived from
!      this software without specific prior written permission.
!
!    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
!    AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
!    IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
!    DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
!    FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
!    DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
!    SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
!    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
!    OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
!    OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
!    ------------------------------------------------------------------------------
!
!    The original version of the PIKAIA software is public domain software
!    and is available electronically from the High Altitude Observatory.
!    http://www.hao.ucar.edu/modeling/pikaia/pikaia.php
!
!
!# History
!  * Jacob Williams : 3/8/2015 : Significant refactoring of original PIKAIA code.
!    Converted to free-form source, double precision real variables, added various
!    new features, and an object-oriented interface.

    module pikaia_module

    use,intrinsic :: iso_fortran_env
    use mt19937_64
!$  use omp_lib

    implicit none

    private

    integer,parameter :: wp = real64  !! Default real kind [8 bytes].

    !*********************************************************
    type,public :: pikaia_class

        !! Main class for using the Pikaia algorithm.
        !! INIT and SOLVE are the only public methods.

        private

        integer :: n = 0  !number of solution variables
        real(wp),dimension(:),allocatable :: xl    !! lower bounds of `x`
        real(wp),dimension(:),allocatable :: xu    !! upper bound of `x`
        real(wp),dimension(:),allocatable :: del

        !other solution inputs (with default values):
        integer  :: np                 = 100
        integer  :: ngen               = 500
        integer  :: nd                 = 5
        real(wp) :: pcross             = 0.85_wp
        integer  :: imut               = 2
        real(wp) :: pmuti              = 0.005_wp  !! initial value of `pmut`
        real(wp) :: pmutmn             = 0.0005_wp
        real(wp) :: pmutmx             = 0.25_wp
        real(wp) :: fdif               = 1.0_wp
        integer  :: irep               = 1
        integer  :: ielite             = 1
        integer  :: ivrb               = 0
        real(wp) :: convergence_tol    = 0.0001_wp
        integer  :: convergence_window = 20
        integer  :: iseed              = 999
        real(wp) :: initial_guess_frac = 0.1_wp

        !used internally:
        real(wp) :: pmut   = -huge(1.0_wp)
        real(wp) :: bestft = huge(1.0_wp)
        real(wp) :: pmutpv = huge(1.0_wp)

        type(mt19937) :: rand !! random number generator

        !user-supplied procedures:
        procedure(pikaia_func),pointer :: user_f => null()  !! fitness function
        procedure(iter_func),pointer   :: iter_f => null()  !! reporting function (best member of population)

    contains

        !public routines:
        procedure,non_overridable,public :: init   => set_inputs
        procedure,non_overridable,public :: solve  => solve_with_pikaia

        !private routines:
        procedure,non_overridable :: ff  => func_wrapper  !! internal pikaia function (x:[0,1])
        procedure,non_overridable :: newpop
        procedure,non_overridable :: stdrep
        procedure,non_overridable :: genrep
        procedure,non_overridable :: adjmut
        procedure,non_overridable :: cross
        procedure,non_overridable :: encode
        procedure,non_overridable :: mutate
        procedure,non_overridable :: decode
        procedure,non_overridable :: select_parents
        procedure,non_overridable :: report
        procedure,non_overridable :: rnkpop
        procedure,non_overridable :: pikaia
        procedure,non_overridable :: rninit
        procedure,non_overridable :: urand

    end type pikaia_class
    !*********************************************************

    abstract interface

        subroutine pikaia_func(me,x,f)
            !! The interface for the function that pikaia will be maximizing.
        import :: wp,pikaia_class
        implicit none
        class(pikaia_class),intent(inout)  :: me    !! pikaia class
        real(wp),dimension(:),intent(in)   :: x     !! optimization variable vector
        real(wp),intent(out)               :: f     !! fitness value
        end subroutine pikaia_func

        subroutine iter_func(me,iter,x,f)
            !! The interface for the function that user can specify
            !! to report each iteration when pikaia is running.
            !! The best (fittest) population member is passed to
            !! this routine in each generation.
        import :: wp,pikaia_class
        implicit none
        class(pikaia_class),intent(inout)  :: me    !! pikaia class
        integer,intent(in)                 :: iter  !! iteration number
        real(wp),dimension(:),intent(in)   :: x     !! optimization variable vector
        real(wp),intent(in)                :: f     !! fitness value
        end subroutine iter_func

    end interface

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

!*****************************************************************************************
!> author: Jacob Williams
!
!  Constructor for the [[pikaia_class]].
!  The routine must be called before the solve routine can be used.
!
!  The following inputs are required: n, f, xl, xu.
!  For the others, if they are not present, then
!  the default values are used
!
!@note Based on setctl in the original code.

    subroutine set_inputs(me,&
                            n,xl,xu,f,status,&
                            iter_f,&
                            np,ngen,nd,pcross,pmutmn,pmutmx,pmut,imut,&
                            fdif,irep,ielite,ivrb,&
                            convergence_tol,convergence_window,initial_guess_frac,&
                            iseed)

    implicit none

    class(pikaia_class),intent(out)    :: me        !! pikaia class
    integer,intent(in)                 :: n         !! the parameter space dimension, i.e., the number
                                                    !! of adjustable parameters (size of the x vector).
    real(wp),dimension(n),intent(in)   :: xl        !! vector of lower bounds for x
    real(wp),dimension(n),intent(in)   :: xu        !! vector of upper bounds for x
    procedure(pikaia_func)             :: f         !! user-supplied scalar function of n variables,
                                                    !! which must have the [[pikaia_func]] procedure interface.
                                                    !! By convention, f should return higher values for more optimal
                                                    !! parameter values (i.e., individuals which are more "fit").
                                                    !! For example, in fitting a function through data points, f
                                                    !! could return the inverse of chi**2.
    integer,intent(out)                :: status    !! status output flag (0 if there were no errors)
    procedure(iter_func),optional      :: iter_f    !! user-supplied subroutine that will report the
                                                    !! best solution for each generation.
                                                    !! It must have the [[iter_func]] procedure interface.  If not present,
                                                    !! then it is not used.  (note: this is independent of ivrb).
    integer,intent(in),optional        :: np        !! number of individuals in a population (default is 100)
    integer,intent(in),optional        :: ngen      !! maximum number of iterations
    integer,intent(in),optional        :: nd        !! number of significant digits (i.e., number of
                                                    !! genes) retained in chromosomal encoding (default is 6).
    real(wp),intent(in),optional       :: pcross    !! crossover probability; must be  <= 1.0 (default
                                                    !! is 0.85). If crossover takes place, either one
                                                    !! or two splicing points are used, with equal
                                                    !! probabilities
    real(wp),intent(in),optional       :: pmutmn    !! minimum mutation rate; must be >= 0.0 (default is 0.0005)
    real(wp),intent(in),optional       :: pmutmx    !! maximum mutation rate; must be <= 1.0 (default is 0.25)
    real(wp),intent(in),optional       :: pmut      !! initial mutation rate; should be small (default
                                                    !! is 0.005) (Note: the mutation rate is the probability
                                                    !! that any one gene locus will mutate in
                                                    !! any one generation.)
    integer,intent(in),optional        :: imut      !! mutation mode; 1/2/3/4/5 (default is 2).
                                                    !!  1=one-point mutation, fixed rate.
                                                    !!  2=one-point, adjustable rate based on fitness.
                                                    !!  3=one-point, adjustable rate based on distance.
                                                    !!  4=one-point+creep, fixed rate.
                                                    !!  5=one-point+creep, adjustable rate based on fitness.
                                                    !!  6=one-point+creep, adjustable rate based on distance.
    real(wp),intent(in),optional       :: fdif      !! relative fitness differential; range from 0
                                                    !! (none) to 1 (maximum).  (default is 1.0)
    integer,intent(in),optional        :: irep      !! reproduction plan; 1/2/3=Full generational
                                                    !! replacement/Steady-state-replace-random/Steady-
                                                    !! state-replace-worst (default is 3)
    integer,intent(in),optional        :: ielite    !! elitism flag; 0/1=off/on (default is 0)
                                                    !! (Applies only to reproduction plans 1 and 2)
    integer,intent(in),optional        :: ivrb      !! printed output 0/1/2=None/Minimal/Verbose
                                                    !! (default is 0)
    real(wp),intent(in),optional       :: convergence_tol    !! convergence tolerance; must be > 0.0 (default is 0.0001)
    integer,intent(in),optional        :: convergence_window !! convergence window; must be >= 0
                                                             !! This is the number of consecutive solutions
                                                             !! within the tolerance for convergence to
                                                             !! be declared (default is 20)
    real(wp),intent(in),optional       :: initial_guess_frac !! fraction of the initial population
                                                             !! to set equal to the initial guess.  Range from 0
                                                             !! (none) to 1.0 (all). (default is 0.1 or 10%).
    integer,intent(in),optional        :: iseed              !! random seed value; must be > 0 (default is 999)

    me%n = n

    if (allocated(me%xl)) deallocate(me%xl)
    allocate(me%xl(n))
    me%xl = xl

    if (allocated(me%xu)) deallocate(me%xu)
    allocate(me%xu(n))
    me%xu = xu

    if (allocated(me%del)) deallocate(me%del)
    allocate(me%del(n))
    me%del = me%xu - me%xl

    me%user_f => f

    if (present(iter_f)) me%iter_f => iter_f

    if (present(np                 )) me%np                 = np
    if (present(ngen               )) me%ngen               = ngen
    if (present(nd                 )) me%nd                 = nd
    if (present(pcross             )) me%pcross             = pcross
    if (present(imut               )) me%imut               = imut
    if (present(pmut               )) me%pmuti              = pmut  !initial value
    if (present(pmutmn             )) me%pmutmn             = pmutmn
    if (present(pmutmx             )) me%pmutmx             = pmutmx
    if (present(fdif               )) me%fdif               = fdif
    if (present(irep               )) me%irep               = irep
    if (present(ielite             )) me%ielite             = ielite
    if (present(ivrb               )) me%ivrb               = ivrb
    if (present(convergence_tol    )) me%convergence_tol    = convergence_tol
    if (present(convergence_window )) me%convergence_window = convergence_window
    if (present(initial_guess_frac )) me%initial_guess_frac = initial_guess_frac
    if (present(iseed              )) me%iseed              = iseed

    !check for errors:

    !initialize error flag:
    status = 0

    !Print a header
    if (me%ivrb>0) then
        write(output_unit,'(A)') '------------------------------------------------------------'
        write(output_unit,'(A)') '              PIKAIA Genetic Algorithm Report               '
        write(output_unit,'(A)') '------------------------------------------------------------'
        write(output_unit,'(A,I4)')    ' Number of Generations evolving: ',me%ngen
        write(output_unit,'(A,I4)')    '     Individuals per generation: ',me%np
        write(output_unit,'(A,I4)')    '  Number of Chromosome segments: ',me%n
        write(output_unit,'(A,I4)')    '  Length of Chromosome segments: ',me%nd
        write(output_unit,'(A,E11.4)') '          Crossover probability: ',me%pcross
        write(output_unit,'(A,E11.4)') '          Initial mutation rate: ',me%pmuti
        write(output_unit,'(A,E11.4)') '          Minimum mutation rate: ',me%pmutmn
        write(output_unit,'(A,E11.4)') '          Maximum mutation rate: ',me%pmutmx
        write(output_unit,'(A,E11.4)') '  Relative fitness differential: ',me%fdif
        write(output_unit,'(A,E11.4)') '         Initial guess fraction: ',me%initial_guess_frac
        write(output_unit,'(A,E11.4)') '          Convergence tolerance: ',me%convergence_tol
        write(output_unit,'(A,I4)')    '             Convergence window: ',me%convergence_window
        select case (me%imut)
        case(1); write(output_unit,'(A)') '                  Mutation Mode: Uniform, Constant Rate'
        case(2); write(output_unit,'(A)') '                  Mutation Mode: Uniform, Variable Rate (F)'
        case(3); write(output_unit,'(A)') '                  Mutation Mode: Uniform, Variable Rate (D)'
        case(4); write(output_unit,'(A)') '                  Mutation Mode: Uniform+Creep, Constant Rate'
        case(5); write(output_unit,'(A)') '                  Mutation Mode: Uniform+Creep, Variable Rate (F)'
        case(6); write(output_unit,'(A)') '                  Mutation Mode: Uniform+Creep, Variable Rate (D)'
        end select
        select case (me%irep)
        case(1); write(output_unit,'(A)') '              Reproduction Plan: Full generational replacement'
        case(2); write(output_unit,'(A)') '              Reproduction Plan: Steady-state-replace-random'
        case(3); write(output_unit,'(A)') '              Reproduction Plan: Steady-state-replace-worst'
        end select
        write(output_unit,'(A)') '------------------------------------------------------------'
    end if

    !Check some control values
    if (me%imut/=1 .and. me%imut/=2 .and. me%imut/=3 .and. &
          me%imut/=4 .and. me%imut/=5 .and. me%imut/=6) then
       write(output_unit,'(A)') ' ERROR: illegal value for Mutation Mode.'
       status = 5
    end if

    if (me%fdif>1.0_wp) then
       write(output_unit,'(A)') ' ERROR: illegal value for Relative fitness differential.'
       status = 9
    end if

    if (me%irep/=1 .and. me%irep/=2 .and. me%irep/=3) then
       write(output_unit,'(A)') ' ERROR: illegal value for Reproduction plan.'
       status = 10
    end if

    if (me%pcross>1.0_wp .or. me%pcross<0.0_wp) then
       write(output_unit,'(A)') ' ERROR: illegal value for Crossover probability.'
       status = 4
    end if

    if (me%ielite/=0 .and. me%ielite/=1) then
       write(output_unit,'(A)') ' ERROR: illegal value for Elitism flag.'
       status = 11
    end if

    if (me%convergence_tol<=0.0_wp) then
        write(output_unit,'(A)') ' ERROR: illegal value for Convergence tolerance.'
        status = 101
    end if

    if (me%convergence_window<=0) then
        write(output_unit,'(A)') ' ERROR: illegal value for Convergence window.'
        status = 102
    end if

    if (me%iseed<=0) then
        write(output_unit,'(A)') ' ERROR: illegal value for iseed.'
        status = 103
    end if

    if (me%nd>9 .or. me%nd<1) then
        write(output_unit,'(A)') ' ERROR: illegal value for Chromosome length.'
        status = 104
    end if

    if (mod(me%np,2)>0) then
       write(output_unit,'(A)') ' ERROR: population size must be an even number.'
       status = 105
    end if

    if (me%initial_guess_frac<0.0_wp .or. me%initial_guess_frac>1.0_wp) then
       write(output_unit,'(A)') ' ERROR: illegal value for Initial guess fraction.'
       status = 106
    end if

    if (me%irep==1 .and. me%imut==1 .and. me%pmuti>0.5_wp .and. me%ielite==0) then
       write(output_unit,'(A)') &
        ' WARNING: dangerously high value for Initial mutation rate; '//&
        '(Should enforce elitism with ielite=1.)'
    end if

    if (me%irep==1 .and. me%imut==2 .and. me%pmutmx>0.5_wp .and. me%ielite==0) then
       write(output_unit,'(A)') &
       ' WARNING: dangerously high value for Maximum mutation rate; '//&
       '(Should enforce elitism with ielite=1.)'
    end if

    if (me%fdif<0.33_wp .and. me%irep/=3) then
       write(output_unit,'(A)') &
       ' WARNING: dangerously low value of Relative fitness differential.'
    end if

    end subroutine set_inputs
!*****************************************************************************************

!*****************************************************************************************
!>
!  Optimization (maximization) of user-supplied "fitness" function
!  over n-dimensional parameter space x using a basic genetic
!  algorithm method.
!
!  Genetic algorithms are heuristic search techniques that
!  incorporate in a computational setting, the biological notion
!  of evolution by means of natural selection.  This subroutine
!  implements the three basic operations of selection, crossover,
!  and mutation, operating on "genotypes" encoded as strings.
!
!  Version 1.2 differs from version 1.0 (December 1995) in that
!  it includes (1) two-point crossover, (2) creep mutation, and
!  (3) dynamical adjustment of the mutation rate based on metric
!  distance in parameter space.
!
!# Authors
!   * Paul Charbonneau & Barry Knapp
!     (High Altitude Observatory, National Center for Atmospheric Research)
!     Version 1.2 [ 2002 April 3 ]
!   * Jacob Williams : 3/8/3015 : Refactoring and some new features.
!
!# References
!   * Charbonneau, Paul. "An introduction to genetic algorithms for
!     numerical optimization", NCAR Technical Note TN-450+IA
!     (April 2002)
!   * Charbonneau, Paul. "Release Notes for PIKAIA 1.2",
!     NCAR Technical Note TN-451+STR (April 2002)
!   * Charbonneau, Paul, and Knapp, Barry. "A User's Guide
!     to PIKAIA 1.0" NCAR Technical Note TN-418+IA
!     (December 1995)
!   * Goldberg, David E.  Genetic Algorithms in Search, Optimization,
!     & Machine Learning.  Addison-Wesley, 1989.
!   * Davis, Lawrence, ed.  Handbook of Genetic Algorithms.
!     Van Nostrand Reinhold, 1991.

    subroutine pikaia(me,x,f,status)

    implicit none

    !subroutine arguments:
    class(pikaia_class),intent(inout)      :: me
    real(wp),dimension(:),intent(inout)    :: x      !! Input - initial guess for solution vector.
                                                     !! Output - the "fittest" (optimal) solution found,
                                                     !! i.e., the solution which maximizes the fitness function.
    real(wp),intent(out)                   :: f      !! the (scalar) value of the fitness function at x
    integer,intent(out)                    :: status !! an indicator of the success or failure
                                                     !! of the call to pikaia (0=success; non-zero=failure)

    !Local variables
    integer  :: k,ip,ig,ip1,ip2,new,newtot,istart,i_window,j
    real(wp) :: current_best_f, last_best_f, fguess
    logical  :: convergence
    logical  :: use_openmp !! if OpenMP is being used
    real(wp),dimension(me%n,2,me%np/2) :: ph
    real(wp),dimension(me%n,me%np)     :: oldph
    real(wp),dimension(me%n,me%np)     :: newph
    integer,dimension(me%n*me%nd)      :: gn1
    integer,dimension(me%n*me%nd)      :: gn2
    integer,dimension(me%np)           :: ifit
    integer,dimension(me%np)           :: jfit
    real(wp),dimension(me%np)          :: fitns
    real(wp),dimension(me%n)           :: xguess
    real(wp),dimension(2,me%np/2)      :: fits

    real(wp),parameter :: big = huge(1.0_wp)    !! a large number

    !initialize:
    call me%rninit()
    me%bestft   = -big
    me%pmutpv   = -big
    me%pmut     = me%pmuti  !set initial mutation rate (it can change)
    i_window    = 0
    last_best_f = -big
    convergence = .false.
    status      = 0

    ! if OpenMP is being used:
    use_openmp = .false.
!$  use_openmp = .true.

    !Handle the initial guess:
    if (me%initial_guess_frac==0.0_wp) then

        !initial guess not used (totally random population)

        istart = 1  !index to start random population members

    else

        !use the initial guess:

        xguess = x
        do k=1,me%n    !make sure they are all within the [0,1] bounds
            xguess(k) = max( 0.0_wp, min(1.0_wp,xguess(k)) )
        end do
        call me%ff(xguess,fguess)

        !how many elements in the population to set to xguess?:
        ! [at least 1, at most n]
        istart = max(1, min(me%np, int(me%np * me%initial_guess_frac)))

        do k=1,istart
            oldph(:,k) = xguess
            fitns(k)   = fguess
        end do

        istart = istart + 1  !index to start random population members

    end if

    !Compute initial (random but bounded) phenotypes
    do ip=istart,me%np
       do k=1,me%n
          oldph(k,ip) = me%urand()  !from [0,1]
       end do
    end do

    !$omp parallel do private(ip)
    do ip=istart,me%np
       call me%ff(oldph(:,ip),fitns(ip))
    end do
    !$omp end parallel do

    !Rank initial population by fitness order
    call me%rnkpop(fitns,ifit,jfit)

    !Main Generation Loop
    ! This is modified from the original for parallelization.
    ! Note that, now, in a generation, the population is not changed until
    ! all the new members are computed. So only the current members are used
    ! in this process.
    do ig=1,me%ngen

        !Main Population Loop
        newtot = 0
        do ip=1,me%np/2

            !1. pick two parents
            call me%select_parents(jfit,ip1,ip2)

            !2. encode parent phenotypes
            call me%encode(oldph(:,ip1),gn1)
            call me%encode(oldph(:,ip2),gn2)

            !3. breed
            call me%cross(gn1,gn2)
            call me%mutate(gn1)
            call me%mutate(gn2)

            !4. decode offspring genotypes
            call me%decode(gn1,ph(:,1,ip))
            call me%decode(gn2,ph(:,2,ip))

            !5. insert into population
            if (me%irep==1) then
                call me%genrep(ip,ph(:,:,ip),newph)
            else
                if (.not. use_openmp) then
                    ! compute all the fitnesses in the parallel
                    do j = 1, 2
                        ! compute offspring fitness (with caller's fitness function)
                        call me%ff(ph(:,j,ip),fits(j,ip))
                    end do
                    call me%stdrep(ph(:,:,ip),fits(:,ip),oldph,fitns,ifit,jfit,new)
                    newtot = newtot+new
               end if
            end if

        end do

        if (use_openmp) then
            !5. insert into population if not already done
            if (me%irep/=1) then
                ! compute all the fitnesses in the parallel
                !$omp parallel do private(ip)
                do ip=1,me%np/2
                    !$omp parallel do private(j)
                    do j = 1, 2
                        ! compute offspring fitness (with caller's fitness function)
                        call me%ff(ph(:,j,ip),fits(j,ip))
                    end do
                    !$omp end parallel do
                end do
                !$omp end parallel do
                newtot=0
                do ip=1,me%np/2
                    call me%stdrep(ph(:,:,ip),fits(:,ip),oldph,fitns,ifit,jfit,new)
                    newtot = newtot+new
                end do
            end if
        end if
        !End of Main Population Loop

        !if running full generational replacement: swap populations
        if (me%irep==1) call me%newpop(oldph,newph,ifit,jfit,fitns,newtot)

        !adjust mutation rate?
        if (any(me%imut==[2,3,5,6])) call adjmut(me,oldph,fitns,ifit)

        !report this iteration:
        if (me%ivrb>0) call me%report(oldph,fitns,ifit,ig,newtot)

        !report (unscaled) x:
        if (associated(me%iter_f)) &
            call me%iter_f(ig,me%xl+me%del*oldph(1:me%n,ifit(me%np)),fitns(ifit(me%np)))

        !JW additions: add a convergence criteria
        ! [stop if the last convergence_window iterations are all within the convergence_tol]
        current_best_f = fitns(ifit(me%np))    !current iteration best fitness
        if (abs(current_best_f-last_best_f)<=me%convergence_tol) then
            !this solution is within the tol from the previous one
            i_window = i_window + 1    !number of solutions within the convergence tolerance
        else
            i_window = 0    !a significantly better solution was found, reset window
        end if
        if (i_window>=me%convergence_window) then
            convergence = .true.
            exit !exit main loop -> convergence
        end if
        last_best_f = current_best_f    !to compare with next iteration

    end do    !End of Main Generation Loop

    !JW additions:
    if (me%ivrb>0) then
        if (convergence) then
            write(output_unit,'(A)') 'Solution Converged'
        else
            write(output_unit,'(A)') 'Iteration Limit Reached'
        end if
    end if

    !Return best phenotype and its fitness
    x = oldph(1:me%n,ifit(me%np))
    f = fitns(ifit(me%np))

    end subroutine pikaia
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!
!  Main pikaia wrapper used by the class.

    subroutine solve_with_pikaia(me,x,f,status)

    implicit none

    class(pikaia_class),intent(inout)   :: me
    real(wp),dimension(:),intent(inout) :: x
    real(wp),intent(out)                :: f
    integer,intent(out)                 :: status

    if (associated(me%user_f)) then

        !scale input initial guess to be [0,1]:
        x = (x-me%xl)/me%del

        !call the main routine, using the wrapper function:
        call me%pikaia(x,f,status)

        !unscale output to be [xl,xu]:
        x = me%xl + me%del*x

    else

        write(output_unit,'(A)') 'Error: pikaia class not initialized.'
        status = -1

    end if

    end subroutine solve_with_pikaia
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!
!  Wrapper for the user's function that is used by the main pikaia routine
!  The x input to this function comes from pikaia, and will be between [0,1].

    subroutine func_wrapper(me,x,f)

    implicit none

    class(pikaia_class),intent(inout) :: me   ! pikaia class
    real(wp),dimension(:),intent(in)  :: x    ! optimization variable vector [0,1]
    real(wp),intent(out)              :: f    ! fitness value

    real(wp),dimension(me%n) :: xp    !unscaled x vector: [xu,xl]

    !map each x variable from [0,1] to [xl,xu]:
    xp = me%xl + me%del*x

    !call the user's function with xp:
    call me%user_f(xp,f)

    end subroutine func_wrapper
!*****************************************************************************************

!*****************************************************************************************
!> author: B. G. Knapp
!  date: 86/12/23
!
!  Return integer array p which indexes array a in increasing order.
!  Array a is not disturbed.  The Quicksort algorithm is used.
!
!# Reference
!   * N. Wirth, "Algorithms and Data Structures", Prentice-Hall, 1986

    subroutine rqsort(n,a,p)

    implicit none

    integer,intent(in)               :: n
    real(wp),dimension(n),intent(in) :: a
    integer,dimension(n),intent(out) :: p

    !Constants
    integer,parameter :: LGN = 32      !! log base 2 of maximum n
    integer,parameter :: Q   = 11      !! smallest subfile to use quicksort on

    !Local:
    integer,dimension(LGN) :: stackl,stackr
    real(wp) :: x
    integer :: s,t,l,m,r,i,j

    !Initialize the stack
    stackl(1) = 1
    stackr(1) = n
    l = stackl(1)
    r = stackr(1)
    s = 1

    !Initialize the pointer array
    p = [(i, i=1,n)]

    do while (s>0)

        s = s - 1

        if ((r-l)<Q) then

            !Use straight insertion
            insertion: do i=l+1,r
                t = p(i)
                x = a(t)
                do j=i-1,l,-1
                    if (a(p(j))<=x) then
                        p(j+1) = t
                        cycle insertion
                    end if
                    p(j+1) = p(j)
                end do
                j=l-1
                p(j+1) = t
            end do insertion

        else

            !Use quicksort, with pivot as median of a(l), a(m), a(r)
            m=(l+r)/2
            t=p(m)
            if (a(t)<a(p(l))) then
                p(m)=p(l)
                p(l)=t
                t=p(m)
            end if
            if (a(t)>a(p(r))) then
                p(m)=p(r)
                p(r)=t
                t=p(m)
                if (a(t)<a(p(l))) then
                    p(m)=p(l)
                    p(l)=t
                    t=p(m)
                end if
            end if

            !Partition
            x=a(t)
            i=l+1
            j=r-1
            do while (i<=j)

                do while (a(p(i))<x)
                    i=i+1
                end do

                do while (x<a(p(j)))
                    j=j-1
                end do

                if (i<=j) then
                    t=p(i)
                    p(i)=p(j)
                    p(j)=t
                    i=i+1
                    j=j-1
                end if

            end do

            !Stack the larger subfile
            s=s+1
            if ((j-l)>(r-i)) then
                stackl(s)=l
                stackr(s)=j
                l=i
            else
                stackl(s)=i
                stackr(s)=r
                r=j
            end if

            s = s + 1 ! since it will be decremented next cycle
            cycle
        end if

        l = stackl(s)
        r = stackr(s)

    end do

    end subroutine rqsort
!*****************************************************************************************

!*****************************************************************************************
!>
!  Return the next pseudo-random deviate from a sequence which is
!  uniformly distributed in the interval [0,1]

    function urand(me) result(r)

    implicit none

    class(pikaia_class),intent(inout) :: me

    real(wp) :: r

    r = me%rand%genrand64_real1()

    end function urand
!*****************************************************************************************

!*****************************************************************************************
!>
!  Initialize the random number generator with the input seed value.

    subroutine rninit(me)

    implicit none

    class(pikaia_class),intent(inout) :: me

    call me%rand%initialize(me%iseed)

    end subroutine rninit
!*****************************************************************************************

!*****************************************************************************************
!>
!  Write generation report to standard output

    subroutine report(me,oldph,fitns,ifit,ig,nnew)

    implicit none

    class(pikaia_class),intent(inout)         :: me
    real(wp),dimension(me%n,me%np),intent(in) :: oldph
    real(wp),dimension(me%np),intent(in)      :: fitns
    integer,dimension(me%np),intent(in)       :: ifit
    integer,intent(in)                        :: ig
    integer,intent(in)                        :: nnew

    integer :: ndpwr,k
    logical :: rpt

    rpt=.false.

    if (me%pmut/=me%pmutpv) then
       me%pmutpv=me%pmut
       rpt=.true.
    end if

    if (fitns(ifit(me%np))/=me%bestft) then
       me%bestft=fitns(ifit(me%np))
       rpt=.true.
    end if

    if (rpt .or. me%ivrb>=2) then

        !Power of 10 to make integer genotypes for display
        ndpwr = 10**me%nd

        write(output_unit,'(/I6,I6,F10.6,4F10.6)') &
            ig,nnew,me%pmut,fitns(ifit(me%np)),&
            fitns(ifit(me%np-1)),fitns(ifit(me%np/2))

        do k=1,me%n
            write(output_unit,'(22X,3I10)') &
                    nint(ndpwr*oldph(k,ifit(me%np))),&
                    nint(ndpwr*oldph(k,ifit(me%np-1))),&
                    nint(ndpwr*oldph(k,ifit(me%np/2)))
        end do

    end if

    end subroutine report
!*****************************************************************************************

!*****************************************************************************************
!>
!  Encode phenotype parameters into integer genotype
!  ph(k) are x,y coordinates [ 0 < x,y < 1 ]

    subroutine encode(me,ph,gn)

    implicit none

    class(pikaia_class),intent(in)            :: me
    real(wp),dimension(me%n),intent(in)       :: ph
    integer,dimension(me%n*me%nd),intent(out) :: gn

    integer  :: ip,i,j,ii
    real(wp) :: z

    z=10.0_wp**me%nd
    ii=0
    do i=1,me%n
        ip=int(ph(i)*z)
        do j=me%nd,1,-1
            gn(ii+j)=mod(ip,10)
            ip=ip/10
        end do
        ii=ii+me%nd
    end do

    end subroutine encode
!*****************************************************************************************

!*****************************************************************************************
!>
!  decode genotype into phenotype parameters
!  ph(k) are x,y coordinates [ 0 < x,y < 1 ]

    subroutine decode(me,gn,ph)

    implicit none

    class(pikaia_class),intent(in)           :: me
    integer,dimension(me%n*me%nd),intent(in) :: gn
    real(wp),dimension(me%n),intent(out)     :: ph

    integer  :: ip,i,j,ii
    real(wp) :: z

    z=10.0_wp**(-me%nd)
    ii=0
    do i=1,me%n
        ip=0
        do j=1,me%nd
            ip=10*ip+gn(ii+j)
        end do
        ph(i)=ip*z
        ii=ii+me%nd
    end do

    end subroutine decode
!*****************************************************************************************

!*****************************************************************************************
!>
!  breeds two parent chromosomes into two offspring chromosomes.
!  breeding occurs through crossover. If the crossover probability
!  test yields true (crossover taking place), either one-point or
!  two-point crossover is used, with equal probabilities.
!
!@note Compatibility with version 1.0: To enforce 100% use of one-point
!      crossover, un-comment appropriate line in source code below

    subroutine cross(me,gn1,gn2)

    implicit none

    class(pikaia_class),intent(inout)           :: me
    integer,dimension(me%n*me%nd),intent(inout) :: gn1
    integer,dimension(me%n*me%nd),intent(inout) :: gn2

    integer :: i, ispl, ispl2, itmp, t

    !Use crossover probability to decide whether a crossover occurs
    if (me%urand()<me%pcross) then

        !Compute first crossover point
        ispl=int(me%urand()*me%n*me%nd)+1

        !Now choose between one-point and two-point crossover
        if (me%urand()<0.5_wp) then
            ispl2=me%n*me%nd
        else
            ispl2=int(me%urand()*me%n*me%nd)+1
            !Un-comment following line to enforce one-point crossover
            !ispl2=me%n*me%nd
            if (ispl2<ispl) then
                itmp=ispl2
                ispl2=ispl
                ispl=itmp
            end if
        end if

        !Swap genes from ispl to ispl2
        do i=ispl,ispl2
            t=gn2(i)
            gn2(i)=gn1(i)
            gn1(i)=t
        end do

    end if

    end subroutine cross
!*****************************************************************************************

!*****************************************************************************************
!>
!  Introduces random mutation in a genotype.
!  Mutations occur at rate pmut at all gene loci.
!
!# Input
!   * imut=1    Uniform mutation, constant rate
!   * imut=2    Uniform mutation, variable rate based on fitness
!   * imut=3    Uniform mutation, variable rate based on distance
!   * imut=4    Uniform or creep mutation, constant rate
!   * imut=5    Uniform or creep mutation, variable rate based on fitness
!   * imut=6    Uniform or creep mutation, variable rate based on distance

    subroutine mutate(me,gn)

    implicit none

    class(pikaia_class),intent(inout)           :: me
    integer,dimension(me%n*me%nd),intent(inout) :: gn

    integer :: i,j,k,l,ist,inc,loc
    logical :: fix

    !Decide which type of mutation is to occur
    if (me%imut>=4 .and. me%urand()<=0.5_wp) then

        !CREEP MUTATION OPERATOR
        !Subject each locus to random +/- 1 increment at the rate pmut
        do i=1,me%n
            do j=1,me%nd

                if (me%urand()<me%pmut) then

                    !Construct integer
                    loc=(i-1)*me%nd+j
                    inc=nint( me%urand() )*2-1
                    ist=(i-1)*me%nd+1
                    gn(loc)=gn(loc)+inc

                    !This is where we carry over the one (up to two digits)
                    !first take care of decrement below 0 case
                    if (inc<0 .and. gn(loc)<0) then
                        if (j==1) then
                            gn(loc)=0
                        else
                            fix = .true.
                            do k=loc,ist+1,-1
                                gn(k)=9
                                gn(k-1)=gn(k-1)-1
                                if ( gn(k-1)>=0 ) then
                                    fix = .false.
                                    exit
                                end if
                            end do
                            if (fix) then
                                !we popped under 0.00000 lower bound; fix it up
                                if ( gn(ist)<0) then
                                    do l=ist,loc
                                        gn(l)=0
                                    end do
                                end if
                            end if
                        end if
                    end if

                    if (inc>0 .and. gn(loc)>9) then
                        if (j==1) then
                            gn(loc)=9
                        else
                            fix = .true.
                            do k=loc,ist+1,-1
                                gn(k)=0
                                gn(k-1)=gn(k-1)+1
                                if ( gn(k-1)<=9 ) then
                                    fix = .false.
                                    exit
                                end if
                            end do
                            if (fix) then
                                !we popped over 9.99999 upper bound; fix it up
                                if ( gn(ist)>9 ) then
                                    do l=ist,loc
                                        gn(l)=9
                                    end do
                                end if
                            end if
                        end if
                    end if

                end if

            end do
        end do

    else

        !UNIFORM MUTATION OPERATOR
        !Subject each locus to random mutation at the rate pmut
        do i=1,me%n*me%nd
            if (me%urand()<me%pmut) then
                gn(i)=int(me%urand()*10.0_wp)
            end if
        end do

    end if

    end subroutine mutate
!*****************************************************************************************

!*****************************************************************************************
!>
!  Dynamical adjustment of mutation rate:
!
!   * imut=2 or imut=5 : adjustment based on fitness differential
!     between best and median individuals
!   * imut=3 or imut=6 : adjustment based on metric distance
!     between best and median individuals

    subroutine adjmut(me,oldph,fitns,ifit)

    implicit none

    class(pikaia_class),intent(inout)         :: me
    integer,dimension(me%np),intent(in)       :: ifit
    real(wp),dimension(me%n,me%np),intent(in) :: oldph
    real(wp),dimension(me%np),intent(in)      :: fitns

    integer  :: i
    real(wp) :: rdif

    real(wp),parameter :: rdiflo = 0.05_wp
    real(wp),parameter :: rdifhi = 0.25_wp
    real(wp),parameter :: delta  = 1.5_wp

    if (me%imut==2 .or. me%imut==5) then

        !Adjustment based on fitness differential
        rdif = abs(fitns(ifit(me%np)) - &
               fitns(ifit(me%np/2)))/(fitns(ifit(me%np)) + &
               fitns(ifit(me%np/2)))

    else if (me%imut==3 .or. me%imut==6) then

        !Adjustment based on normalized metric distance
        rdif=0.0_wp
        do i=1,me%n
            rdif=rdif+( oldph(i,ifit(me%np))-oldph(i,ifit(me%np/2)) )**2
        end do
        rdif=sqrt( rdif ) / real(me%n,wp)

    end if

    if (rdif<=rdiflo) then
        me%pmut=min(me%pmutmx,me%pmut*delta)
    else if (rdif>=rdifhi) then
        me%pmut=max(me%pmutmn,me%pmut/delta)
    end if

    end subroutine adjmut
!*****************************************************************************************

!*****************************************************************************************
!>
!  Selects two parents from the population, using roulette wheel
!  algorithm with the relative fitnesses of the phenotypes as
!  the "hit" probabilities.
!
!# Reference
!  * Davis 1991, chap. 1.
!
!# History
!  * Jacob Williams : 3/10/2015 : rewrote this routine to return both parents,
!    and also protect against the loop exiting without selecting a parent.

    subroutine select_parents(me,jfit,imom,idad)

    implicit none

    class(pikaia_class),intent(inout)   :: me
    integer,dimension(me%np),intent(in) :: jfit
    integer,intent(out)                 :: imom
    integer,intent(out)                 :: idad

    integer  :: np1,i,j
    real(wp) :: dice,rtfit
    integer,dimension(2) :: parents

    !initialize:
    np1 = me%np+1
    parents = -99

    !get two (unequal) parents:
    do j=1,2
        main: do
            dice = me%urand()*me%np*np1
            rtfit = 0.0_wp
            do i=1,me%np
                rtfit = rtfit+np1+me%fdif*(np1-2*jfit(i))
                if (rtfit>=dice) then
                    parents(j) = i
                    if (parents(1)/=parents(2)) exit main
                end if
            end do
        end do main
    end do

    imom = parents(1)
    idad = parents(2)

    end subroutine select_parents
!*****************************************************************************************

!*****************************************************************************************
!>
!  Ranks initial population.
!  Calls external sort routine to produce key index and rank order
!  of input array arrin (which is not altered).

    subroutine rnkpop(me,arrin,indx,rank)

    implicit none

    class(pikaia_class),intent(inout)     :: me
    real(wp),dimension(me%np),intent(in)  :: arrin
    integer,dimension(me%np),intent(out)  :: indx
    integer,dimension(me%np),intent(out)  :: rank

    integer :: i

    !Compute the key index
    call rqsort(me%np,arrin,indx)

    !and the rank order
    do i=1,me%np
        rank(indx(i)) = me%np-i+1
    end do

    end subroutine rnkpop
!*****************************************************************************************

!*****************************************************************************************
!>
!  Full generational replacement: accumulate offspring into new
!  population array

    subroutine genrep(me,ip,ph,newph)

    implicit none

    class(pikaia_class),intent(inout)          :: me
    integer,intent(in)                         :: ip
    real(wp),dimension(me%n,2),intent(in)      :: ph
    real(wp),dimension(me%n,me%np),intent(out) :: newph

    integer :: i1,i2,k

    !Insert one offspring pair into new population
    i1=2*ip-1
    i2=i1+1
    do k=1,me%n
        newph(k,i1)=ph(k,1)
        newph(k,i2)=ph(k,2)
    end do

    end subroutine genrep
!*****************************************************************************************

!*****************************************************************************************
!>
!  Steady-state reproduction: insert offspring pair into population
!  only if they are fit enough (replace-random if irep=2 or
!  replace-worst if irep=3).

    subroutine stdrep(me,ph,fits,oldph,fitns,ifit,jfit,nnew)

    implicit none

    class(pikaia_class),intent(inout)             :: me
    real(wp),dimension(me%n,2),intent(in)         :: ph
    real(wp),dimension(2),intent(in)              :: fits
    real(wp),dimension(me%n,me%np),intent(inout)  :: oldph
    real(wp),dimension(me%np),intent(inout)       :: fitns
    integer,dimension(me%np),intent(inout)        :: ifit
    integer,dimension(me%np),intent(inout)        :: jfit
    integer,intent(out)                           :: nnew

    integer  :: i,j,k,i1,if1
    real(wp) :: fit

    nnew = 0
    main_loop : do j=1,2

        !1. get offspring fitness
        fit = fits(j)

        !2. if fit enough, insert in population
        do i=me%np,1,-1

            if (fit>fitns(ifit(i))) then

                !make sure the phenotype is not already in the population
                if (i<me%np) then
                    if (all(oldph(1:me%n,ifit(i+1))==ph(1:me%n,j))) cycle main_loop
                end if

                !offspring is fit enough for insertion, and is unique

                !(i) insert phenotype at appropriate place in population
                if (me%irep==3) then
                    i1=1
                else if (me%ielite==0 .or. i==me%np) then
                    i1=int(me%urand()*me%np)+1
                else
                    i1=int(me%urand()*(me%np-1))+1
                end if
                if1 = ifit(i1)
                fitns(if1)=fit
                do k=1,me%n
                    oldph(k,if1)=ph(k,j)
                end do

                !(ii) shift and update ranking arrays
                if (i<i1) then

                    !shift up
                    jfit(if1)=me%np-i
                    do k=i1-1,i+1,-1
                        jfit(ifit(k))=jfit(ifit(k))-1
                        ifit(k+1)=ifit(k)
                    end do
                    ifit(i+1)=if1

                else

                    !shift down
                    jfit(if1)=me%np-i+1
                    do k=i1+1,i
                        jfit(ifit(k))=jfit(ifit(k))+1
                        ifit(k-1)=ifit(k)
                    end do
                    ifit(i)=if1

                end if

                nnew = nnew+1
                cycle main_loop

            end if

        end do

    end do main_loop

    end subroutine stdrep
!*****************************************************************************************

!*****************************************************************************************
!>
!  Replaces old population by new; recomputes fitnesses & ranks
!
!# History
!  * Jacob Williams : 3/9/2015 : avoid unnecessary function evaluation if `ielite/=1`.

    subroutine newpop(me,oldph,newph,ifit,jfit,fitns,nnew)

    implicit none

    class(pikaia_class),intent(inout)            :: me
    real(wp),dimension(me%n,me%np),intent(inout) :: oldph
    real(wp),dimension(me%n,me%np),intent(inout) :: newph
    integer,dimension(me%np),intent(out)         :: ifit
    integer,dimension(me%np),intent(out)         :: jfit
    real(wp),dimension(me%np),intent(out)        :: fitns
    integer,intent(out)                          :: nnew

    integer  :: i
    real(wp) :: f

    nnew = me%np

    if (me%ielite==1) then

        !if using elitism, introduce in new population fittest of old
        !population (if greater than fitness of the individual it is
        !to replace)
        call me%ff(newph(:,1),f)

        if (f<fitns(ifit(me%np))) then
            newph(:,1)=oldph(:,ifit(me%np))
            nnew = nnew-1
        end if

    end if

    !replace population
    oldph = newph

    !get fitness using caller's fitness function
    !$omp parallel do private(i)
    do i=1,me%np
        call me%ff(oldph(:,i),fitns(i))
    end do
    !$omp end parallel do

    !compute new population fitness rank order
    call me%rnkpop(fitns,ifit,jfit)

    end subroutine newpop
!*****************************************************************************************

!*****************************************************************************************
    end module pikaia_module
!*****************************************************************************************


!	Estimate the information matrix for a complex sample.
!	This version is designed for random sampling of psu's within strata.
!	Sampling is with replacement.
!	npsu is the number of psus's per stratum.
!	nstratum is the number of strata.
!	psu indicates the psu of an observation.
!	stratum indicates the stratum of an observation.
!	stratify is .true. for stratified sampling.
!	usepsu is .true. for primary sampling units within strata.
!	grads is the array of observation gradients.
!	obsweight contains observation weights.

function information_complex(npsu,nstratum,psu,stratum,stratify,usepsu,grads,obsweight)
implicit none
!
interface
	subroutine makesym(matrix)
!	Symmetrize n by n matrix based on lower triangle.
		real(kind=8),intent(inout)::matrix(:,:)
	end subroutine makesym
end interface
integer,intent(in)::nstratum
integer,intent(in),optional::npsu(:),psu(:),stratum(:)
logical,intent(in)::stratify,usepsu
real(kind=8),intent(in)::grads(:,:),obsweight(:)
real(kind=8)::information_complex(size(grads,1),size(grads,1))
!	al indicates allocation error.
!	col counts columns.
!	col1 counts columns.
!	counts count strata.
!	locpsu is psu locator.
!	obs is an observation counter.
!	point indicates the location of a psu.
!	row counts rows.
!	row1 counts rows.
integer::al,col,col1,counts(nstratum),locpsu(nstratum),obs,point,row,row1

!	diff is for differences.
!	gradstrat is used for weighted summations within strata.
!	inform is used for information within a psu.

!	ratio is a ratio.

real(kind=8)::diff(size(grads,1)),gradstrat(size(grads,1)),inform(size(grads,1),size(grads,1)),ratio
!	gradsum is for weighted summations within psu units.
!	informst is used for information within a stratum.
real(kind=8),allocatable::gradsum(:,:),informst(:,:,:)

information_complex=0.0_8
!	Something must be present.
if(count(obsweight>0.0_8)==0)return
counts=0
gradstrat=0.0_8

if(usepsu)then

	allocate(gradsum(size(grads,1),sum(npsu)),stat=al)
	if(al/=0) stop "Unable to allocate arrays for asymptotic variances computations for complex sampling."
	gradsum=0.0_8

	point=1
	do row=1,nstratum

		locpsu(row)=point
		point=point+npsu(row)
	end do

	if(stratify) then
		do obs=1,size(obsweight)
			if(obsweight(obs)<=0.0_8) cycle
			point=locpsu(stratum(obs))+psu(obs)-1

			do row=1,size(grads,1)
				if(grads(row,obs)/=0.0_8)gradsum(row,point)=gradsum(row,point)+obsweight(obs)*grads(row,obs)
			end do

		end do

		point=1
		do row=1,nstratum
			gradstrat=0.0_8
				do row1=1,size(grads,1)
					do col=point,point+npsu(row)-1
						if(gradsum(row1,col)/=0.0_8)gradstrat(row1)=gradstrat(row1)+gradsum(row1,col)
					end do
				end do
			gradstrat=gradstrat/npsu(row)
			inform=0.0_8
			ratio=1.0_8
			if(npsu(row)>1) ratio=npsu(row)/(npsu(row)-1.0_8)

			do col=1,npsu(row)
				diff=gradsum(:,point)-gradstrat
				do row1=1,size(grads,1)
					if(diff(row1)==0.0_8)cycle
					do col1=1,row1
						if(diff(col1)/=0.0_8)inform(row1,col1)=inform(row1,col1)&
							+diff(row1)*diff(col1)
					end do
				end do
				point=point+1
			end do
			do row1=1,size(grads,1)
				do col1=1,row1
					if(inform(row1,col1)/=0.0_8)information_complex(row1,col1)=information_complex(row1,col1)&
						+ratio*inform(row1,col1)
				end do
			end do

		end do

	else

		do obs=1,size(obsweight)
			if(obsweight(obs)==0.0_8)cycle
			do row=1,size(grads,1)

				if(grads(row,obs)/=0.0_8)gradsum(row,psu(obs))=&
					gradsum(row,psu(obs))+obsweight(obs)*grads(row,obs)
			end do
		end do
		gradstrat=0.0_8

		do col=1,npsu(1)
			do row=1,size(grads,1)
				if(gradsum(row,col)/=0.0_8) gradstrat(row)=gradstrat(row)+gradsum(row,col)
			end do
		end do

		gradstrat=gradstrat/npsu(1)
		ratio=1
		if(npsu(1)>1)ratio=npsu(1)/(npsu(1)-1.0_8)
		do col=1,npsu(1)
			do row1=1,size(grads,1)
				diff(row1)=gradsum(row1,col)-gradstrat(row1)
				if(diff(row1)==0.0_8)cycle
				do col1=1,row1
					if(diff(col1)/=0.0_8)information_complex(row1,col1)=information_complex(row1,col1)+diff(row1)*diff(col1)
				end do
			end do
		end do

		do row=1,size(grads,1)
			information_complex(row,1:row)=ratio*information_complex(row,1:row)
		end do

	end if
else
	if(stratify) then
		allocate(gradsum(size(grads,1),nstratum),informst(size(grads,1),size(grads,1),nstratum),stat=al)
		if(al/=0) stop "Unable to allocate arrays for asymptotic variances computations for complex sampling."
		gradsum=0.0_8
		informst=0.0_8
		do obs=1,size(obsweight)
			if(obsweight(obs)<=0.0_8)cycle
			do row=1,size(grads,1)
				if(grads(row,obs)/=0.0_8)gradsum(row,stratum(obs))=&
					gradsum(row,stratum(obs))+obsweight(obs)*grads(row,obs)
			end do
			counts(stratum(obs))=counts(stratum(obs))+1
		end do
		do row=1,nstratum
			if(counts(row)>0)gradsum(:,row)=gradsum(:,row)/counts(row)
		end do
		do obs=1,size(obsweight)
			if(obsweight(obs)<=0.0_8)cycle

			do row=1,size(grads,1)
				diff(row)=obsweight(obs)*grads(row,obs)-gradsum(row,stratum(obs))
				if(diff(row)==0.0_8)cycle
				do col=1,row
					if(diff(col)/=0.0_8)informst(row,col,stratum(obs))&
						=informst(row,col,stratum(obs))+diff(row)*diff(col)
				end do
			end do
		end do
		do row1=1,nstratum
			if(counts(row1)>1)then
				ratio=counts(row1)/(counts(row1)-1.0_8)
				do row=1,size(grads,1)
					do col=1,row
						if(informst(row,col,row1)/=0.0_8)information_complex(row,col)&
							=information_complex(row,col)+ratio*informst(row,col,row1)
					end do
				end do
			end if
		end do
	else
		gradstrat=0.0_8
		do obs=1,size(obsweight)
			if(obsweight(obs)==0.0_8)cycle
			do row=1,size(grads,1)
				if(grads(row,obs)/=0.0_8)gradstrat(row)=gradstrat(row)+obsweight(obs)*grads(row,obs)
			end do
		end do
		gradstrat=gradstrat/count(obsweight>0.0_8)

		do obs=1,size(obsweight)
			if(obsweight(obs)<=0.0_8)cycle

			do row=1,size(grads,1)
				diff(row)=obsweight(obs)*grads(row,obs)-gradstrat(row)
				if(diff(row)==0.0_8)cycle
				do col=1,row
					if(diff(col)/=0.0_8)information_complex(row,col)=information_complex(row,col)+diff(row)*diff(col)
				end do
			end do
		end do

		ratio=1.0_8
		if(count(obsweight>0.0_8)>1)ratio=count(obsweight>0.0_8)/(count(obsweight>0.0_8)-1.0_8)
		do row=1,size(grads,1)
			information_complex(row,1:row)=ratio*information_complex(row,1:row)
		end do
	end if
end if

call makesym(information_complex)
return
end function information_complex


      SUBROUTINE elongation (r1, z1, waist, height)
      USE vmec_main
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      REAL(rprec), INTENT(out) :: waist(2), height(2)
      REAL(rprec), INTENT(in), DIMENSION(ns,nzeta,ntheta3,0:1) :: r1, z1
      INTEGER :: nv, n1
C-----------------------------------------------
!
!     Compute Waist thickness, Height in phi = 0, pi symmetry planes
!
      n1 = 0
      DO nv = 1, nzeta/2+1
         IF (nv.ne.1 .and. nv.ne.nzeta/2+1) CYCLE
         n1 = n1+1
         waist(n1) = (r1(ns,nv,1,0)       + r1(ns,nv,1,1)) -
     1               (r1(ns,nv,ntheta2,0) + r1(ns,nv,ntheta2,1))
         height(n1) = 2*MAXVAL(ABS(z1(ns,nv,:,0) + z1(ns,nv,:,1)))
      END DO

      END SUBROUTINE elongation


! a simple code to check the analytic Jacobian via numerical
! differencing

subroutine test_jacobian() bind(C)

  use network
  use eos_module
  use burner_module
  use actual_burner_module
  use actual_rhs_module
  use burn_type_module

  use amrex_fort_module, only : rt => amrex_real
  implicit none

  type (burn_t) :: state, statep, statem

  type (eos_t) :: eos_state

  character (len=32) :: probin_file
  integer :: probin_pass(32)
  integer :: i, j

  real(rt)        , parameter :: delta = 1.e-6_rt
  real(rt)        , parameter :: SMALL = 1.e-12_rt
  real(rt)         :: num_jac

  character(len=16) :: namei,namej

  probin_file = "probin"
  do i = 1, len(trim(probin_file))
     probin_pass(i) = ichar(probin_file(i:i))
  enddo

  call runtime_init(probin_pass(1:len(trim(probin_file))), len(trim(probin_file)))

  call network_init()
  call burner_init()
  call eos_init()

  ! Set up state

  state % rho   = 2.0e7_rt
  state % T     = 8.0e9_rt

  state % xn(:) = ONE / nspec

  call burn_to_eos(state, eos_state)
  call normalize_abundances(eos_state)
  call eos(eos_input_rt, eos_state)
  call eos_to_burn(eos_state, state)

  state % self_heat = .true.

  ! Evaluate the analytical Jacobian. Note that we
  ! need to call f_rhs first because that will fill
  ! the state with the rates that the Jacobian needs.

  call actual_rhs(state)
  call actual_jac(state)

888 format(a,"-derivatives that don't match:")
999 format(5x, "df(",a,")/dy(",a,")", g18.10, g18.10, g18.10)

  ! Now evaluate a numerical estimate of the Jacobian
  ! using the RHS.

  do j = 1, neqs

     statep = state
     statem = state

     if (j <= nspec) then
        statep % xn(j) = (ONE + delta) * state % xn(j)
     else if (j == net_itemp) then
        statep % T     = (ONE + delta) * state % T
     else if (j == net_ienuc) then
        statep % e     = (ONE + delta) * state % e
     endif

     call actual_rhs(statep)

     if (j <= nspec) then
        statem % xn(j) = (ONE - delta) * state % xn(j)
     else if (j == net_itemp) then
        statem % T     = (ONE - delta) * state % T
     else if (j == net_ienuc) then
        statem % e     = (ONE - delta) * state % e
     endif

     call actual_rhs(statem)

     if (j <= nspec) then
        namej = short_spec_names(j)
     else if (j==net_ienuc) then
        namej = "e"
     else if (j==net_itemp) then
        namej = "T"
     endif

     write(*,888) trim(namej)

     do i = 2, neqs

        if (j <= nspec) then
           num_jac = (statep % ydot(i) - statem % ydot(i))/(statep % xn(j) - statem % xn(j) + SMALL)
        else if (j == net_itemp) then
           num_jac = (statep % ydot(i) - statem % ydot(i))/(statep % T - statem % T + SMALL)
        else if (j == net_ienuc) then
           num_jac = (statep % ydot(i) - statem % ydot(i))/(statep % e - statem % e + SMALL)
        endif

        if (i <= nspec) then
           namei = short_spec_names(i)
        else if (i==net_ienuc) then
           namei = "e"
        else if (i==net_itemp) then
           namei = "T"
        endif

        ! only dump the ones that don't match
        if (num_jac /= state % jac(i,j)) then
           if (num_jac /= ZERO) then
              write (*,999) trim(namei), &
                   trim(namej), num_jac, state % jac(i,j), (num_jac-state % jac(i,j))/num_jac
           else
              write (*,999) trim(namei), &
                   trim(namej), num_jac, state % jac(i,j)
           endif
        endif

     enddo
  enddo

end subroutine test_jacobian


! Program that blurs image data, by making every pixel the average of it's neighbours.
! Does not handle any actual image formats, so it just applies the bluring to dummy data.

module img_blur_module
    implicit none

    ! Custom pixel type, just has RGB values.
    type pixel
        integer :: r, g, b
    end type pixel

    ! Function declarations.
    public :: blur, set_pixel

contains

    function blur(img, n) result (blurred)
        integer, intent (in) :: n
        type (pixel), dimension (n, n), intent (in) :: img
        type (pixel), dimension (n, n) :: blurred

        integer :: i, j, cnt, r, g, b
        type (pixel) :: p

        do i = 1, n
            do j = 1, n
                cnt = 1
                r = img(i, j)%r
                g = img(i, j)%g
                b = img(i, j)%b

                ! Get average RGB values.
                if (i > 1) then
                    cnt = cnt + 1
                    r = r + img(i - 1, j)%r
                    g = g + img(i - 1, j)%g
                    b = b + img(i - 1, j)%b
                end if
                if (i < n) then
                    cnt = cnt + 1
                    r = r + img(i + 1, j)%r
                    g = g + img(i + 1, j)%g
                    b = b + img(i + 1, j)%b
                end if
                if (j > 1) then
                    cnt = cnt + 1
                    r = r + img(i, j - 1)%r
                    g = g + img(i, j - 1)%g
                    b = b + img(i, j - 1)%b
                end if
                if (j < n) then
                    cnt = cnt + 1
                    r = r + img(i, j + 1)%r
                    g = g + img(i, j + 1)%g
                    b = b + img(i, j + 1)%b
                end if

                ! Set the new, averaged value.
                call set_pixel(r / cnt, g / cnt, b / cnt, p)
                blurred(i, j) = p
            end do
        end do

    end function blur

    ! Sets a given pixel's RGB values.
    subroutine set_pixel(r, g, b, p)
        integer, intent (in) :: r, g, b
        type (pixel), intent (out) :: p

        p%r = r
        p%g = g
        p%b = b
    end subroutine set_pixel

end module img_blur_module

! Driver code.
program main
    use img_blur_module
    implicit none

    ! Set up a dummy image that is just half green and half red.
    integer, parameter :: n = 6
    type (pixel), dimension (n, n) :: img, blurred

    integer :: i, j
    type (pixel) :: green, red

    ! Set green and red pixel types.
    call set_pixel(0, 255, 0, green)
    call set_pixel(255, 0, 0, red)

    ! Color the dummy image.
    do i = 1, n / 2
        do j = 1, n
            img(i, j) = green
        end do
    end do
    do i = (n / 2) + 1, n
        do j = 1, n
            img(i, j) = red
        end do
    end do

    ! Blur it and print the results.
    blurred = blur(img, n)

    print '(a)', 'Original image:'
    do i = 1, n
        do j = 1, n
            write (*, '(a,i0,a,i0,a,i0,a,x)', advance='no') '(', img(j, i)%r, ',', img(j,i)%g, ',', img(j,i)%b, ')'
        end do
        print *, ''
    end do

    print '(a)', 'Blurred image:'
    do i = 1, n
        do j = 1, n
            write (*, '(a,i0,a,i0,a,i0,a,x)', advance='no') '(', blurred(j, i)%r, ',', blurred(j,i)%g, ',', blurred(j,i)%b, ')'
        end do
        print *, ''
    end do

end program main


program testburn

  use amrex_constants_module
  use amrex_error_module
  use amrex_fort_module, only : rt => amrex_real
  use network
  use eos_module
  use burner_module
  use burner_aux_module

  implicit none

  real(rt) :: dens, temp
  real(rt), dimension(nspec) :: Xin
  real(rt), dimension(nspec_advance+1) :: y, ydot
  real(rt) :: enucdot

  real(rt) :: rpar
  integer :: ipar

  integer :: ic12, io16, img24
  integer :: n

  call network_init()
  call eos_init()

  ic12 = network_species_index("carbon-12")
  io16 = network_species_index("oxygen-16")
  img24 = network_species_index("magnesium-24")

  if (ic12 < 0 .or. io16 < 0 .or. img24 < 0) then
     call amrex_error("ERROR: species index not defined")
  endif

  dens = 2.6e9_rt
  temp = 6.e8_rt

  Xin(ic12) = 0.5_rt
  Xin(io16) = 0.5_rt
  Xin(img24) = 0.0_rt

  den_eos(1) = dens
  temp_eos(1) = temp
  xn_eos(1,:) = Xin(:)

  call eos(eos_input_rt, den_eos, temp_eos, &
           npts, &
           xn_eos, &
           p_eos, h_eos, e_eos, &
           cv_eos, cp_eos, xne_eos, eta_eos, pele_eos, &
           dpdt_eos, dpdr_eos, dedt_eos, dedr_eos, &
           dpdX_eos, dhdX_eos, &
           gam1_eos, cs_eos, s_eos, &
           dsdt_eos, dsdr_eos, &
           .false.)

  print *, 'evaluating the RHS...'

  ! load the state
  y(1) = Xin(ic12)
  y(nspec_advance+1) = temp

  ! set the burner_aux variables
  dens_pass = dens
  c_p_pass = cp_eos(1)
  dhdx_pass(:) = dhdX_eos(1,:)
  X_O16_pass = Xin(io16)

  call f_rhs(nspec_advance+1, ZERO, y, ydot, rpar, ipar)

  print *, 'done!'

  print *, 'Xin:  ', Xin
  print *, 'rhs:  ', ydot

  ! compute the energy release/s (erg/g/s)
  enucdot = (ebin(img24) - ebin(ic12))*ydot(ic12)

  print *, 'enucdot = ', enucdot

end program testburn


program UI_integrate
use libatoms_module
implicit none
   type(InOutput) :: io
   integer :: N, n_lines
   real(dp), allocatable :: v(:), v_err(:), f(:), f_err(:), f_int(:), f_int_err_sq(:)
   real(dp) :: t_err_sq
   character(len=256), allocatable :: line_array(:)
   integer :: i, i_zero

   call system_initialise(verbosity=PRINT_SILENT)
   call verbosity_push(PRINT_NORMAL)

   call initialise(io, "stdin")
   call read_file(io, line_array, n_lines)
   call finalise(io)
   allocate(v(n_lines+1))
   allocate(v_err(n_lines+1))
   allocate(f(n_lines+1))
   allocate(f_err(n_lines+1))
   allocate(f_int(n_lines+1))
   allocate(f_int_err_sq(n_lines+1))
   N=n_lines
   do i=1, N
      read (unit=line_array(i), fmt=*) v(i), v_err(i), f(i), f_err(i)
   end do
   i_zero = 1
   do i=2, N
      if (f(i-1)*f(i) < 0) then ! force changed sign, must have crossed 0 here
	 v(i+1:n+1) = v(i:n)
	 v_err(i+1:n+1) = v_err(i:n)
	 f(i+1:n+1) = f(i:n)
	 f_err(i+1:N+1) = f_err(i:N)

	 v(i) = v(i-1)*f(i+1)/(f(i+1)-f(i-1)) - v(i+1)*f(i-1)/(f(i+1)-f(i-1))
	 v_err(i) =  Sqrt((f(i+1)**2*v_err(i-1)**2)/(-f(i-1) + f(i+1))**2 + \
	    f_err(i+1)**2*(-((f(i+1)*v(i-1))/(-f(i-1) + f(i+1))**2) + v(i-1)/(-f(i-1) + f(i+1)) + \
	    (f(i-1)*v(i+1))/(-f(i-1) + f(i+1))**2)**2 + f_err(i-1)**2*((f(i+1)*v(i-1))/(-f(i-1) + f(i+1))**2 \
	    - (f(i-1)*v(i+1))/(-f(i-1) + f(i+1))**2 - v(i+1)/(-f(i-1) + f(i+1)))**2 + \
	    (f(i-1)**2*v_err(i+1)**2)/(-f(i-1) + f(i+1))**2)

	 f(i) = 0.0_dp
	 f_err(i) =  Sqrt((f(i+1)**2*f_err(i-1)**2)/(-f(i-1) + f(i+1))**2 + \
	    f_err(i+1)**2*(-((f(i+1)*f(i-1))/(-f(i-1) + f(i+1))**2) + f(i-1)/(-f(i-1) + f(i+1)) + \
	    (f(i-1)*f(i+1))/(-f(i-1) + f(i+1))**2)**2 + f_err(i-1)**2*((f(i+1)*f(i-1))/(-f(i-1) + f(i+1))**2 \
	    - (f(i-1)*f(i+1))/(-f(i-1) + f(i+1))**2 - f(i+1)/(-f(i-1) + f(i+1)))**2 + \
	    (f(i-1)**2*f_err(i+1)**2)/(-f(i-1) + f(i+1))**2)

	 i_zero = i
	 N = N+1
	 exit
      endif
   end do

   f_int(i_zero) = 0.0_dp
   f_int_err_sq(i_zero) = 0.0_dp
   do i=i_zero-1, 1, -1
      f_int(i) = f_int(i+1) - (v(i+1)-v(i))*(f(i+1)+f(i))/2.0_dp
      t_err_sq = ((f(i+1)+f(i))/2.0_dp)**2*v_err(i+1)**2 + ((f(i+1)+f(i))/2.0_dp)**2*v_err(i)**2 + &
	 ((v(i+1)-v(i))/2.0_dp)**2*f_err(i+1)**2 + ((v(i+1)-v(i))/2.0_dp)**2*f_err(i)**2
      f_int_err_sq(i) = f_int_err_sq(i+1) + t_err_sq
   end do
   do i=i_zero, N-1
      f_int(i+1) = f_int(i) + (v(i+1)-v(i))*(f(i+1)+f(i))/2.0_dp
      t_err_sq = ((f(i+1)+f(i))/2.0_dp)**2*v_err(i+1)**2 + ((f(i+1)+f(i))/2.0_dp)**2*v_err(i)**2 + &
	 ((v(i+1)-v(i))/2.0_dp)**2*f_err(i+1)**2 + ((v(i+1)-v(i))/2.0_dp)**2*f_err(i)**2
      f_int_err_sq(i+1) = f_int_err_sq(i) + t_err_sq
   end do

   call print("# col_val err  grad_val err int_val err")
   do i=1, N
      call print(v(i)//" "//v_err(i)//" "//f(i)//" "//f_err(i)//" "//f_int(i)//" "//sqrt(f_int_err_sq(i)))
   end do

   call verbosity_pop()
   call system_finalise()
end program UI_integrate


      SUBROUTINE SGEMV( TRANS, M, N, ALPHA, A, LDA, X, INCX,
     $                  BETA, Y, INCY )
*
*  -- Automatically Tuned Linear Algebra Software (ATLAS)
*     (C) Copyright 2000 All Rights Reserved
*
*  -- ATLAS routine -- F77 Interface -- Version 3.9.24 -- December 25, 2000
*
*  Author         : Antoine P. Petitet
*  Originally developed at the University of Tennessee,
*  Innovative Computing Laboratory,  Knoxville TN, 37996-1301, USA.
*
*  ---------------------------------------------------------------------
*
*  -- Copyright notice and Licensing terms:
*
*  Redistribution  and  use in  source and binary forms, with or without
*  modification, are  permitted provided  that the following  conditions
*  are met:
*
*  1. Redistributions  of  source  code  must retain the above copyright
*     notice, this list of conditions and the following disclaimer.
*  2. Redistributions in binary form must reproduce  the above copyright
*     notice,  this list of conditions, and the  following disclaimer in
*     the documentation and/or other materials provided with the distri-
*     bution.
*  3. The name of the University,  the ATLAS group,  or the names of its
*     contributors  may not be used to endorse or promote products deri-
*     ved from this software without specific written permission.
*
*  -- Disclaimer:
*
*  THIS  SOFTWARE  IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
*  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,  INCLUDING,  BUT NOT
*  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
*  A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY
*  OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,  INDIRECT, INCIDENTAL, SPE-
*  CIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
*  TO,  PROCUREMENT  OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
*  OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEO-
*  RY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT  (IN-
*  CLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
*  THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
*  ---------------------------------------------------------------------
*
*     .. Scalar Arguments ..
      CHARACTER*1        TRANS
      INTEGER            INCX, INCY, LDA, M, N
      REAL               ALPHA, BETA
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), X( * ), Y( * )
*     ..
*
*  Purpose
*  =======
*
*  SGEMV performs one of the matrix-vector operations
*
*     y := alpha*A*x + beta*y,   or   y := alpha*A'*x + beta*y,
*
*  where  alpha and beta are scalars, x and y are vectors and  A is an m
*  by n matrix.
*
*  Arguments
*  =========
*
*  TRANS   (input)                       CHARACTER*1
*          On entry,  TRANS  specifies the  operation to be performed as
*          follows:
*
*             TRANS = 'N' or 'n',    y := alpha*A *x + beta*y,
*
*             TRANS = 'T' or 't',    y := alpha*A'*x + beta*y,
*
*             TRANS = 'C' or 'c',    y := alpha*A'*x + beta*y.
*
*          Unchanged on exit.
*
*  M       (input)                       INTEGER
*          On entry,  M  specifies the number of rows of  the matrix  A.
*          M must be at least zero. Unchanged on exit.
*
*  N       (input)                       INTEGER
*          On entry, N  specifies the number of columns of the matrix A.
*          N  must be at least zero. Unchanged on exit.
*
*  ALPHA   (input)                       REAL
*          On entry, ALPHA specifies the scalar alpha.   When  ALPHA  is
*          supplied as zero then  A and X  need not be set on input. Un-
*          changed on exit.
*
*  A       (input)                       REAL array
*          On entry,  A  is an array of DIMENSION ( LDA, n ). Before en-
*          try, the leading m by n part of the array  A must contain the
*          matrix coefficients. Unchanged on exit.
*
*  LDA     (input)                       INTEGER
*          On entry, LDA  specifies the first dimension of A as declared
*          in the calling (sub) program. LDA must be at least  max(1,m).
*          Unchanged on exit.
*
*  X       (input)                       REAL array
*          On entry,  X  is an incremented array of dimension  at  least
*          ( 1 + ( n - 1 ) * abs( INCX ) ) when  TRANS = 'N' or 'n'  and
*          at  least ( 1 + ( m - 1 ) * abs( INCX ) )  otherwise.  Before
*          entry, the incremented array X must contain the vector x. Un-
*          changed on exit.
*
*  INCX    (input)                       INTEGER
*          On entry, INCX specifies the increment for the elements of X.
*          INCX must not be zero. Unchanged on exit.
*
*  BETA    (input)                       REAL
*          On entry,  BETA  specifies the scalar  beta.   When  BETA  is
*          supplied as zero then Y  need not be set on input.  Unchanged
*          on exit.
*
*  Y       (input/output)                REAL array
*          On entry,  Y  is an incremented array of dimension  at  least
*          ( 1 + ( m - 1 ) * abs( INCY ) ) when  TRANS = 'N' or 'n'  and
*          at  least ( 1 + ( n - 1 ) * abs( INCY ) )  otherwise.  Before
*          entry with BETA non-zero, the incremented array  Y  must con-
*          tain the vector y. On exit,  Y  is overwritten by the updated
*          vector y.
*
*  INCY    (input)                       INTEGER
*          On entry, INCY specifies the increment for the elements of Y.
*          INCY must not be zero. Unchanged on exit.
*
*  Further Details
*  ===============
*
*  For further information on the Level 1 BLAS specification, see:
*
*  ``A Proposal for Standard Linear Algebra Subprograms''  by R. Hanson,
*  F. Krogh and C. Lawson, ACM SIGNUM Newsl., 8(16), 1973,
*
*  ``Basic Linear Algebra Subprograms for Fortran Usage''  by C. Lawson,
*  R. Hanson, D. Kincaid and F. Krogh,  ACM Transactions on Mathematical
*  Software, 5(3) pp 308-323, 1979.
*
*  For further information on the Level 2 BLAS specification, see:
*
*  ``An  Extended Set of  FORTRAN  Basic Linear Algebra Subprograms'' by
*  J. Dongarra,  J. Du Croz,  S. Hammarling and R. Hanson,  ACM Transac-
*  tions on Mathematical Software, 14(1) pp 1-17, 1988.
*
*  ``Algorithm 656: An extended Set of Basic Linear Algebra Subprograms:
*  Model Implementation and Test Programs''  by J. Dongarra, J. Du Croz,
*  S. Hammarling and R. Hanson,  ACM  Transactions on Mathematical Soft-
*  ware, 14(1) pp 18-32, 1988.
*
*  For further information on the Level 3 BLAS specification, see:
*
*  ``A Set of Level 3 Basic Linear Algebra Subprograms'' by J. Dongarra,
*  J. Du Croz, I. Duff and S. Hammarling, ACM Transactions on Mathemati-
*  cal Software, 16(1), pp 1-17, 1990.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            ICOTRAN, INOTRAN, ITRAN
      PARAMETER          ( INOTRAN = 111, ITRAN = 112, ICOTRAN = 113 )
*     ..
*     .. Local Scalars ..
      INTEGER            INFO, ITRANS
*     ..
*     .. External Subroutines ..
      EXTERNAL           ATL_F77WRAP_SGEMV, XERBLA
*     ..
*     .. External Functions ..
      EXTERNAL           LSAME
      LOGICAL            LSAME
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
      INFO = 0
*
      IF(      LSAME( TRANS, 'N' ) ) THEN
         ITRANS = INOTRAN
      ELSE IF( LSAME( TRANS, 'T' ) ) THEN
         ITRANS = ITRAN
      ELSE IF( LSAME( TRANS, 'C' ) ) THEN
         ITRANS = ICOTRAN
      ELSE IF( INFO.EQ.0 ) THEN
         INFO  = 1
      END IF
*
      IF( INFO.EQ.0 ) THEN
         IF( M.LT.0 ) THEN
            INFO = 2
         ELSE IF( N.LT.0 ) THEN
            INFO = 3
         ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
            INFO = 6
         ELSE IF( INCX.EQ.0 ) THEN
            INFO = 8
         ELSE IF( INCY.EQ.0 ) THEN
            INFO = 11
         END IF
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SGEMV ', INFO )
         RETURN
      END IF
*
      CALL ATL_F77WRAP_SGEMV( ITRANS, M, N, ALPHA, A, LDA, X, INCX,
     $                        BETA, Y, INCY )
*
      RETURN
*
*     End of SGEMV
*
      END


module grid_pda_geometry

  use core_lib
  use type_grid_cell
  use grid_geometry
  implicit none
  save

  private
  public :: geometrical_factor
  public :: check_allowed_pda

contains

  real(dp) function geometrical_factor(wall, cell)
    implicit none
    integer, intent(in) :: wall
    type(grid_cell), intent(in) :: cell
    select case(wall)
    case(1)
       geometrical_factor = 4. * geo%w1(cell%i1)**2/(geo%w1(cell%i1) + geo%w1(cell%i1+1))**2
    case(2)
       geometrical_factor = 4. * geo%w1(cell%i1+1)**2/(geo%w1(cell%i1) + geo%w1(cell%i1+1))**2
    case(3)
       geometrical_factor = 2. * geo%wsint(cell%i2) / (geo%wsint(cell%i2) + geo%wsint(cell%i2+1))
    case(4)
       geometrical_factor = 2. * geo%wsint(cell%i2+1) / (geo%wsint(cell%i2) + geo%wsint(cell%i2+1))
    case default
       geometrical_factor = 1._dp
    end select
  end function geometrical_factor

  subroutine check_allowed_pda(do_pda)
    implicit none
    logical,intent(inout) :: do_pda(:)
    integer :: i1, i2, i3, ic
    do i2=1,geo%n2
       do i3=1,geo%n3
          ic = cell_id(1, i2, i3, geo)
          do_pda(ic) = .false.
          ic = cell_id(geo%n1, i2, i3, geo)
          do_pda(ic) = .false.
       end do
    end do
    do i1=1,geo%n1
       do i3=1,geo%n3
          ic = cell_id(i1, 1, i3, geo)
          do_pda(ic) = .false.
          ic = cell_id(i1, geo%n2, i3, geo)
          do_pda(ic) = .false.
       end do
    end do
  end subroutine check_allowed_pda

end module grid_pda_geometry


program r_inv_speed
	! Tests the speed of the inversion of
	! the R matrix
	use flips

	implicit none

	type(flips_s) :: gg
	real, dimension(:), allocatable :: r,invr
	real :: ts, te ,tot
	integer :: n, id, k

	write(*,*) 'Give size of R:'
	read(*,*) n
	write(*,*) 'Give ID (0 uses memory):'
	read(*,*) id

	if (id > 0) then
		call flips_init(gg,n,1,idnum=id)
	else
		call flips_init(gg,n,1)
	end if

	allocate(r(n*(n+1)/2),invr(n*(n+1)/2))

	call random_number(r)

	if (gg%use_files) then
		!do k = 1,n*(n+1)/2
			write(gg%idnum*100+11,POS=1) r
		!end do
	else
		gg%rmat = r
	end if

	write(*,*) 'HEP!'

	call cpu_time(ts)
	call invert_r_s(gg)
	call cpu_time(te)

	write(*,*) 'Time: ',te-ts

	call flips_kill(gg,.FALSE.)

end program r_inv_speed


!
!  Copyright 2017 SALMON developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
subroutine calc_dos
use salmon_parallel, only: nproc_id_global, nproc_group_grid
use salmon_communication, only: comm_is_root, comm_summation
use inputoutput, only: out_dos_start, out_dos_end, out_dos_method, &
                       out_dos_smearing, iout_dos_nenergy, out_dos_fshift, uenergy_from_au
use scf_data
use allocate_psl_sub
use new_world_sub
implicit none
!integer :: iob,iobmax,iob_allob
integer :: iob,iobmax,iob_allob,iik
real(8) :: dos_l_tmp(1:iout_dos_nenergy)
real(8) :: dos_l(1:iout_dos_nenergy)
real(8) :: fk,ww,dw
integer :: iw
real(8) :: ene_homo,ene_lumo,ene_min,ene_max,efermi,eshift

call calc_pmax(iobmax)
ene_min = minval(esp(:,:))
ene_max = maxval(esp(:,:))
ene_homo = esp(nelec/2,1)
ene_lumo = esp(nelec/2+1,1)
if(out_dos_fshift=='y'.and.nstate>nelec/2) then
  efermi = (ene_homo+ene_lumo)*0.5d0
  eshift = efermi
else
  eshift = 0.d0
endif
out_dos_start = max(out_dos_start,ene_min-0.25d0*(ene_max-ene_min))
out_dos_end = min(out_dos_end,ene_max+0.25d0*(ene_max-ene_min))
dw=(out_dos_end-out_dos_start)/dble(iout_dos_nenergy-1)

dos_l_tmp=0.d0

do iik=k_sta,k_end
do iob=1,iobmax
  call calc_allob(iob,iob_allob)
  select case (out_dos_method)
  case('lorentzian')
    fk=2.d0*out_dos_smearing/pi
    do iw=1,iout_dos_nenergy
      ww=out_dos_start+dble(iw-1)*dw+eshift-esp(iob_allob,iik)
      dos_l_tmp(iw)=dos_l_tmp(iw)+wtk(iik)*fk/(ww**2+out_dos_smearing**2)
    end do
  case('gaussian')
    fk=2.d0/(sqrt(2.d0*pi)*out_dos_smearing)
    do iw=1,iout_dos_nenergy
      ww=out_dos_start+dble(iw-1)*dw+eshift-esp(iob_allob,iik)
      dos_l_tmp(iw)=dos_l_tmp(iw)+wtk(iik)*fk*exp(-(0.5d0/out_dos_smearing**2)*ww**2)
    end do
  end select
end do
end do
call comm_summation(dos_l_tmp,dos_l,iout_dos_nenergy,nproc_group_grid)

if(comm_is_root(nproc_id_global))then
  open(101,file="dos.data")
  write(101,'("# Density of States")')
  select case(unit_energy)
  case('au','a.u.')
    write(101,'("# Energy[a.u.] DOS[a.u.]")')
  case('ev','eV')
    write(101,'("# Energy[eV]  DOS[1/eV]")')
  end select
  write(101,'("#-----------------------")')
  do iw=1,iout_dos_nenergy
    ww=out_dos_start+dble(iw-1)*dw+eshift
    write(101,'(F16.8,99(1X,E23.15E3))') ww*uenergy_from_au, dos_l(iw)/uenergy_from_au
  end do
  close(101)
end if

end subroutine calc_dos