module type_rbf_interpolation
#include <messenger.h>
    use mod_kinds,                              only: rk, ik
    use mod_constants,                          only: ZERO, ONE, TWO
    use mod_inv,                                only: inv
    use mod_radial_basis_function,              only: create_radial_basis_function
    use mod_rbf_tools
    use mod_k_means_clustering
    use type_radial_basis_function,             only: radial_basis_function_t
    use type_rbf_info,                          only: rbf_info_t
    use type_rbf_node,                          only: rbf_node_t
    use type_rbf_node_patch,                    only: rbf_node_patch_t
    use type_rbf_node_vector,                   only: rbf_node_vector_t
    use type_rbf_interpolation_matrix,          only: rbf_interpolation_matrix_t
    use type_ivector,                           only: ivector_t
    use type_svector,                           only: svector_t
    use type_mesh,                              only: mesh_t
    implicit none

    type :: rbf_interpolation_t

        type(rbf_info_t)                                    :: rbf_info

        class(radial_basis_function_t), allocatable         :: rbf

        ! For the multiscale RBFI, we might want two different kinds of RBFs
        ! for the base nodes and explicit nodes. We might want to use
        ! global RBFs (e.g. thin-plate splines) for the base nodes,
        ! while the use of compactly supported RBFs for the explicit nodes seems to be mandatory.
        class(radial_basis_function_t), allocatable         :: rbf_explicit

        ! RBF node patch, with patch node ordering.
        type(rbf_node_patch_t)                              :: rbf_node_patch

        ! RBF node lists. Ordered according to RBF system node ordering.
        type(rbf_node_vector_t)                             :: source_nodes
        type(rbf_node_vector_t)                             :: source_nodes_base
        type(rbf_node_vector_t)                             :: source_nodes_explicit

        ! RBF interpolation matrix
        type(rbf_interpolation_matrix_t)                    :: interpolation_matrix

    contains

        !procedure           :: init_from_patch
        procedure           :: init_from_array
        procedure           :: init_from_array_std
        procedure           :: add_rbf
        procedure           :: add_rbf_explicit
        !procedure           :: assemble_node_patch
        procedure           :: assemble_rbf_patch
        procedure           :: assemble_node_patch_from_array
        procedure           :: construct_rbf_interpolation
        procedure           :: construct_rbf_interpolation_std
        procedure           :: solve
        procedure           :: evaluate_rbf
        procedure           :: evaluate_rbf_grad
        procedure           :: evaluate
        procedure           :: evaluate_grad
        procedure           :: evaluate_ms
        procedure           :: evaluate_ms_grad

    end type rbf_interpolation_t

contains

!    !>  Provides an interface to initialize an RBF interpolation from a specified
!    !!  BC patch_group.
!    !!
!    !!
!    !!  @author Eric Wolf
!    !!  @date 10/19/2017
!    !--------------------------------------------------------------------------------
!    subroutine init_from_patch(self, rbfstring, rbfstring_explicit, data, patch_group, nnodes_base, radius_base)
!        class(rbf_interpolation_t),             intent(inout)   :: self
!        character(*),                           intent(in)      :: rbfstring
!        character(*),                           intent(in)      :: rbfstring_explicit
!        type(chidg_data_t),                     intent(inout)   :: data
!        character(*),                           intent(in)      :: patch_group
!        integer(ik),                            intent(in)      :: nnodes_base
!        real(rk),                               intent(in)      :: radius_base(3)
!
!        call self%add_rbf(rbfstring)
!        call self%add_rbf_explicit(rbfstring_explicit)
!        call self%assemble_node_patch(data, patch_group)
!        call self%construct_rbf_interpolation(nnodes_base, radius_base)
!
!    end subroutine init_from_patch
!    !********************************************************************************
!
    !>  Provides an interface to initialize an RBF interpolation from a specified
    !!  BC patch_group.
    !!
    !!
    !!  @author Eric Wolf
    !!  @date 10/19/2017
    !--------------------------------------------------------------------------------
    subroutine init_from_array(self, rbfstring, rbfstring_explicit, source_nodes_in, nnodes_base, radius_base)
        class(rbf_interpolation_t),             intent(inout)   :: self
        character(*),                           intent(in)      :: rbfstring
        character(*),                           intent(in)      :: rbfstring_explicit
        real(rk),                               intent(in)      :: source_nodes_in(:,:)
        integer(ik),                            intent(in)      :: nnodes_base
        real(rk),                               intent(in)      :: radius_base(3)

        call self%add_rbf(rbfstring)
        call self%add_rbf_explicit(rbfstring_explicit)
        call self%assemble_node_patch_from_array(source_nodes_in)
        call self%construct_rbf_interpolation(nnodes_base, radius_base)

    end subroutine init_from_array
    !********************************************************************************

    !>  Provides an interface to initialize an RBF interpolation from a specified
    !!  BC patch_group.
    !!
    !!
    !!  @author Eric Wolf
    !!  @date 10/19/2017
    !--------------------------------------------------------------------------------
    subroutine init_from_array_std(self, rbfstring, source_nodes_in, radius_base)
        class(rbf_interpolation_t),             intent(inout)   :: self
        character(*),                           intent(in)      :: rbfstring
        real(rk),                               intent(in)      :: source_nodes_in(:,:)
        real(rk),                               intent(in)      :: radius_base(3)

        call self%add_rbf(rbfstring)
        call self%assemble_node_patch_from_array(source_nodes_in)
        call self%construct_rbf_interpolation_std(radius_base)

    end subroutine init_from_array_std
    !********************************************************************************

    !>  Adds a rbf instance to self, choosing the type based on input string rbfstring
    !!
    !!
    !!  @author Eric Wolf
    !!  @date 10/19/2017
    !--------------------------------------------------------------------------------
    subroutine add_rbf(self, rbfstring)
        class(rbf_interpolation_t),             intent(inout)   :: self
        character(*),                           intent(in)      :: rbfstring

        class(radial_basis_function_t), allocatable                :: rbf

        integer(ik)     :: ierr
        !call self%set_rbf_name(rbfstring)
        call create_radial_basis_function(rbf, rbfstring)
        if (allocated(self%rbf)) deallocate(self%rbf)
        allocate(self%rbf, source = rbf, stat=ierr)
        if (ierr /= 0) call AllocationError

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

    !>  Adds a rbf instance to self, choosing the type based on input string rbfstring
    !!
    !!
    !!  @author Eric Wolf
    !!  @date 10/19/2017
    !--------------------------------------------------------------------------------
    subroutine add_rbf_explicit(self, rbfstring)
        class(rbf_interpolation_t),             intent(inout)   :: self
        character(*),                           intent(in)      :: rbfstring

        class(radial_basis_function_t), allocatable                :: rbf

        integer(ik)     :: ierr
        !call self%set_rbf_name(rbfstring)
        call create_radial_basis_function(rbf, rbfstring)
        if (allocated(self%rbf_explicit)) deallocate(self%rbf_explicit)
        allocate(self%rbf_explicit, source = rbf, stat=ierr)
        if (ierr /= 0) call AllocationError

    end subroutine add_rbf_explicit
    !********************************************************************************

    !>  Assembles the rbf_node_patch from a BC patch_group.
    !!
    !!
    !!  @author Eric Wolf
    !!  @date 10/19/2017
    !--------------------------------------------------------------------------------
   subroutine assemble_rbf_patch(self,mesh,patch_group)
        class(rbf_interpolation_t),         intent(inout)       :: self
        type(mesh_t),                 intent(inout)       :: mesh
        type(svector_t),                       intent(inout)          :: patch_group

        call self%rbf_node_patch%assemble_rbf_patch(mesh,patch_group)

    end subroutine assemble_rbf_patch
    !********************************************************************************

!    !>  Assembles the rbf_node_patch from a BC patch_group.
!    !!
!    !!
!    !!  @author Eric Wolf
!    !!  @date 10/19/2017
!    !--------------------------------------------------------------------------------
!   subroutine assemble_node_patch(self,data,patch_group)
!        class(rbf_interpolation_t),         intent(inout)       :: self
!        type(chidg_data_t),                 intent(inout)       :: data
!        character(*),                       intent(in)          :: patch_group
!
!        call self%rbf_node_patch%assemble(data,patch_group)
!
!    end subroutine assemble_node_patch
!    !********************************************************************************

    !>  Assembles self%rbf_node_patch from a given array of nodes.
    !!
    !!
    !!  @author Eric Wolf
    !!  @date 10/19/2017
    !--------------------------------------------------------------------------------
    subroutine assemble_node_patch_from_array(self,source_nodes_in)
        class(rbf_interpolation_t),         intent(inout)       :: self
        real(rk),                           intent(in)          :: source_nodes_in(:,:)

        call self%rbf_node_patch%assemble_from_array(source_nodes_in)

    end subroutine assemble_node_patch_from_array
    !********************************************************************************

    !>  Constructs the compactly supported RBF interpolation according to
    !!  the multiscale formulation of
    !!      Kedward, Allen, Rendall (2017)
    !!
    !!  The source nodes are divided into a small set of base nodes,
    !!  numbering nnodes_base, and a much larger set of explicit nodes. The names
    !!  'base' and 'explicit' pertain to the construction and solution of the
    !!  linear system used to obtain RBF coefficients from nodal values.
    !!
    !!  The base nodes give a dense RBF submatrix A, whose inverse Ainv we obtain
    !!  with a direct solver and store for later repeated use, while the
    !!  explicit nodes give a dense block B in connection to the base nodes
    !!  and a lower triangular RBF submatrix C in connection with explicit nodes.
    !!  The full RBF interpolation matrix has the form,
    !!
    !!  M =
    !!      |A 0|
    !!      |B C|.
    !!
    !!  We solve the linear system M*x=f arising in RBF interpolation with
    !!  base and explicit nodal data,
    !!
    !!  f =
    !!      |f_b|
    !!      |f_e|,
    !!
    !!  and RBF coefficient solution vector,
    !!
    !!  x =
    !!      |x_b|
    !!      |x_e|,
    !!
    !!  by applying the stored Ainv,
    !!
    !!  x_b = Ainv*f_b
    !!
    !!  and then applying forward substitution to solve the lower-triangular system
    !!
    !!  C*x_e = f_e-B*x_b.
    !!
    !!  This linear system solution method costs O(N_b^3 + N_b*N_e + N_e) operations,
    !!  and we will generally take N_b << N_e to be a small fixed number.
    !!
    !!  We use k-means clustering with k=N_b to automatically select our base node set.
    !!
    !!
    !!  @author Eric Wolf
    !!  @date 10/19/2017
    !--------------------------------------------------------------------------------
    subroutine construct_rbf_interpolation(self, nnodes_base, radius_base)
        class(rbf_interpolation_t),         intent(inout)   :: self
        integer(ik),                        intent(in), optional :: nnodes_base
        real(rk),                           intent(in), optional :: radius_base(3)

        type(ivector_t) :: active_nodes, inactive_nodes

        real(rk) :: radius_new(3), target_node(3), source_node(3), radius_rbf(3)
        real(rk) :: dist_max, min_dist, current_dist
        integer(ik) :: nnodes_total, nnodes_explicit
        integer(ik) :: inode, inode_active, inode_transfer, inode_ag, inode_ig, num_active, num_inactive, inode_source, inode_target

        type(rbf_node_t) :: rbf_node_temp

        integer(ik), allocatable :: base_node_indices(:)

        ! We may want to implement a NON-multiscale version to have a basis for comparision.
        if ((present(nnodes_base)) .and. (present(radius_base))) then

            ! Select the nnodes_base number of base nodes using k-means clustering
            nnodes_total = size(self%rbf_node_patch%nodes, 1)
            nnodes_explicit = nnodes_total-nnodes_base
            base_node_indices = get_k_means_node_indices(self%rbf_node_patch%nodes, nnodes_base)

            ! Store the base node informationinto the relevant data strucutres
            ! These comprise the initial active node set
            do inode = 1, nnodes_base

                call rbf_node_temp%set_node(self%rbf_node_patch%nodes(base_node_indices(inode),:), radius_base)
                call active_nodes%push_back(base_node_indices(inode))
                call self%source_nodes_base%push_back(rbf_node_temp)
                call self%source_nodes%push_back(rbf_node_temp)
                self%rbf_node_patch%patch_to_rbf_index(base_node_indices(inode)) = inode
                self%rbf_node_patch%rbf_to_patch_index(inode) = base_node_indices(inode)

            end do

            ! The remaining nodes (explicit nodes) comprise the initial inactive node set
            do inode = 1, nnodes_total

                if (.not. (ANY(base_node_indices==inode))) then

                    call inactive_nodes%push_back(inode)

                end if

            end do

            ! Adaptively add the explicit nodes to the RBFI
            ! by moving one node at a time from the inactive to active node set.
            ! The inactive node with the largest distance to the active node set
            ! is selected to be added to the RBFI and moved to the active node set.

            num_inactive = inactive_nodes%size()

            num_active = active_nodes%size()

            do while (num_inactive>0)

                ! Loop over inactive nodes and find their distance to the active node set.
                ! Move the point with the greatest distance to the active node set.

                dist_max = ZERO
                inode_transfer = -1
                do inode = 1, num_inactive

                    inode_ig = inactive_nodes%at(inode)

                    ! Find the distance to the closest active node
                    min_dist = 1.0e16_rk
                    do inode_active = 1, num_active

                        inode_ag = active_nodes%at(inode_active)

                        current_dist = node_dist(self%rbf_node_patch%nodes(inode_ig,:),self%rbf_node_patch%nodes(inode_ag,:))

                        if (current_dist<min_dist) then
                            min_dist = current_dist
                        end if

                    end do

                    ! If this distance is the largest, mark the current inactive node to be activated
                    if (min_dist>dist_max) then
                        dist_max = min_dist
                        inode_transfer = inode_ig
                    end if

                end do
                radius_new = dist_max
                call rbf_node_temp%set_node(self%rbf_node_patch%nodes(inode_transfer,:), radius_new)
                call self%source_nodes_explicit%push_back(rbf_node_temp)
                call self%source_nodes%push_back(rbf_node_temp)

                call active_nodes%push_back(inode_transfer)
                call inactive_nodes%remove(inode_transfer)

                num_active = active_nodes%size()
                num_inactive = inactive_nodes%size()
                self%rbf_node_patch%patch_to_rbf_index(inode_transfer) = num_active
                self%rbf_node_patch%rbf_to_patch_index(num_active) = inode_transfer

            end do

            !
            ! Now, construct the interpolation matrix
            !

            call self%interpolation_matrix%init(nnodes_base, nnodes_explicit)

            do inode_source = 1, nnodes_base

                source_node = self%source_nodes_base%data(inode_source)%node_center
                radius_rbf = self%source_nodes_base%data(inode_source)%node_radius
                do inode_target = 1, nnodes_base

                    target_node = self%source_nodes_base%data(inode_target)%node_center
                    self%interpolation_matrix%A(inode_target, inode_source) = self%rbf%compute(target_node, source_node, radius_rbf)

                end do

                do inode_target = 1, nnodes_explicit

                    target_node = self%source_nodes_explicit%data(inode_target)%node_center
                    self%interpolation_matrix%B(inode_target, inode_source) = self%rbf%compute(target_node, source_node, radius_rbf)

                end do

            end do

            self%interpolation_matrix%Ainv = inv(self%interpolation_matrix%A)
            do inode_target = 1, nnodes_explicit

                target_node = self%source_nodes_explicit%data(inode_target)%node_center
                do inode_source = 1, inode_target
                    source_node = self%source_nodes_explicit%data(inode_source)%node_center
                    radius_rbf = self%source_nodes_explicit%data(inode_source)%node_radius

                    if (allocated(self%rbf_explicit)) then
                        self%interpolation_matrix%C(inode_target, inode_source) = self%rbf_explicit%compute(target_node, source_node, radius_rbf)
                    else
                        self%interpolation_matrix%C(inode_target, inode_source) = self%rbf%compute(target_node, source_node, radius_rbf)
                    end if

                end do

            end do

            self%interpolation_matrix%is_filled = .true.
        end if

    end subroutine construct_rbf_interpolation
    !********************************************************************************

    subroutine construct_rbf_interpolation_std(self, radius_base)
        class(rbf_interpolation_t),         intent(inout)   :: self
        real(rk),                           intent(in)      :: radius_base(3)

        type(ivector_t) :: active_nodes, inactive_nodes

        real(rk) :: radius_new(3), target_node(3), source_node(3), radius_rbf(3)
        real(rk) :: dist_max, min_dist, current_dist
        integer(ik) :: nnodes_total, nnodes_explicit
        integer(ik) :: inode, inode_active, inode_transfer, inode_ag, inode_ig, num_active, num_inactive, inode_source, inode_target

        type(rbf_node_t) :: rbf_node_temp

        integer(ik), allocatable :: base_node_indices(:)

        ! We may want to implement a NON-multiscale version to have a basis for comparision.

            ! Select the nnodes_base number of base nodes using k-means clustering
            nnodes_total = size(self%rbf_node_patch%nodes, 1)

            ! Store the base node informationinto the relevant data strucutres
            ! These comprise the initial active node set
            do inode = 1, nnodes_total

                call rbf_node_temp%set_node(self%rbf_node_patch%nodes(inode,:), radius_base)
                call active_nodes%push_back(inode)
                call self%source_nodes_base%push_back(rbf_node_temp)
                call self%source_nodes%push_back(rbf_node_temp)
                self%rbf_node_patch%patch_to_rbf_index(inode) = inode
                self%rbf_node_patch%rbf_to_patch_index(inode) = inode

            end do

            !
            ! Now, construct the interpolation matrix
            !

            allocate(self%interpolation_matrix%A(nnodes_total, nnodes_total))

            do inode_source = 1, nnodes_total

                source_node = self%source_nodes_base%data(inode_source)%node_center
                radius_rbf = self%source_nodes_base%data(inode_source)%node_radius
                do inode_target = 1, nnodes_total

                    target_node = self%source_nodes_base%data(inode_target)%node_center
                    self%interpolation_matrix%A(inode_target, inode_source) = self%rbf%compute(target_node, source_node, radius_rbf)

                end do
            end do

            self%interpolation_matrix%Ainv = inv(self%interpolation_matrix%A)

            self%interpolation_matrix%is_filled = .true.

    end subroutine construct_rbf_interpolation_std
    !********************************************************************************

    !>  Solves the RBF system with given source node values.
    !!
    !!  NOTE: The node ordering of source_node_vals is assumed to be the same as
    !!          the node ordering of rbf_node_patch%nodes. This is convenient, since
    !!          the we can easily evaluate PMM fomulas at the RBF patch nodes.
    !!
    !!        The rbf_node_patch handles the reordering of these nodes to be
    !!          consistent with the RBF system node ordering.
    !!
    !!  @author Eric Wolf
    !!  @date 10/19/2017
    !--------------------------------------------------------------------------------
    function solve(self, source_node_vals) result(rbf_coefficients)
        class(rbf_interpolation_t),         intent(inout)   :: self
        real(rk),                           intent(in)      :: source_node_vals(:)

        real(rk), allocatable   :: rbf_coefficients(:)

        real(rk), allocatable :: source_node_vals_rbf(:)

        !Re-index the source node values to conform to the RBF node ordering
        source_node_vals_rbf = self%rbf_node_patch%reorder_patch_to_rbf(source_node_vals)

        ! Now solve
        rbf_coefficients = self%interpolation_matrix%solve(source_node_vals_rbf)

    end function solve
    !********************************************************************************

    !>  Evaluates a single given RBF at a given node.
    !!
    !!
    !!  @author Eric Wolf
    !!  @date 10/19/2017
    !--------------------------------------------------------------------------------
    function evaluate_rbf(self, inode, eval_node) result(val)
        class(rbf_interpolation_t),         intent(inout)  :: self
        integer(ik),                        intent(in)  :: inode
        real(rk),                           intent(in)  :: eval_node(3)

        real(rk)                                        :: val
        val = self%rbf%compute(eval_node, self%source_nodes%data(inode)%node_center, self%source_nodes%data(inode)%node_radius)

    end function evaluate_rbf
    !********************************************************************************

    !>  evaluates the gradient of a single given RBF at a given node.
    !!
    !!
    !!  @author Eric Wolf
    !!  @date 10/19/2017
    !--------------------------------------------------------------------------------
    function evaluate_rbf_grad(self, inode, eval_node) result(val)
        class(rbf_interpolation_t),         intent(inout)  :: self
        integer(ik),                        intent(in)  :: inode
        real(rk),                           intent(in)  :: eval_node(3)
        real(rk)                                        :: val(3)

        val = self%rbf%compute_grad(eval_node, self%source_nodes%data(inode)%node_center, self%source_nodes%data(inode)%node_radius)

    end function evaluate_rbf_grad
    !********************************************************************************

    !>  Evaluate the RBF interpolation at a given node.
    !!
    !!
    !!  @author Eric Wolf
    !!  @date 10/19/2017
    !--------------------------------------------------------------------------------
    function evaluate(self,rbf_coeff, eval_node) result(val)
        class(rbf_interpolation_t),         intent(inout)  :: self
        real(rk),                           intent(in)  :: rbf_coeff(:)
        real(rk),                           intent(in)  :: eval_node(3)

        real(rk)                                        :: val

        integer(ik)     :: isource_node

        ! Naive implementation, not using compact support
        val = ZERO
        do isource_node = 1, self%rbf_node_patch%nnodes_patch

            val = val + rbf_coeff(isource_node)*self%evaluate_rbf(isource_node,eval_node)

        end do
    end function evaluate
    !********************************************************************************

    !>  Evaluates the gradient of the RBF interpolant at a given node.
    !!
    !!
    !!  @author Eric Wolf
    !!  @date 10/19/2017
    !--------------------------------------------------------------------------------
    function evaluate_grad(self,rbf_coeff, eval_node) result(val)
        class(rbf_interpolation_t),         intent(inout)  :: self
        real(rk),                           intent(in)  :: rbf_coeff(:)
        real(rk),                           intent(in)  :: eval_node(3)

        real(rk)                                        :: val(3)

        integer(ik)     :: isource_node

        ! Naive implementation, not using compact support

        val = ZERO
        do isource_node = 1, self%source_nodes%size()

            val = val + rbf_coeff(isource_node)*self%evaluate_rbf_grad(isource_node,eval_node)

        end do
    end function evaluate_grad
    !********************************************************************************

    !>  Evaluate the RBF interpolation at a given node.
    !!
    !!
    !!  @author Eric Wolf
    !!  @date 10/19/2017
    !--------------------------------------------------------------------------------
    function evaluate_ms(self,rbf_coeff, eval_node) result(val)
        class(rbf_interpolation_t),         intent(inout)  :: self
        real(rk),                           intent(in)  :: rbf_coeff(:)
        real(rk),                           intent(in)  :: eval_node(3)

        real(rk)                                        :: val

        integer(ik)     :: isource_node

        ! Naive implementation, not using compact support

        if (allocated(self%rbf_explicit)) then
            val = ZERO
            do isource_node = 1, self%source_nodes_base%size()

                val = val + rbf_coeff(isource_node)*self%rbf%compute(eval_node, &
                    self%source_nodes_base%data(isource_node)%node_center,&
                    self%source_nodes_base%data(isource_node)%node_radius)

            end do
            do isource_node = 1, self%source_nodes_explicit%size()

                val = val + rbf_coeff(self%source_nodes_base%size()+isource_node)*self%rbf_explicit%compute(eval_node, &
                    self%source_nodes_explicit%data(isource_node)%node_center,&
                    self%source_nodes_explicit%data(isource_node)%node_radius)

            end do

        else

            val = ZERO
            do isource_node = 1, self%rbf_node_patch%nnodes_patch

                val = val + rbf_coeff(isource_node)*self%evaluate_rbf(isource_node,eval_node)

            end do

        end if

    end function evaluate_ms
    !********************************************************************************

    !>  Evaluates the gradient of the RBF interpolant at a given node.
    !!
    !!
    !!  @author Eric Wolf
    !!  @date 10/19/2017
    !--------------------------------------------------------------------------------
    function evaluate_ms_grad(self,rbf_coeff, eval_node) result(val)
        class(rbf_interpolation_t),         intent(inout)  :: self
        real(rk),                           intent(in)  :: rbf_coeff(:)
        real(rk),                           intent(in)  :: eval_node(3)

        real(rk)                                        :: val(3)

        integer(ik)     :: isource_node

        ! Naive implementation, not using compact support

        if (allocated(self%rbf_explicit)) then
            val = ZERO
            do isource_node = 1, self%source_nodes_base%size()

                val = val + rbf_coeff(isource_node)*self%rbf%compute_grad(eval_node, &
                    self%source_nodes_base%data(isource_node)%node_center,&
                    self%source_nodes_base%data(isource_node)%node_radius)

            end do
            do isource_node = 1, self%source_nodes_explicit%size()

                val = val + rbf_coeff(self%source_nodes_base%size()+isource_node)*self%rbf_explicit%compute_grad(eval_node, &
                    self%source_nodes_explicit%data(isource_node)%node_center,&
                    self%source_nodes_explicit%data(isource_node)%node_radius)

            end do

        else
            val = ZERO
            do isource_node = 1, self%source_nodes%size()

                val = val + rbf_coeff(isource_node)*self%evaluate_rbf_grad(isource_node,eval_node)

            end do

        end if

    end function evaluate_ms_grad
    !********************************************************************************

end module type_rbf_interpolation


      SUBROUTINE STRPTP(N,ICOUNT,IDEG,R ,X)
C
C COMPUTES INITIAL POINTS FOR PATHS.
C
C ON INPUT:
C
C N  IS THE NUMBER OF (COMPLEX) VARIABLES.
C
C ICOUNT  IS A COUNTER USED TO INCREMENT EACH
C   VARIABLE AROUND THE UNIT CIRCLE SO THAT EVERY
C   COMBINATION OF START VALUES IS CHOSEN.  ICOUNT  IS
C   INITIALIZED IN  POLYP.
C
C IDEG(J)  IS THE DEGREE OF THE J-TH EQUATION.
C
C R(I,J)  IS A (COMPLEX) ARRAY GENERATED BY SUBROUTINE  INITP.
C   R(1,J), AND R(2,J) ARE THE REAL AND IMAGINARY PARTS, RESPECTIVELY.
C
C ON OUTPUT:
C
C X(I,J)  IS INITIALIZED TO THE START VALUES FOR THE CURRENT PATH,
C   WITH X(1,J) AND X(2,J) THE REAL AND IMAGINARY PARTS OF THE
C   J-TH VARIABLE, RESPECTIVELY.
C
C SUBROUTINES:  ATAN, COS, MULP, SIN.
C
C DECLARATION OF INPUT AND OUTPUT:
      INTEGER N,ICOUNT,IDEG
      DOUBLE PRECISION R ,X
      DIMENSION ICOUNT(N),IDEG(N)
      DIMENSION R(2,N),X(2,N)
C
C DECLARATION OF VARIABLES:
      INTEGER J
      DOUBLE PRECISION TWOPI,ANGLE,XXXX
      DIMENSION XXXX(2)
C
      DO 10 J=1,N
         IF(ICOUNT(J) .GE. IDEG(J) ) THEN
             ICOUNT(J)=1
           ELSE
             ICOUNT(J)=ICOUNT(J)+1
             GOTO 20
         END IF
  10  CONTINUE
  20  CONTINUE
      TWOPI = 8.0*ATAN(1.0)
      DO 30 J=1,N
          ANGLE = ( TWOPI/IDEG(J) )*ICOUNT(J)
          XXXX(1) = COS(ANGLE)
          XXXX(2) = SIN(ANGLE)
          CALL MULP(XXXX,R(1,J),X(1,J))
  30  CONTINUE
      RETURN
      END


*DECK DAI
      DOUBLE PRECISION FUNCTION DAI (X)
C***BEGIN PROLOGUE  DAI
C***PURPOSE  Evaluate the Airy function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10D
C***TYPE      DOUBLE PRECISION (AI-S, DAI-D)
C***KEYWORDS  AIRY FUNCTION, FNLIB, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DAI(X) calculates the double precision Airy function for double
C precision argument X.
C
C Series for AIF        on the interval -1.00000E+00 to  1.00000E+00
C                                        with weighted error   8.37E-33
C                                         log weighted error  32.08
C                               significant figures required  30.87
C                                    decimal places required  32.63
C
C Series for AIG        on the interval -1.00000E+00 to  1.00000E+00
C                                        with weighted error   7.47E-34
C                                         log weighted error  33.13
C                               significant figures required  31.50
C                                    decimal places required  33.68
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, D9AIMP, DAIE, DCSEVL, INITDS, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920618  Removed space from variable names.  (RWC, WRB)
C***END PROLOGUE  DAI
      DOUBLE PRECISION X, AIFCS(13), AIGCS(13), THETA, XM, XMAX, X3SML,
     1  Z, D1MACH, DCSEVL, DAIE, XMAXT
      LOGICAL FIRST
      SAVE AIFCS, AIGCS, NAIF, NAIG, X3SML, XMAX, FIRST
      DATA AIFCS(  1) / -.3797135849 6669997496 1970894694 14 D-1     /
      DATA AIFCS(  2) / +.5919188853 7263638574 3197280137 77 D-1     /
      DATA AIFCS(  3) / +.9862928057 7279975365 6038910440 60 D-3     /
      DATA AIFCS(  4) / +.6848843819 0765667554 8548301824 12 D-5     /
      DATA AIFCS(  5) / +.2594202596 2194713019 4892790814 03 D-7     /
      DATA AIFCS(  6) / +.6176612774 0813750329 4457496972 36 D-10    /
      DATA AIFCS(  7) / +.1009245417 2466117901 4295562246 01 D-12    /
      DATA AIFCS(  8) / +.1201479251 1179938141 2880332253 33 D-15    /
      DATA AIFCS(  9) / +.1088294558 8716991878 5252954666 66 D-18    /
      DATA AIFCS( 10) / +.7751377219 6684887039 2384000000 00 D-22    /
      DATA AIFCS( 11) / +.4454811203 7175638391 4666666666 66 D-25    /
      DATA AIFCS( 12) / +.2109284523 1692343466 6666666666 66 D-28    /
      DATA AIFCS( 13) / +.8370173591 0741333333 3333333333 33 D-32    /
      DATA AIGCS(  1) / +.1815236558 1161273011 5562099578 64 D-1     /
      DATA AIGCS(  2) / +.2157256316 6010755534 0306388199 68 D-1     /
      DATA AIGCS(  3) / +.2567835698 7483249659 0524280901 33 D-3     /
      DATA AIGCS(  4) / +.1426521411 9792403898 8294969217 21 D-5     /
      DATA AIGCS(  5) / +.4572114920 0180426070 4340975581 91 D-8     /
      DATA AIGCS(  6) / +.9525170843 5647098607 3922788405 92 D-11    /
      DATA AIGCS(  7) / +.1392563460 5771399051 1504206861 90 D-13    /
      DATA AIGCS(  8) / +.1507099914 2762379592 3069911386 66 D-16    /
      DATA AIGCS(  9) / +.1255914831 2567778822 7032053333 33 D-19    /
      DATA AIGCS( 10) / +.8306307377 0821340343 8293333333 33 D-23    /
      DATA AIGCS( 11) / +.4465753849 3718567445 3333333333 33 D-26    /
      DATA AIGCS( 12) / +.1990085503 4518869333 3333333333 33 D-29    /
      DATA AIGCS( 13) / +.7470288525 6533333333 3333333333 33 D-33    /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DAI
      IF (FIRST) THEN
         NAIF = INITDS (AIFCS, 13, 0.1*REAL(D1MACH(3)))
         NAIG = INITDS (AIGCS, 13, 0.1*REAL(D1MACH(3)))
C
         X3SML = D1MACH(3)**0.3334D0
         XMAXT = (-1.5D0*LOG(D1MACH(1)))**0.6667D0
         XMAX = XMAXT - XMAXT*LOG(XMAXT)/(4.0D0*SQRT(XMAXT)+1.0D0)
     *           - 0.01D0
      ENDIF
      FIRST = .FALSE.
C
      IF (X.GE.(-1.D0)) GO TO 20
      CALL D9AIMP (X, XM, THETA)
      DAI = XM * COS(THETA)
      RETURN
C
 20   IF (X.GT.1.0D0) GO TO 30
      Z = 0.0D0
      IF (ABS(X).GT.X3SML) Z = X**3
      DAI = 0.375D0 + (DCSEVL (Z, AIFCS, NAIF) - X*(0.25D0 +
     1  DCSEVL (Z, AIGCS, NAIG)) )
      RETURN
C
 30   IF (X.GT.XMAX) GO TO 40
      DAI = DAIE(X) * EXP(-2.0D0*X*SQRT(X)/3.0D0)
      RETURN
C
 40   DAI = 0.0D0
      CALL XERMSG ('SLATEC', 'DAI', 'X SO BIG AI UNDERFLOWS', 1, 1)
      RETURN
C
      END


module mod_network

  use mod_activation, only: gaussian, gaussian_prime,&
                            relu, relu_prime,&
                            sigmoid, sigmoid_prime,&
                            step, step_prime,&
                            tanhf, tanh_prime
  use mod_kinds, only: ik, rk
  use mod_layer, only: array1d, array2d, db_init, dw_init,&
                       db_co_sum, dw_co_sum, layer_type
  use mod_parallel, only: tile_indices

  implicit none

  private
  public :: network_type

  type :: network_type

    type(layer_type), allocatable :: layers(:)
    integer, allocatable :: dims(:)
    procedure(activation_function), pointer, nopass :: activation => null()
    procedure(activation_function), pointer, nopass :: activation_prime => null()

  contains

    procedure, public, pass(self) :: accuracy
    procedure, public, pass(self) :: backprop
    procedure, public, pass(self) :: fwdprop
    procedure, public, pass(self) :: init
    procedure, public, pass(self) :: load
    procedure, public, pass(self) :: loss
    procedure, public, pass(self) :: output
    procedure, public, pass(self) :: save
    procedure, public, pass(self) :: set_activation
    procedure, public, pass(self) :: sync
    procedure, public, pass(self) :: train_batch
    procedure, public, pass(self) :: train_single
    procedure, public, pass(self) :: update

    generic, public :: train => train_batch, train_single

  end type network_type

  interface network_type
    module procedure :: net_constructor
  endinterface network_type

  interface
    pure function activation_function(x)
      import :: rk
      real(rk), intent(in) :: x(:)
      real(rk) :: activation_function(size(x))
    end function activation_function
  end interface

contains

  type(network_type) function net_constructor(dims, activation) result(net)
    ! Network class constructor. Size of input array dims indicates the total
    ! number of layers (input + hidden + output), and the value of its elements
    ! corresponds the size of each layer.
    integer(ik), intent(in) :: dims(:)
    character(len=*), intent(in), optional :: activation
    call net % init(dims)
    if (present(activation)) then
      call net % set_activation(activation)
    else
      call net % set_activation('sigmoid')
    end if
    call net % sync(1)
  end function net_constructor

  pure real(rk) function accuracy(self, x, y)
    ! Given input x and output y, evaluates the position of the
    ! maximum value of the output and returns the number of matches
    ! relative to the size of the dataset.
    class(network_type), intent(in) :: self
    real(rk), intent(in) :: x(:,:), y(:,:)
    integer(ik) :: i, good
    good = 0
    do i = 1, size(x, dim=2)
      if (all(maxloc(self % output(x(:,i))) == maxloc(y(:,i)))) then
        good = good + 1
      end if
    end do
    accuracy = real(good) / size(x, dim=2)
  end function accuracy

  pure subroutine backprop(self, y, dw, db)
    ! Applies a backward propagation through the network
    ! and returns the weight and bias gradients.
    class(network_type), intent(in out) :: self
    real(rk), intent(in) :: y(:)
    type(array2d), allocatable, intent(out) :: dw(:)
    type(array1d), allocatable, intent(out) :: db(:)
    integer :: n, nm

    associate(dims => self % dims, layers => self % layers)

      call db_init(db, dims)
      call dw_init(dw, dims)

      n = size(dims)
      db(n) % array = (layers(n) % a - y) * self % activation_prime(layers(n) % z)
      dw(n-1) % array = matmul(reshape(layers(n-1) % a, [dims(n-1), 1]),&
                               reshape(db(n) % array, [1, dims(n)]))

      do n = size(dims) - 1, 2, -1
        db(n) % array = matmul(layers(n) % w, db(n+1) % array)&
                      * self % activation_prime(layers(n) % z)
        dw(n-1) % array = matmul(reshape(layers(n-1) % a, [dims(n-1), 1]),&
                                 reshape(db(n) % array, [1, dims(n)]))
      end do

    end associate

  end subroutine backprop

  pure subroutine fwdprop(self, x)
    ! Performs the forward propagation and stores arguments to activation
    ! functions and activations themselves for use in backprop.
    class(network_type), intent(in out) :: self
    real(rk), intent(in) :: x(:)
    integer(ik) :: n
    associate(layers => self % layers)
      layers(1) % a = x
      do n = 2, size(layers)
        layers(n) % z = matmul(transpose(layers(n-1) % w), layers(n-1) % a) + layers(n) % b
        layers(n) % a = self % activation(layers(n) % z)
      end do
    end associate
  end subroutine fwdprop

  subroutine init(self, dims)
    ! Allocates and initializes the layers with given dimensions dims.
    class(network_type), intent(in out) :: self
    integer(ik), intent(in) :: dims(:)
    integer(ik) :: n
    self % dims = dims
    if (.not. allocated(self % layers)) allocate(self % layers(size(dims)))
    do n = 1, size(dims) - 1
      self % layers(n) = layer_type(dims(n), dims(n+1))
    end do
    self % layers(n) = layer_type(dims(n), 1)
    self % layers(1) % b = 0
    self % layers(size(dims)) % w = 0
  end subroutine init

  subroutine load(self, filename)
    ! Loads the network from file.
    class(network_type), intent(in out) :: self
    character(len=*), intent(in) :: filename
    integer(ik) :: fileunit, n, num_layers
    integer(ik), allocatable :: dims(:)
    open(newunit=fileunit, file=filename, status='old', action='read')
    read(fileunit, fmt=*) num_layers
    allocate(dims(num_layers))
    read(fileunit, fmt=*) dims
    call self % init(dims)
    do n = 2, size(self % dims)
      read(fileunit, fmt=*) self % layers(n) % b
    end do
    do n = 1, size(self % dims) - 1
      read(fileunit, fmt=*) self % layers(n) % w
    end do
    close(fileunit)
  end subroutine load

  pure real(rk) function loss(self, x, y)
    ! Given input x and expected output y, returns the loss of the network.
    class(network_type), intent(in) :: self
    real(rk), intent(in) :: x(:), y(:)
    loss = 0.5 * sum((y - self % output(x))**2) / size(x)
  end function loss

  pure function output(self, x) result(a)
    ! Use forward propagation to compute the output of the network.
    class(network_type), intent(in) :: self
    real(rk), intent(in) :: x(:)
    real(rk), allocatable :: a(:)
    integer(ik) :: n
    associate(layers => self % layers)
      a = self % activation(matmul(transpose(layers(1) % w), x) + layers(2) % b)
      do n = 3, size(layers)
        a = self % activation(matmul(transpose(layers(n-1) % w), a) + layers(n) % b)
      end do
    end associate
  end function output

  subroutine save(self, filename)
    ! Saves the network to a file.
    class(network_type), intent(in out) :: self
    character(len=*), intent(in) :: filename
    integer(ik) :: fileunit, n
    open(newunit=fileunit, file=filename)
    write(fileunit, fmt=*) size(self % dims)
    write(fileunit, fmt=*) self % dims
    do n = 2, size(self % dims)
      write(fileunit, fmt=*) self % layers(n) % b
    end do
    do n = 1, size(self % dims) - 1
      write(fileunit, fmt=*) self % layers(n) % w
    end do
    close(fileunit)
  end subroutine save

  pure subroutine set_activation(self, activation)
    ! Sets the activation functions. Input string must match one of
    ! provided activation functions, otherwise it defaults to sigmoid.
    ! If activation not present, defaults to sigmoid.
    class(network_type), intent(in out) :: self
    character(len=*), intent(in) :: activation
    select case(trim(activation))
      case('gaussian')
        self % activation => gaussian
        self % activation_prime => gaussian_prime
      case('relu')
        self % activation => relu
        self % activation_prime => relu_prime
      case('sigmoid')
        self % activation => sigmoid
        self % activation_prime => sigmoid_prime
      case('step')
        self % activation => step
        self % activation_prime => step_prime
      case('tanh')
        self % activation => tanhf
        self % activation_prime => tanh_prime
      case default
        self % activation => sigmoid
        self % activation_prime => sigmoid_prime
    end select
  end subroutine set_activation

  subroutine sync(self, image)
    ! Broadcasts network weights and biases from
    ! specified image to all others.
    class(network_type), intent(in out) :: self
    integer(ik), intent(in) :: image
    integer(ik) :: n
    if (num_images() == 1) return
    layers: do n = 1, size(self % dims)
      call co_broadcast(self % layers(n) % b, image)
      call co_broadcast(self % layers(n) % w, image)
    end do layers
  end subroutine sync

  subroutine train_batch(self, x, y, eta)
    ! Trains a network using input data x and output data y,
    ! and learning rate eta. The learning rate is normalized
    ! with the size of the data batch.
    class(network_type), intent(in out) :: self
    real(rk), intent(in) :: x(:,:), y(:,:), eta
    type(array1d), allocatable :: db(:), db_batch(:)
    type(array2d), allocatable :: dw(:), dw_batch(:)
    integer(ik) :: i, im, n, nm
    integer(ik) :: is, ie, indices(2)

    im = size(x, dim=2) ! mini-batch size
    nm = size(self % dims) ! number of layers

    ! get start and end index for mini-batch
    indices = tile_indices(im)
    is = indices(1)
    ie = indices(2)

    call db_init(db_batch, self % dims)
    call dw_init(dw_batch, self % dims)

    do concurrent(i = is:ie)
      call self % fwdprop(x(:,i))
      call self % backprop(y(:,i), dw, db)
      do concurrent(n = 1:nm)
        dw_batch(n) % array =  dw_batch(n) % array + dw(n) % array
        db_batch(n) % array =  db_batch(n) % array + db(n) % array
      end do
    end do

    if (num_images() > 1) then
      call dw_co_sum(dw_batch)
      call db_co_sum(db_batch)
    end if

    call self % update(dw_batch, db_batch, eta / im)

  end subroutine train_batch

  pure subroutine train_single(self, x, y, eta)
    ! Trains a network using a single set of input data x and output data y,
    ! and learning rate eta.
    class(network_type), intent(in out) :: self
    real(rk), intent(in) :: x(:), y(:), eta
    type(array2d), allocatable :: dw(:)
    type(array1d), allocatable :: db(:)
    call self % fwdprop(x)
    call self % backprop(y, dw, db)
    call self % update(dw, db, eta)
  end subroutine train_single

  pure subroutine update(self, dw, db, eta)
    ! Updates network weights and biases with gradients dw and db,
    ! scaled by learning rate eta.
    class(network_type), intent(in out) :: self
    class(array2d), intent(in) :: dw(:)
    class(array1d), intent(in) :: db(:)
    real(rk), intent(in) :: eta
    integer(ik) :: n

    associate(layers => self % layers, nm => size(self % dims))
      ! update biases
      do concurrent(n = 2:nm)
        layers(n) % b = layers(n) % b - eta * db(n) % array
      end do
      ! update weights
      do concurrent(n = 1:nm-1)
        layers(n) % w = layers(n) % w - eta * dw(n) % array
      end do
    end associate

  end subroutine update

end module mod_network


C***********************************************************************
C***********************************************************************
C*********     BLKDINV ... Compute the diagonal of the inverse *********
C***********************************************************************
C***********************************************************************
C
C   PURPOSE:
C       GIVEN THE CHOLESKY FACTORIZATION OF A SPARSE SYMMETRIC
C       POSITIVE DEFINITE MATRIX, THIS SUBROUTINE computes the
C       diagonal of the inverse of the given matrix.
C       IT USES OUTPUT FROM BLKFCT.
C
C   INPUT PARAMETERS:
C       NSUPER          -   NUMBER OF SUPERNODES.
C       XSUPER          -   SUPERNODE PARTITION.
C       (XLINDX,LINDX)  -   ROW INDICES FOR EACH SUPERNODE.
C       (XLNZ,LNZ)      -   CHOLESKY FACTOR.
C
C   UPDATED PARAMETERS:
C       DINV            -   OUTPUT, CONTAINS THE diagonal of the inverse
C
C   for j = 1:n
C      solve L*y = e_j
C      w = D\y
C      dinv(j) = y^T*w
C   end for
C
C***********************************************************************
C
      SUBROUTINE  BLKDINV (  NSUPER, XSUPER, XLINDX, LINDX , XLNZ  ,
     &                       LNZ   , DINVP , Y,      mark, nzidx, perm )
      implicit none
C
C***********************************************************************
C
        INTEGER             NSUPER
        INTEGER             LINDX(*)      , XSUPER(*), perm(*)
        INTEGER             XLINDX(*)     , XLNZ(*)
        DOUBLE PRECISION    LNZ(*)        , DINVP(*)
        REAL*8, allocatable, dimension(:) :: DINV
        DOUBLE PRECISION    Y(*)
C
C***********************************************************************
C
        INTEGER             FJCOL , I     , IPNT  , IX    , IXSTOP,
     &                      IXSTRT, JCOL  , JPNT  , JSUP  , LJCOL
        DOUBLE PRECISION    T
        integer             neqns, jsup2, jcol2
        integer             mark(*), nzidx(*)
        integer             nnz, j, jx

C
C***********************************************************************
C
        IF  ( NSUPER .LE. 0 )  RETURN
C
        neqns = XSUPER(NSUPER+1)-1
        allocate(dinv(neqns))

        DO J = 1, NEQNS
           DINV(J) = 0.0d0
           DINVP(J) = 0.0d0
           mark(j) = 0
c           nzidx(j) = -1;
           Y(J) = 0.0d0
        ENDDO

        DO jsup2 = 1,nsuper
           DO jcol2 = XSUPER(jsup2),XSUPER(jsup2+1)-1
C
              Y(jcol2) = 1.0d0
              mark(jcol2) = 1
              nnz = 1
              nzidx(nnz) = jcol2
C
C             ------------------------
C             FORWARD SUBSTITUTION ...
C             ------------------------
C
              FJCOL = jcol2
              DO JSUP = jsup2, NSUPER
                 LJCOL  = XSUPER(JSUP+1) - 1
                 IXSTRT = XLNZ(FJCOL)
                 JPNT   = XLINDX(JSUP)+ FJCOL-XSUPER(JSUP)
                 DO JCOL = FJCOL, LJCOL
                    IXSTOP    = XLNZ(JCOL+1) - 1
                    T         = Y(JCOL)
                    IF (T .NE. 0.0) then
                       IPNT      = JPNT +1
                       DO IX = IXSTRT+1, IXSTOP
                          I    = LINDX(IPNT)
                          Y(I) = Y(I) - T*LNZ(IX)
                          IPNT = IPNT + 1
                          if (mark(i) .eq. 0) then
                             mark(i) = 1
                             nnz = nnz + 1
                             nzidx(nnz) = i
                          endif
                       ENDDO
                    endif
                    IXSTRT = IXSTOP + 1
                    JPNT   = JPNT + 1
                 ENDDO
                 FJCOL = LJCOL + 1
              ENDDO
C
C             ------------------
C             DIAGONAL SOLVE ...
C             ------------------
c              DO  J = JCOL2, neqns
c                  W(J) = Y(J) / LNZ(XLNZ(J))
c              ENDDO
c
c               dinv(jcol2) = 0.0
c               do j = jcol2,neqns
c                  dinv(jcol2) = dinv(jcol2) + y(j)*y(j)/lnz(xlnz(j))
c                  nzidx(j) = -1
cc                  mark(j) = 0
c                  y(j) = 0.0d0
c               enddo
               do j = 1, nnz
                  i = nzidx(j)
                  dinv(jcol2) = dinv(jcol2) + y(i)*y(i)/lnz(xlnz(i))
c                  nzidx(j) = -1
                  mark(i) = 0
                  Y(i)    = 0.0d0
               end do
           ENDDO
        ENDDO
        DO JSUP = 1, NSUPER
           FJCOL = XSUPER(JSUP)
           LJCOL = XSUPER(JSUP+1)-1
           DO JCOL = FJCOL,LJCOL
              dinvp(PERM(JCOL)) = dinv(JCOL)
           ENDDO
        ENDDO
        deallocate(dinv)
C
        RETURN
      END


!--------------------------------------------------------------------
! This file is part of HiggsSignals (TS 31/01/2013)
!--------------------------------------------------------------------
module combinatorics

 implicit none
 integer, allocatable :: indices(:,:)
 integer, allocatable :: peakindices(:,:,:)

 contains
!--------------------------------------------------------------------
  subroutine create_peakindices(npeaks, nhiggs)
!--------------------------------------------------------------------
 integer, intent(in) :: npeaks, nhiggs
!--Internal parameter:
 integer, allocatable :: Higgs_avail(:,:),Higgs_avail_tmp(:,:)
 integer, allocatable :: peakindices_tmp(:,:,:),peakindices_big(:,:,:)
 integer :: ncomb, a, b, i, j, N, nphcomb, jj
 logical :: avail, zeros

if(npeaks.le.0) then
 write(*,*) 'WARNING in subroutine create_peakindices:',&
 &   	    'npeaks must be greater than 0!'
else
 call create_indices(nhiggs)
 ncomb=ncombinations(nhiggs)+1

! nphcomb=npeakhiggscombs(nhiggs,npeaks)+1
! allocate(peakindices(nphcomb,npeaks,nhiggs))
! allocate(Higgs_avail(nphcomb,nhiggs))

! We first create very big matrices and reduce them later to the number
! of irreducible combinations: This should be the correct number, otherwise
! there will be a warning later...
 nphcomb = (npeaks+1)**(nhiggs)
 allocate(peakindices_big(nphcomb,npeaks,nhiggs))
 allocate(Higgs_avail(nphcomb,nhiggs))

 !Make all Higgses available by setting all entries of Higgs_avail to 1
 do i=lbound(Higgs_avail,dim=1),ubound(Higgs_avail,dim=1)
  do j=lbound(Higgs_avail,dim=2),ubound(Higgs_avail,dim=2)
   Higgs_avail(i,j)=1
  enddo
 enddo

 N=1
 do i=1,npeaks
  b=N
  do j=1, ncomb
!  if(i.ne.1) then
 !-Copy all existing matrices to a temporary matrix collection
   allocate(peakindices_tmp(N,npeaks,nhiggs))
   allocate(Higgs_avail_tmp(N,nhiggs))
   do a=1, N
     call copy_matrices(peakindices_big(a,:,:),peakindices_tmp(a,:,:))
     Higgs_avail_tmp(a,lbound(Higgs_avail_tmp,dim=2):ubound(Higgs_avail_tmp,dim=2)) &
     & =Higgs_avail(a,lbound(Higgs_avail_tmp,dim=2):ubound(Higgs_avail_tmp,dim=2))
   enddo
!  endif

   do a=1, N
    call check_Higgs_avail(avail, zeros, Higgs_avail_tmp(a,:), indices(j,:))
!	write(*,*) "a=",a,", b=",b," , N=",N
!    write(*,*) "Higgs_avail(a,:) = ",Higgs_avail_tmp(a,:)
!    write(*,*) "indices(j,:) = ",indices(j,:)
!    write(*,*) "avail = ", avail
!    write(*,*) "zeros = ", zeros
    if(avail) then
     if(zeros) then
!      write(*,*) "... filling existing matrix with a row containing zeros..."
!-----Add another row (for this peak) to the existing matrices
      peakindices_big(a, i, lbound(peakindices_big,dim=3):ubound(peakindices_big,dim=3)) &
     & = indices(j,lbound(indices,dim=2):ubound(indices,dim=2))
      Higgs_avail(a,lbound(Higgs_avail,dim=2):ubound(Higgs_avail,dim=2)) = &
     & Higgs_avail_tmp(a,lbound(Higgs_avail_tmp,dim=2):ubound(Higgs_avail_tmp,dim=2))
     else
!      write(*,*) "... create new matrix and add a row..."
      b=b+1
      call copy_matrices(peakindices_tmp(a,:,:),peakindices_big(b,:,:))
      peakindices_big(b,i,lbound(peakindices_big,dim=3):ubound(peakindices_big,dim=3)) &
     & = indices(j,lbound(indices,dim=2):ubound(indices,dim=2))
      Higgs_avail(b,lbound(Higgs_avail,dim=2):ubound(Higgs_avail,dim=2)) = &
     & Higgs_avail_tmp(a,lbound(Higgs_avail_tmp,dim=2):ubound(Higgs_avail_tmp,dim=2))
!DEBUGGING
!      write(*,*) "peakindices(",b,jj,"):"
!      do jj = lbound(peakindices,dim=2),ubound(peakindices,dim=2)
!       write(*,*) peakindices(b,jj,:)
!      enddo

     endif
    endif
   enddo
   deallocate(peakindices_tmp)
   deallocate(Higgs_avail_tmp)
  enddo
  N=b

 enddo

 deallocate(indices)

!NEW:
 deallocate(Higgs_avail)
 allocate(peakindices(N,npeaks,nhiggs))
 do a=lbound(peakindices,dim=1),ubound(peakindices,dim=1)
  call copy_matrices(peakindices_big(a,:,:),peakindices(a,:,:))
 enddo
 deallocate(peakindices_big)

!-
 if(N.ne.nphcomb) then
 write(*,*) "WARNING in subroutine create_peakindices:",&
 & " problem with number of possible combinations."
 write(*,*) "created peakindices for nhiggs/npeak = ",nhiggs,npeaks
 write(*,*) "N = ", N
 write(*,*) "nphcomb = ", nphcomb
 endif

 endif

 end subroutine create_peakindices
!--------------------------------------------------------------------
 subroutine check_Higgs_avail(avail, zeros, Higgs_avail, Higgs_comb)
!--------------------------------------------------------------------
  logical, intent(out) :: avail, zeros
  integer, dimension(:) :: Higgs_avail
  integer, dimension(:), intent(in) :: Higgs_comb
  integer :: i

  !First, check if dimensions match:
  if(size(Higgs_avail).ne.size(Higgs_comb)) then
   write(*,*) 'WARNING in subroutine check_Higgs_avail: dimensions of',&
   &		  'Higgs_avail and Higgs_comb do not match!'
  else
  !-Check, whether the Higgs_comb is still available:
   avail=.True.
   zeros=.True.
   do i=1, size(Higgs_comb)
    if(avail) then
     if(Higgs_comb(i).ne.0) then
      zeros=.False.
      if(Higgs_avail(Higgs_comb(i)).eq.0) avail=.False.
     endif
    endif
   enddo

   if(avail.and.(.not.zeros)) then
   !-This combination is available. Now make the used Higgses unavailable
   !-for other combinations
    do i=1, size(Higgs_comb)
     if(Higgs_comb(i).ne.0) Higgs_avail(Higgs_comb(i)) = 0
    enddo
   endif
  endif

 end subroutine check_Higgs_avail
!--------------------------------------------------------------------
 subroutine copy_matrices(matrix_in, matrix_out)
!--------------------------------------------------------------------
 integer, dimension(:,:), intent(in) :: matrix_in
 integer, dimension(:,:), intent(out) :: matrix_out
 integer :: a,b

   if(size(matrix_in,dim=1).ne.size(matrix_out,dim=1).or. &
&     size(matrix_in,dim=2).ne.size(matrix_out,dim=2)) then
   write(*,*) 'WARNING in subroutine copy matrices: dimensions of',&
   &		  'matrices do not match!'
   else
    do a=lbound(matrix_in,dim=1),ubound(matrix_in,dim=1)
     do b=lbound(matrix_in,dim=2),ubound(matrix_in,dim=2)
	  matrix_out(a,b)=matrix_in(a,b)
     enddo
    enddo
   endif

 end subroutine copy_matrices
!--------------------------------------------------------------------
  subroutine create_indices(nhiggs)
!--------------------------------------------------------------------
  integer, intent(in) :: nhiggs
  integer :: ncombs, a, i, j, k, x, ii, m, leader
  integer, allocatable :: s(:)

  ! Calculate the number of possible (irreducible) Higgs combinations
  ncombs=ncombinations(nhiggs)+1

!  write(*,*) 'ncombs = ', ncombs

  allocate(indices(ncombs,nhiggs))
  ! Fill the matrix indices with all possible Higgs combinations
  ! Fill the first row of indices with zeros
  do i=lbound(indices,dim=2),ubound(indices,dim=2)
   indices(1,i)=0
  enddo

! Fill the matrix column by column (i,j)
  do j=1,nhiggs
   a=1
! First column
   if(j.eq.1) then
    do i=1,nhiggs
     do ii=1,2**(i-1)
      a=a+1
      indices(a,j)=i
     enddo
    enddo
! Preceding columns
   else
    a=1
	do while (a < ncombs)
     a=a+1
     leader = indices(a,j-1)
     indices(a,j)=0
     if(leader.ne.1) then
      do i=1,leader-1
       do ii=1,2**(i-1)
        a=a+1
        indices(a,j)=i
       enddo
      enddo
     endif
    enddo
   endif
  enddo

!  write(*,*) "Indices:"
!  do i=1,ncombs
!   write(*,*) indices(i,:)
!  enddo
!  if(a.ne.ncombs) write(*,*) "WARNING in subroutine create indices:",&
!  				" Higgs combinations do not match! a=",a,", ncomb=",ncombs

  end subroutine create_indices
!--------------------------------------------------------------------
  function ncombinations(nhiggs)
!--------------------------------------------------------------------
  integer, intent(in) :: nhiggs
  integer :: ncombinations, x
  integer, allocatable :: s(:)
  integer :: kk
  ! Calculate the number of possible (irreducible) Higgs combinations
  allocate(s(nhiggs+1))
  s(1)=0
  do x=1,nhiggs
   s(x+1)=s(x)+(x-1)
  enddo
  ncombinations=sum(s)+nhiggs+1
!NEW
  deallocate(s)

  ncombinations=0
  do kk=0,nhiggs-1
   ncombinations = ncombinations + 2**kk
  enddo

  end function ncombinations
!--------------------------------------------------------------------
!  function nsubcombinations(nhiggs, ncomb)
!!--------------------------------------------------------------------
!  integer, intent(in) :: nhiggs, ncomb
!  integer :: nsubcombinations
!  integer :: i
!
!  if((nhiggs.lt.ncomb).or.(nhiggs.le.0).or.(ncomb.lt.0)) then
!   write(*,*) "WARNING in function nsubcombinations: nhiggs or ncomb not valid!"
!  else
!   if(ncomb.eq.0) then
!    nsubcombinations = 1
!   else if(ncomb.eq.1) then
!    nsubcombinations = nhiggs
!   else
!    nsubcombinations=0
!	do i=ncomb,nhiggs
!	 nsubcombinations=nsubcombinations+(i-ncomb+1)
!	enddo
!   endif
!  endif
!  end function nsubcombinations
!--------------------------------------------------------------------
!  recursive function npeakhiggscombs(nhiggs, npeaks) result(N)
!!--------------------------------------------------------------------
!  integer, intent(in) :: nhiggs, npeaks
!  integer :: j,k,N
!
!!  write(*,*) "Start npeakhiggscombs with nhiggs=",nhiggs,", npeaks=",npeaks
!
!  if(npeaks.lt.1) then
!   write(*,*) "WARNING in function npeakhiggscombs: npeak not valid!"
!   N=0
!  else if(nhiggs.lt.1) then
!   N=1
!  else
!   if(npeaks.eq.1) then
!    N=ncombinations(nhiggs)
!   else if(nhiggs.eq.1) then
!    N=npeaks+1
!   else
!    N=0
!    do j=0, nhiggs
!     do k=1,nsubcombinations(nhiggs,j)
!      N=N+npeakhiggscombs(nhiggs-j,npeaks-1)
!     enddo
!    enddo
!   endif
!  endif
!
!  end function npeakhiggscombs
!--------------------------------------------------------------------
end module combinatorics
!--------------------------------------------------------------------


      SUBROUTINE EEVMM (VWWNLM, PJVPLM, VWMPMT)

C note: no 3D version (eevmm3) because standard does not specify
C a unique transformation.

      REAL   VWMPMT(3,3), VWWNLM(4), PJVPLM(4)

      CALL EBLTM (VWWNLM(1),VWWNLM(3),
     1             PJVPLM(1)-VWWNLM(1), PJVPLM(3)-VWWNLM(3), 0.0,
     2            (PJVPLM(2)-PJVPLM(1))/(VWWNLM(2)-VWWNLM(1)),
     3            (PJVPLM(4)-PJVPLM(3))/(VWWNLM(4)-VWWNLM(3)),  VWMPMT)

      END