!>  This module contains procedures for initializing and maintaining the Chimera
!!  interfaces.
!!
!!  detect_chimera_faces
!!  detect_chimera_donors
!!  compute_chimera_interpolators
!!  find_gq_donor
!!  clear_donor_cache
!!
!!  detect_chimera_faces, detect_chimera_donors, and compute_chimera_interpolators are probably
!!  called in src/parallel/mod_communication.f90%establish_chimera_communication.
!!
!!  @author Nathan A. Wukie
!!  @date   2/1/2016
!!
!!
!-----------------------------------------------------------------------------------
module mod_chimera
#include <messenger.h>
    use mod_kinds,              only: rk, ik
    use mod_constants,          only: NFACES, ORPHAN, CHIMERA, &
                                      XI_DIR, ETA_DIR, ZETA_DIR, &
                                      ONE, ZERO, TWO, TWO_DIM, THREE_DIM, &
                                      NO_PROC, NO_ID

    use type_point
    use type_mesh,              only: mesh_t
    use type_chimera_send,      only: chimera_send
    use type_element_info,      only: element_info_t, element_info
    use type_face_info,         only: face_info_t, face_info
    use type_ivector,           only: ivector_t
    use type_rvector,           only: rvector_t
    use type_pvector,           only: pvector_t
    use type_mvector,           only: mvector_t

    use mod_determinant,        only: det_3x3
    use mod_polynomial,         only: polynomial_val, dpolynomial_val
    use mod_periodic,           only: get_periodic_offset
    use mod_chidg_mpi,          only: IRANK, NRANK, ChiDG_COMM
    use mpi_f08,                only: MPI_BCast, MPI_Send, MPI_Recv, MPI_INTEGER4, MPI_REAL8, &
                                      MPI_LOGICAL, MPI_ANY_TAG, MPI_STATUS_IGNORE
    use ieee_arithmetic,        only: ieee_is_nan
    implicit none

    integer(ik) :: idomain_g_prev = NO_ID
    integer(ik) :: idomain_l_prev = NO_ID
    integer(ik) :: ielement_g_prev = NO_ID
    integer(ik) :: ielement_l_prev = NO_ID

    type, public, abstract:: multi_donor_rule_t

    contains
        procedure(select_donor_interface), deferred, nopass :: select_donor
    end type multi_donor_rule_t

    abstract interface
        function select_donor_interface(mesh,donors,candidate_domains_g,candidate_domains_l,candidate_elements_g,candidate_elements_l) result(donor_index)
            import mesh_t
            import ivector_t
            import ik
            type(mesh_t),       intent(in)  :: mesh
            type(ivector_t),    intent(in)  :: donors
            type(ivector_t),    intent(in)  :: candidate_domains_g
            type(ivector_t),    intent(in)  :: candidate_domains_l
            type(ivector_t),    intent(in)  :: candidate_elements_g
            type(ivector_t),    intent(in)  :: candidate_elements_l
            integer(ik) :: donor_index
        end function
    end interface

contains

    !>  Routine for detecting Chimera faces.
    !!
    !!  Routine flags face as a Chimera face if it has an ftype==ORPHAN,
    !!  indicating it is not an interior face and it has not been assigned a
    !!  boundary condition.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/1/2016
    !!
    !!  @param[inout]   mesh    Array of mesh types. One for each domain.
    !!
    !------------------------------------------------------------------------------------------
    subroutine detect_chimera_faces(mesh)
        type(mesh_t),   intent(inout)   :: mesh

        integer(ik) :: idom, ielem, iface, nnodes, ierr, ChiID
        logical     :: orphan_face = .false.
        logical     :: chimera_face = .false.

        ! Loop through each element of each domain and look for ORPHAN face-types.
        ! If orphan is found, designate as CHIMERA
        do idom = 1,mesh%ndomains()
            do ielem = 1,mesh%domain(idom)%nelem
                do iface = 1,NFACES
                    associate( domain         => mesh%domain(idom),            &
                               domain_chimera => mesh%domain(idom)%chimera,    &
                               face           => mesh%domain(idom)%faces(ielem,iface) )

                    ! Test if the current face is unattached.
                    ! Test also if the current face is CHIMERA in case this is being
                    ! called as a reinitialization procedure.
                    orphan_face = ( face%ftype == ORPHAN .or. face%ftype == CHIMERA )

                    ! If orphan_face, set as Chimera face so it can search for donors in
                    ! other domains
                    if (orphan_face) then

                        ! Set face-type to CHIMERA
                        face%ftype = CHIMERA
                        nnodes = size(face%jinv)

                        ! Set domain-local Chimera identifier. Really, just the index
                        ! order which they were detected in, starting from 1.The n-th
                        ! chimera face
                        face%ChiID = domain_chimera%add_receiver(domain%idomain_g,                &
                                                                 domain%idomain_l,                &
                                                                 domain%elems(ielem)%ielement_g,  &
                                                                 domain%elems(ielem)%ielement_l,  &
                                                                 iface,                           &
                                                                 nnodes)
                    end if

                    end associate
                end do ! iface
            end do ! ielem
        end do ! idom

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

    !>  Routine for generating the data in a chimera_receiver_data instance.
    !!  This includes donor_domain and donor_element indices.
    !!
    !!  For each Chimera face, find a donor for each quadrature node on the face,
    !!  for a given node, initialize information about its donor.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/1/2016
    !!
    !!  @parma[in]  mesh    Array of mesh_t instances
    !!
    !----------------------------------------------------------------------------------------
    subroutine detect_chimera_donors(mesh)
        type(mesh_t),   intent(inout)   :: mesh

        integer(ik) :: idom, igq, ichimera_face, idonor, ierr, iproc,                           &
                       idonor_proc, iproc_loop,                                                 &
                       ndonors, nfields, nterms_s,                                              &
                       idonor_domain_g, idonor_element_g, idonor_domain_l, idonor_element_l,    &
                       idomain_g_list, idomain_l_list, ielement_g_list, ielement_l_list,        &
                       nfields_list, nterms_s_list, nterms_c_list, iproc_list, eqn_ID_list,       &
                       local_domain_g, parallel_domain_g, donor_domain_g, donor_index,          &
                       donor_ID, send_ID
        integer(ik) :: receiver_indices(6), parallel_indices(13), size_modal_coords, size_nodes_to_modes

        real(rk)                :: donor_metric(3,3), parallel_metric(3,3)
        real(rk), allocatable   :: donor_vols(:), parallel_nodes_to_modes(:,:), parallel_modal_coords(:,:), &
                                   donor_nodes_to_modes(:,:), donor_modal_coords(:,:)
        real(rk)                :: gq_coords(3), offset(3), gq_node(3), &
                                   donor_jinv, donor_vol, local_vol, parallel_vol, parallel_jinv

        type(face_info_t)       :: receiver
        type(element_info_t)    :: donor
        real(rk)                :: donor_coord(3)
        logical                 :: new_donor     = .false.
        logical                 :: already_added = .false.
        logical                 :: donor_match   = .false.
        logical                 :: searching
        logical                 :: donor_found
        logical                 :: proc_has_donor
        logical                 :: still_need_donor
        logical                 :: local_donor, parallel_donor
        logical                 :: use_local, use_parallel, get_donor

        type(ivector_t)         :: donor_proc_indices, donor_proc_domains
        type(rvector_t)         :: donor_proc_vols

        ! Loop through processes. One will process its chimera faces and try to
        ! find processor-local donors. If it can't find on-processor donors, then
        ! it will broadcast a search request to all other processors. All other processors
        ! receive the request and return if they have a donor element or not.
        !
        ! The processes loop through in this serial fashion until all processors have
        ! processed their Chimera faces and have found donor elements for the quadrature
        ! nodes.
        do iproc = 0,NRANK-1

            ! iproc searches for donors for it's Chimera faces
            if ( iproc == IRANK ) then
                do idom = 1,mesh%ndomains()
                    call write_line('   Detecting chimera donors for domain: ', idom, delimiter='  ', ltrim=.false.)

                    ! Loop over faces and process Chimera-type faces
                    do ichimera_face = 1,mesh%domain(idom)%chimera%nreceivers()

                        ! Get location of the face receiving Chimera data
                        receiver%idomain_g  = mesh%domain(idom)%chimera%recv(ichimera_face)%idomain_g
                        receiver%idomain_l  = mesh%domain(idom)%chimera%recv(ichimera_face)%idomain_l
                        receiver%ielement_g = mesh%domain(idom)%chimera%recv(ichimera_face)%ielement_g
                        receiver%ielement_l = mesh%domain(idom)%chimera%recv(ichimera_face)%ielement_l
                        receiver%iface      = mesh%domain(idom)%chimera%recv(ichimera_face)%iface

                        call write_line('   Face ', ichimera_face,' of ',mesh%domain(idom)%chimera%nreceivers(), '      (domain,element,face) = ', receiver%idomain_g, receiver%ielement_g, receiver%iface, delimiter='  ')

                        ! Loop through quadrature nodes on Chimera face and find donors
                        do igq = 1,mesh%domain(receiver%idomain_l)%faces(receiver%ielement_l,receiver%iface)%basis_s%nnodes_face()

                            ! Get node coordinates
                            !gq_node = mesh%domain(receiver%idomain_l)%faces(receiver%ielement_l,receiver%iface)%interp_coords_def(igq,1:3)
                            gq_node = mesh%domain(receiver%idomain_l)%faces(receiver%ielement_l,receiver%iface)%interp_coords(igq,1:3)

                            ! Get offset coordinates from face for potential periodic offset.
                            offset = get_periodic_offset(mesh%domain(receiver%idomain_l)%faces(receiver%ielement_l,receiver%iface))

                            searching = .true.
                            call MPI_BCast(searching,1,MPI_LOGICAL, iproc, ChiDG_COMM, ierr)

                            ! Send gq node physical coordinates
                            call MPI_BCast(gq_node,3,MPI_REAL8, iproc, ChiDG_COMM, ierr)
                            call MPI_BCast(offset, 3,MPI_REAL8, iproc, ChiDG_COMM, ierr)

                            ! Send receiver indices
                            receiver_indices(1) = receiver%idomain_g
                            receiver_indices(2) = receiver%idomain_l
                            receiver_indices(3) = receiver%ielement_g
                            receiver_indices(4) = receiver%ielement_l
                            receiver_indices(5) = receiver%iface
                            receiver_indices(6) = receiver%dof_start
                            call MPI_BCast(receiver_indices,6,MPI_INTEGER4, iproc, ChiDG_COMM, ierr)

                            ! Call routine to find LOCAL gq donor for current node
                            call find_gq_donor(mesh,                &
                                               gq_node,             &
                                               offset,              &
                                               receiver,            &
                                               donor,               &
                                               donor_coord,         &
                                               donor_found,         &
                                               donor_volume=local_vol)

                            local_domain_g = 0
                            local_donor = .false.
                            if ( donor_found ) then
                                local_donor = .true.
                            end if

                            !
                            ! Check which processors have a valid donor
                            !
                            do idonor_proc = 0,NRANK-1
                                if (idonor_proc /= IRANK) then
                                    ! Check if a donor was found on proc idonor_proc
                                    call MPI_Recv(proc_has_donor,1,MPI_LOGICAL, idonor_proc, MPI_ANY_TAG, ChiDG_COMM, MPI_STATUS_IGNORE, ierr)

                                    if (proc_has_donor) then
                                        call donor_proc_indices%push_back(idonor_proc)

                                        call MPI_Recv(donor_domain_g,1,MPI_INTEGER4, idonor_proc, MPI_ANY_TAG, ChiDG_COMM, MPI_STATUS_IGNORE, ierr)
                                        call donor_proc_domains%push_back(donor_domain_g)

                                        call MPI_Recv(donor_vol,1,MPI_REAL8, idonor_proc, MPI_ANY_TAG, ChiDG_COMM, MPI_STATUS_IGNORE, ierr)
                                        call donor_proc_vols%push_back(donor_vol)
                                    end if
                                end if
                            end do !idonor_proc

                            !
                            ! If there is a parallel donor, determine which has the lowest volume
                            !
                            parallel_domain_g = 0
                            parallel_donor = .false.
                            if ( donor_proc_indices%size() > 0 ) then
                                donor_vols = donor_proc_vols%data()
                                donor_index = minloc(donor_vols,1)

                                parallel_vol = donor_vols(donor_index)
                                parallel_donor = .true.
                            end if

                            !
                            ! Determine which donor to use
                            !
                            if ( local_donor .and. parallel_donor ) then
                                use_local    = (local_vol    <= parallel_vol)
                                use_parallel = (parallel_vol <  local_vol   )

                            else if (local_donor .and. (.not. parallel_donor)) then
                                use_local = .true.
                                use_parallel = .false.

                            else if (parallel_donor .and. (.not. local_donor)) then
                                use_local = .false.
                                use_parallel = .true.

                            else
                                call chidg_signal_three(FATAL,"detect_chimera_donor: no valid donor found",gq_node(1),gq_node(2),gq_node(3))
                            end if

                            !
                            ! Overwrite donor data if use_parallel
                            !
                            if (use_parallel) then

                                !
                                ! Send a message to the processes that have donors to indicate if we would like to use it
                                !
                                do iproc_loop = 1,donor_proc_indices%size()

                                    idonor_proc = donor_proc_indices%at(iproc_loop)
                                    get_donor   = (iproc_loop == donor_index)
                                    call MPI_Send(get_donor,1,MPI_LOGICAL, idonor_proc, 0, ChiDG_COMM, ierr)

                                end do !idonor_proc

                                !
                                ! Receive parallel donor index from processor indicated
                                !
                                idonor_proc = donor_proc_indices%at(donor_index)
                                call MPI_Recv(parallel_indices,13,MPI_INTEGER4, idonor_proc, MPI_ANY_TAG, ChiDG_COMM, MPI_STATUS_IGNORE, ierr)

                                donor = element_info(idomain_g         = parallel_indices(1),  &
                                                     idomain_l         = parallel_indices(2),  &
                                                     ielement_g        = parallel_indices(3),  &
                                                     ielement_l        = parallel_indices(4),  &
                                                     iproc             = parallel_indices(5),  &
                                                     pelem_ID          = NO_ID,                &
                                                     coordinate_system = parallel_indices(6),  &
                                                     eqn_ID            = parallel_indices(7),  &
                                                     nfields           = parallel_indices(8),  &
                                                     ntime             = parallel_indices(9),  &
                                                     nterms_s          = parallel_indices(10), &
                                                     nterms_c          = parallel_indices(11), &
                                                     dof_start         = parallel_indices(12), &
                                                     dof_local_start   = NO_ID, &
                                                     xdof_start        = parallel_indices(13), &
                                                     xdof_local_start  = NO_ID, &
                                                     recv_comm         = NO_ID, &
                                                     recv_domain       = NO_ID, &
                                                     recv_element      = NO_ID, &
                                                     recv_dof          = NO_ID, &
                                                     recv_xdof         = NO_ID)

                                ! Define sizes of donor_nodes_to_modes and donoro_modal_coords
                                size_nodes_to_modes = donor%nterms_c*donor%nterms_c
                                size_modal_coords   = donor%nterms_c*3

                                ! Allocate matrices
                                if (allocated(donor_modal_coords)) deallocate(donor_modal_coords,donor_nodes_to_modes)
                                allocate (donor_modal_coords(donor%nterms_c,3),donor_nodes_to_modes(donor%nterms_c,donor%nterms_c),stat=ierr)
                                if (ierr/=0) call AllocationError

                                ! 1: Receive donor local coordinate
                                ! 2: Receive donor metric matrix
                                ! 3: Receive donor inverse jacobian mapping
                                ! 4: Receive donor inverse jacobian mapping
                                ! 5: Receive donor inverse jacobian dx mapping
                                call MPI_Recv(donor_coord,                            3,MPI_REAL8, idonor_proc, MPI_ANY_TAG, ChiDG_COMM, MPI_STATUS_IGNORE, ierr)
                                call MPI_Recv(donor_metric,                           9,MPI_REAL8, idonor_proc, MPI_ANY_TAG, ChiDG_COMM, MPI_STATUS_IGNORE, ierr)
                                call MPI_Recv(donor_jinv,                             1,MPI_REAL8, idonor_proc, MPI_ANY_TAG, ChiDG_COMM, MPI_STATUS_IGNORE, ierr)
                                call MPI_Recv(donor_nodes_to_modes, size_nodes_to_modes,MPI_REAL8, idonor_proc, MPI_ANY_TAG, ChiDG_COMM, MPI_STATUS_IGNORE, ierr)
                                call MPI_Recv(donor_modal_coords,     size_modal_coords,MPI_REAL8, idonor_proc, MPI_ANY_TAG, ChiDG_COMM, MPI_STATUS_IGNORE, ierr)

                            else if (use_local) then

                                ! Send a message to all procs with donors that we don't need them
                                get_donor = .false.
                                do iproc_loop = 1,donor_proc_indices%size()
                                    idonor_proc = donor_proc_indices%at(iproc_loop)
                                    call MPI_Send(get_donor,1,MPI_LOGICAL, idonor_proc, 0, ChiDG_COMM, ierr)
                                end do

                                ! Allocate matrices
                                if (allocated(donor_modal_coords)) deallocate(donor_modal_coords,donor_nodes_to_modes)
                                allocate (donor_modal_coords(donor%nterms_c,3),donor_nodes_to_modes(donor%nterms_c,donor%nterms_c),stat=ierr)
                                if (ierr/=0) call AllocationError

                                donor_metric = mesh%domain(donor%idomain_l)%elems(donor%ielement_l)%metric_point(donor_coord,coordinate_frame='Undeformed',coordinate_scaling=.true.)
                                donor_jinv   = ONE/det_3x3(donor_metric)
                                ! TODO: properly reflect itime
                                donor_nodes_to_modes    = mesh%domain(donor%idomain_l)%elems(donor%ielement_l)%nodes_to_modes
                                donor_modal_coords(:,1) = mesh%domain(donor%idomain_l)%elems(donor%ielement_l)%coords%getvar(1,itime=1)
                                donor_modal_coords(:,2) = mesh%domain(donor%idomain_l)%elems(donor%ielement_l)%coords%getvar(2,itime=1)
                                donor_modal_coords(:,3) = mesh%domain(donor%idomain_l)%elems(donor%ielement_l)%coords%getvar(3,itime=1)

                            else
                                call chidg_signal(FATAL,"detect_chimera_donors: no local or parallel donor found")

                            end if

                            donor_ID = mesh%domain(idom)%chimera%recv(ichimera_face)%add_donor(donor)
                            call mesh%domain(idom)%chimera%recv(ichimera_face)%donor(donor_ID)%set_properties(donor_nodes_to_modes,donor_modal_coords)
                            call mesh%domain(idom)%chimera%recv(ichimera_face)%donor(donor_ID)%add_node(igq,donor_coord,donor_metric,donor_jinv)

                            ! Clear working vectors
                            call donor_proc_indices%clear()
                            call donor_proc_domains%clear()
                            call donor_proc_vols%clear()

                        end do ! igq

                    end do ! iface
                end do ! idom

            searching = .false.
            call MPI_BCast(searching,1,MPI_LOGICAL, iproc, ChiDG_COMM, ierr)

            end if ! iproc == IRANK

            ! Each other proc waits for donor requests from iproc and sends back donors if they are found.
            if (iproc /= IRANK) then

                ! Check if iproc is searching for a node
                call MPI_BCast(searching,1,MPI_LOGICAL,iproc,ChiDG_COMM,ierr)

                do while(searching)

                    ! Receive gq node physical coordinates from iproc
                    call MPI_BCast(gq_node,3,MPI_REAL8, iproc, ChiDG_COMM, ierr)
                    call MPI_BCast(offset, 3,MPI_REAL8, iproc, ChiDG_COMM, ierr)

                    ! Receive receiver indices
                    call MPI_BCast(receiver_indices,6,MPI_INTEGER4, iproc, ChiDG_COMM, ierr)
                    receiver = face_info(receiver_indices(1),   &
                                         receiver_indices(2),   &
                                         receiver_indices(3),   &
                                         receiver_indices(4),   &
                                         receiver_indices(5),   &
                                         receiver_indices(6)    &
                                         )

                    ! Try to find donor
                    call find_gq_donor(mesh,                &
                                       gq_node,             &
                                       offset,              &
                                       receiver,            &
                                       donor,               &
                                       donor_coord,         &
                                       donor_found,         &
                                       donor_volume=donor_vol)

                    ! Send status
                    call MPI_Send(donor_found,1,MPI_LOGICAL,iproc,0,ChiDG_COMM,ierr)

                    if (donor_found) then

                        call MPI_Send(donor%idomain_g,1,MPI_INTEGER4,iproc,0,ChiDG_COMM,ierr)
                        call MPI_Send(donor_vol,1,MPI_REAL8,iproc,0,ChiDG_COMM,ierr)

                        call MPI_Recv(still_need_donor,1,MPI_LOGICAL, iproc, MPI_ANY_TAG, ChiDG_COMM, MPI_STATUS_IGNORE, ierr)

                        if (still_need_donor) then

                            ! Add donor to the chimera send collection
                            send_ID = mesh%domain(donor%idomain_l)%chimera%find_send(donor%idomain_g, donor%ielement_g)
                            if (send_ID == NO_ID) then
                                send_ID = mesh%domain(donor%idomain_l)%chimera%new_send()
                                mesh%domain(donor%idomain_l)%chimera%send(send_ID) = chimera_send(donor%idomain_g, donor%idomain_l, donor%ielement_g, donor%ielement_l)
                            end if
                            call mesh%domain(donor%idomain_l)%chimera%send(send_ID)%send_procs%push_back_unique(iproc)

                            ! 1: Send donor indices
                            ! 2: Send donor-local coordinate for the quadrature node
                            parallel_indices(1)  = donor%idomain_g
                            parallel_indices(2)  = donor%idomain_l
                            parallel_indices(3)  = donor%ielement_g
                            parallel_indices(4)  = donor%ielement_l
                            parallel_indices(5)  = donor%iproc
                            parallel_indices(6)  = donor%coordinate_system
                            parallel_indices(7)  = donor%eqn_ID
                            parallel_indices(8)  = donor%nfields
                            parallel_indices(9)  = donor%ntime
                            parallel_indices(10) = donor%nterms_s
                            parallel_indices(11) = donor%nterms_c
                            parallel_indices(12) = donor%dof_start
                            parallel_indices(13) = donor%xdof_start

                            call MPI_Send(parallel_indices,13,MPI_INTEGER4,iproc,0,ChiDG_COMM,ierr)
                            call MPI_Send(donor_coord,3,MPI_REAL8,iproc,0,ChiDG_COMM,ierr)

                            ! Compute metric terms for the point in the donor element
                            parallel_metric = mesh%domain(donor%idomain_l)%elems(donor%ielement_l)%metric_point(donor_coord, coordinate_frame='Undeformed', coordinate_scaling=.true.)
                            parallel_jinv   = ONE/det_3x3(parallel_metric)

                            ! Allocate matrices
                            if (allocated(parallel_modal_coords)) deallocate(parallel_modal_coords)
                            allocate(parallel_modal_coords(donor%nterms_c,3),stat=ierr)
                            if (ierr/=0) call AllocationError

                            ! Get parallel nodes_to_modes and modal coordinates
                            parallel_nodes_to_modes    = mesh%domain(donor%idomain_l)%elems(donor%ielement_l)%nodes_to_modes
                            parallel_modal_coords(:,1) = mesh%domain(donor%idomain_l)%elems(donor%ielement_l)%coords%getvar(1,itime=1)
                            parallel_modal_coords(:,2) = mesh%domain(donor%idomain_l)%elems(donor%ielement_l)%coords%getvar(2,itime=1)
                            parallel_modal_coords(:,3) = mesh%domain(donor%idomain_l)%elems(donor%ielement_l)%coords%getvar(3,itime=1)

                            ! Get size nodes_to_modes and modal coordinate
                            size_nodes_to_modes = donor%nterms_c*donor%nterms_c
                            size_modal_coords   = donor%nterms_c*3

                            ! Communicate metric and jacobian
                            call MPI_Send(parallel_metric,                           9, MPI_REAL8, iproc, 0, ChiDG_COMM, ierr)
                            call MPI_Send(parallel_jinv,                             1, MPI_REAL8, iproc, 0, ChiDG_COMM, ierr)
                            call MPI_Send(parallel_nodes_to_modes, size_nodes_to_modes, MPI_REAL8, iproc, 0, ChiDG_COMM, ierr)
                            call MPI_Send(parallel_modal_coords,     size_modal_coords, MPI_REAL8, iproc, 0, ChiDG_COMM, ierr)

                        end if

                    end if

                    ! Check if iproc is searching for another node
                    call MPI_BCast(searching,1,MPI_LOGICAL,iproc,ChiDG_COMM,ierr)

                end do ! while searching

            end if ! iproc /= IRANK

        end do ! iproc

        ! Clear cache of last detected overset donor.
        call clear_donor_cache()

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

    !> Compute the matrices that interpolate solution data from a donor element expansion
    !! to the receiver nodes.
    !!
    !! These matrices get stored in:
    !!      mesh(idom)%chimera%recv(ChiID)%donor_interpolator
    !!      mesh(idom)%chimera%recv(ChiID)%donor_interpolator_grad1
    !!      mesh(idom)%chimera%recv(ChiID)%donor_interpolator_grad2
    !!      mesh(idom)%chimera%recv(ChiID)%donor_interpolator_grad3
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/1/2016
    !!
    !-------------------------------------------------------------------------------
    subroutine compute_chimera_interpolators(mesh)
        type(mesh_t),   intent(inout)   :: mesh

        integer(ik)     :: idom, ChiID, idonor, ierr, ipt, iterm,   &
                           donor_idomain_g, donor_idomain_l,        &
                           donor_ielement_g, donor_ielement_l,      &
                           npts, donor_nterms_s, spacedim
        real(rk)        :: node(3), jinv, ddxi, ddeta, ddzeta

        real(rk), allocatable, dimension(:,:)   ::  &
            interpolator, interpolator_grad1, interpolator_grad2, interpolator_grad3, metric

        ! Loop over all domains
        do idom = 1,mesh%ndomains()
            ! Loop over each chimera face
            do ChiID = 1,mesh%domain(idom)%chimera%nreceivers()
                ! For each donor, compute an interpolation matrix
                do idonor = 1,mesh%domain(idom)%chimera%recv(ChiID)%ndonors()

                    donor_idomain_g  = mesh%domain(idom)%chimera%recv(ChiID)%donor(idonor)%elem_info%idomain_g
                    donor_idomain_l  = mesh%domain(idom)%chimera%recv(ChiID)%donor(idonor)%elem_info%idomain_l
                    donor_ielement_g = mesh%domain(idom)%chimera%recv(ChiID)%donor(idonor)%elem_info%ielement_g
                    donor_ielement_l = mesh%domain(idom)%chimera%recv(ChiID)%donor(idonor)%elem_info%ielement_l
                    donor_nterms_s   = mesh%domain(idom)%chimera%recv(ChiID)%donor(idonor)%elem_info%nterms_s

                    ! Get number of GQ points this donor is responsible for
                    npts   = mesh%domain(idom)%chimera%recv(ChiID)%donor(idonor)%nnodes()

                    ! Allocate interpolator matrix
                    if (allocated(interpolator)) deallocate(interpolator,       &
                                                            interpolator_grad1, &
                                                            interpolator_grad2, &
                                                            interpolator_grad3)
                    allocate(interpolator(      npts,donor_nterms_s), &
                             interpolator_grad1(npts,donor_nterms_s), &
                             interpolator_grad2(npts,donor_nterms_s), &
                             interpolator_grad3(npts,donor_nterms_s), stat=ierr)
                    if (ierr /= 0) call AllocationError

                    ! Compute values of modal polynomials at the donor nodes
                    do iterm = 1,donor_nterms_s
                        do ipt = 1,npts

                            node = mesh%domain(idom)%chimera%recv(ChiID)%donor(idonor)%coords(ipt,:)

                            ! Compute value interpolator
                            spacedim = 3
                            interpolator(ipt,iterm) = polynomial_val(spacedim,donor_nterms_s,iterm,node)

                            ! Compute gradient interpolators, grad1, grad2, grad3
                            ddxi   = dpolynomial_val(spacedim,donor_nterms_s,iterm,node,XI_DIR  )
                            ddeta  = dpolynomial_val(spacedim,donor_nterms_s,iterm,node,ETA_DIR )
                            ddzeta = dpolynomial_val(spacedim,donor_nterms_s,iterm,node,ZETA_DIR)

                            ! Get metrics for element mapping
                            metric = mesh%domain(idom)%chimera%recv(ChiID)%donor(idonor)%metric(:,:,ipt)
                            jinv   = mesh%domain(idom)%chimera%recv(ChiID)%donor(idonor)%jinv(ipt)

                            ! Compute cartesian derivative interpolator for gq node
                            interpolator_grad1(ipt,iterm) = metric(1,1) * ddxi   + &
                                                            metric(2,1) * ddeta  + &
                                                            metric(3,1) * ddzeta
                            interpolator_grad2(ipt,iterm) = metric(1,2) * ddxi   + &
                                                            metric(2,2) * ddeta  + &
                                                            metric(3,2) * ddzeta
                            interpolator_grad3(ipt,iterm) = metric(1,3) * ddxi   + &
                                                            metric(2,3) * ddeta  + &
                                                            metric(3,3) * ddzeta

                        end do ! ipt
                    end do ! iterm

                    ! Store interpolators
                    mesh%domain(idom)%chimera%recv(ChiID)%donor(idonor)%value = interpolator
                    mesh%domain(idom)%chimera%recv(ChiID)%donor(idonor)%grad1 = interpolator_grad1
                    mesh%domain(idom)%chimera%recv(ChiID)%donor(idonor)%grad2 = interpolator_grad2
                    mesh%domain(idom)%chimera%recv(ChiID)%donor(idonor)%grad3 = interpolator_grad3

                end do  ! idonor
            end do  ! ChiID
        end do  ! idom

        ! Communicate mesh
        call mesh%comm_send()
        call mesh%comm_recv()   ! also calls mesh%assemble_chimera_data to construct data on complete exterior node set.
        call mesh%comm_wait()

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

    !>  Find the domain and element indices for an element that contains a given
    !!  quadrature node and can donate interpolated solution values to the receiver face.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/1/2016
    !!
    !!  @param[in]      mesh                Array of mesh_t instances
    !!  @param[in]      gq_node             GQ point that needs to find a donor
    !!  @param[in]      receiver_face       Location of face containing the gq_node
    !!  @param[inout]   donor_element       Location of the donor element that was found
    !!  @param[inout]   donor_coordinate    Point defining the location of the GQ point in the donor coordinate system
    !!  @param[inout]   donor_volume        Volume of the donor element that can be used to select between donors if
    !!                                      multiple are available.
    !!
    !-------------------------------------------------------------------------------------
    subroutine find_gq_donor(mesh,gq_node,offset,receiver_face,donor_element,donor_coordinate,donor_found,donor_volume,multi_donor_rule)
        type(mesh_t),               intent(in)              :: mesh
        real(rk),                   intent(in)              :: gq_node(3)
        real(rk),                   intent(in)              :: offset(3)
        type(face_info_t),          intent(in)              :: receiver_face
        type(element_info_t),       intent(inout)           :: donor_element
        real(rk),                   intent(inout)           :: donor_coordinate(3)
        logical,                    intent(inout)           :: donor_found
        real(rk),                   intent(inout), optional :: donor_volume
        class(multi_donor_rule_t),  intent(in),    optional :: multi_donor_rule

        integer(ik)                 :: idom, ielem, inewton, idomain_g, idomain_l,      &
                                       ielement_g, ielement_l, icandidate, ncandidates, &
                                       idonor, ndonors, donor_index, donor_domain_l, donor_element_l

        real(rk), allocatable   :: xcenter(:), ycenter(:), zcenter(:), dist(:), donor_vols(:)
        real(rk)                :: xgq, ygq, zgq, dx, dy, dz, xi, eta, zeta, xn, yn, zn,    &
                                   xmin, xmax, ymin, ymax, zmin, zmax,                      &
                                   xcenter_recv, ycenter_recv, zcenter_recv

        real(rk)                :: donor_comp(3), recv_comp(3), search1, search2, search3, &
                                   offset1, offset2, offset3
        type(ivector_t)         :: candidate_domains_g, candidate_domains_l, &
                                   candidate_elements_g, candidate_elements_l
        type(ivector_t)         :: donors
        type(rvector_t)         :: donors_xi, donors_eta, donors_zeta

        logical                 :: contained  = .false.
        logical                 :: receiver   = .false.
        logical                 :: node_found = .false.
        logical                 :: node_self  = .false.

        xgq = gq_node(1)
        ygq = gq_node(2)
        zgq = gq_node(3)

        offset1 = offset(1)
        offset2 = offset(2)
        offset3 = offset(3)

        search1 = xgq + offset1
        search2 = ygq + offset2
        search3 = zgq + offset3

        ! Try previous donor, since it is relatively likely the previous donor
        ! for a quadrature node set will satisfy the next node. Consider
        ! abutting boundaries, all nodes are satisfied by the same donor.
        !---------------------------------------------------------------------
        ndonors = 0
        if (idomain_g_prev /= NO_ID) then
            idomain_g  = idomain_g_prev
            idomain_l  = idomain_l_prev
            ielement_g = ielement_g_prev
            ielement_l = ielement_l_prev
            call candidate_domains_g%push_back(idomain_g)
            call candidate_domains_l%push_back(idomain_l)
            call candidate_elements_g%push_back(ielement_g)
            call candidate_elements_l%push_back(ielement_l)
            ncandidates = 1

            ! Try to find donor (xi,eta,zeta) coordinates for receiver (xgq,ygq,zgq)
            donor_comp = mesh%domain(idomain_l)%elems(ielement_l)%computational_point([search1,search2,search3])    ! Newton's method routine

            ! Node is not nan
            node_found = (any(ieee_is_nan(donor_comp)) .eqv. .false.)

            ! Node is not self: could be periodic, so same element is okay, but we don't want the same node
            if ( (idomain_g == receiver_face%idomain_g) .and. (ielement_g == receiver_face%ielement_g) ) then
                recv_comp  = mesh%domain(idomain_l)%elems(ielement_l)%computational_point([xgq, ygq, zgq])
                node_self = (abs(sum(recv_comp - donor_comp)) < 1.e-3_rk)
            else
                node_self = .false.
            end if

            ! Add donor if donor_comp is valid
            if ( node_found .and. (.not. node_self)) then
                ndonors = ndonors + 1
                call donors%push_back(1)
                call donors_xi%push_back(  donor_comp(1))
                call donors_eta%push_back( donor_comp(2))
                call donors_zeta%push_back(donor_comp(3))
            end if
        end if
        !---------------------------------------------------------------------

        ! If the previous donor didn't work, then we will go through a global
        ! search again.
        if (ndonors == 0) then

            !
            ! Loop through LOCAL domains and search for potential donor candidates
            !
            ncandidates = 0
            call candidate_domains_g%clear()
            call candidate_domains_l%clear()
            call candidate_elements_g%clear()
            call candidate_elements_l%clear()
            do idom = 1,mesh%ndomains()
                idomain_g = mesh%domain(idom)%idomain_g
                idomain_l = mesh%domain(idom)%idomain_l

                !
                ! Loop through elements in the current domain
                !
                do ielem = 1,mesh%domain(idom)%nelem
                    ielement_g = mesh%domain(idom)%elems(ielem)%ielement_g
                    ielement_l = mesh%domain(idom)%elems(ielem)%ielement_l

                    !
                    ! Get bounding coordinates for the current element
                    !
                    xmin = minval(mesh%domain(idom)%elems(ielem)%node_coords(:,1))
                    xmax = maxval(mesh%domain(idom)%elems(ielem)%node_coords(:,1))
                    ymin = minval(mesh%domain(idom)%elems(ielem)%node_coords(:,2))
                    ymax = maxval(mesh%domain(idom)%elems(ielem)%node_coords(:,2))
                    zmin = minval(mesh%domain(idom)%elems(ielem)%node_coords(:,3))
                    zmax = maxval(mesh%domain(idom)%elems(ielem)%node_coords(:,3))

                    !
                    ! Grow bounding box by 10%. Use delta x,y,z instead of scaling xmin etc. in case xmin is 0
                    !
                    dx = abs(xmax - xmin)
                    dy = abs(ymax - ymin)
                    dz = abs(zmax - zmin)

                    xmin = xmin - 0.1*dx
                    xmax = xmax + 0.1*dx
                    ymin = ymin - 0.1*dy
                    ymax = ymax + 0.1*dy
                    zmin = (zmin-0.001) - 0.1*dz    ! This is to help 2D
                    zmax = (zmax+0.001) + 0.1*dz    ! This is to help 2D

                    !
                    ! Test if gq_node is contained within the bounding coordinates
                    !
                    contained = ( (xmin < search1) .and. (search1 < xmax ) .and. &
                                  (ymin < search2) .and. (search2 < ymax ) .and. &
                                  (zmin < search3) .and. (search3 < zmax ) )

                    ! If the node was within the bounding coordinates, flag the element as a potential donor
                    if (contained) then
                        call candidate_domains_g%push_back(idomain_g)
                        call candidate_domains_l%push_back(idomain_l)
                        call candidate_elements_g%push_back(ielement_g)
                        call candidate_elements_l%push_back(ielement_l)
                        ncandidates = ncandidates + 1
                    end if

                end do ! ielem

            end do ! idom

            !
            ! Test gq_node physical coordinates on candidate element volume to try and map to donor local coordinates
            !
            ndonors = 0
            do icandidate = 1,ncandidates
                idomain_g  = candidate_domains_g%at(icandidate)
                idomain_l  = candidate_domains_l%at(icandidate)
                ielement_g = candidate_elements_g%at(icandidate)
                ielement_l = candidate_elements_l%at(icandidate)

                ! Try to find donor (xi,eta,zeta) coordinates for receiver (xgq,ygq,zgq)
                donor_comp = mesh%domain(idomain_l)%elems(ielement_l)%computational_point([search1,search2,search3])    ! Newton's method routine

                ! Node is not nan
                node_found = (any(ieee_is_nan(donor_comp)) .eqv. .false.)

                ! Node is not self: could be periodic, so same element is okay, but we don't want the same node
                if ( (idomain_g == receiver_face%idomain_g) .and. (ielement_g == receiver_face%ielement_g) ) then
                    recv_comp  = mesh%domain(idomain_l)%elems(ielement_l)%computational_point([xgq, ygq, zgq])
                    node_self = (abs(sum(recv_comp - donor_comp)) < 1.e-3_rk)
                else
                    node_self = .false.
                end if

                ! Add donor if donor_comp is valid
                if ( node_found .and. (.not. node_self)) then
                    ndonors = ndonors + 1
                    call donors%push_back(icandidate)
                    call donors_xi%push_back(  donor_comp(1))
                    call donors_eta%push_back( donor_comp(2))
                    call donors_zeta%push_back(donor_comp(3))
                    !exit
                end if

            end do ! icandidate

        end if !ndonors == 0, from check of previous donor element.

        ! Sanity check on donors and set donor_element location
        if (ndonors == 0) then
            donor_element = element_info(idomain_g         = 0,       &
                                         idomain_l         = 0,       &
                                         ielement_g        = 0,       &
                                         ielement_l        = 0,       &
                                         iproc             = NO_PROC, &
                                         pelem_ID          = NO_ID,   &
                                         coordinate_system = NO_ID,   &
                                         eqn_ID            = NO_ID,   &
                                         nfields           = 0,       &
                                         ntime             = 0,       &
                                         nterms_s          = 0,       &
                                         nterms_c          = 0,       &
                                         dof_start         = NO_ID,   &
                                         dof_local_start   = NO_ID,   &
                                         xdof_start        = NO_ID,   &
                                         xdof_local_start  = NO_ID,   &
                                         recv_comm         = NO_ID,   &
                                         recv_domain       = NO_ID,   &
                                         recv_element      = NO_ID,   &
                                         recv_dof          = NO_ID,   &
                                         recv_xdof         = NO_ID)

            donor_found = .false.

        elseif (ndonors == 1) then

            idonor = donors%at(1)   ! donor index from candidates

            donor_domain_l  = candidate_domains_l%at(idonor)
            donor_element_l = candidate_elements_l%at(idonor)

            donor_element = mesh%get_element_info(donor_domain_l,donor_element_l)

            xi   = donors_xi%at(1)
            eta  = donors_eta%at(1)
            zeta = donors_zeta%at(1)
            donor_coordinate = [xi,eta,zeta]
            donor_found = .true.
            if (present(donor_volume)) donor_volume = mesh%domain(donor_element%idomain_l)%elems(donor_element%ielement_l)%vol

        elseif (ndonors > 1) then

            ! Handle multiple potential donors: Choose donor with minimum volume - should be best resolved
            if (allocated(donor_vols) ) deallocate(donor_vols)
            allocate(donor_vols(donors%size()))

            ! If provided a rule use that, if not select by lowest volume
            if (present(multi_donor_rule)) then
                donor_index = multi_donor_rule%select_donor(mesh,donors,candidate_domains_g,candidate_domains_l,candidate_elements_g,candidate_elements_l)
            else
                ! Get index of domain with minimum volume
                do idonor = 1,donors%size()
                    donor_vols(idonor) = mesh%domain(candidate_domains_l%at(donors%at(idonor)))%elems(candidate_elements_l%at(donors%at(idonor)))%vol
                end do
                donor_index = minloc(donor_vols,1)
            end if

            idonor = donors%at(donor_index)

            donor_domain_l  = candidate_domains_l%at(idonor)
            donor_element_l = candidate_elements_l%at(idonor)

            donor_element = mesh%get_element_info(donor_domain_l,donor_element_l)

            ! Set donor coordinate and volume if present
            xi   = donors_xi%at(donor_index)
            eta  = donors_eta%at(donor_index)
            zeta = donors_zeta%at(donor_index)
            donor_coordinate = [xi,eta,zeta]
            donor_found = .true.
            if (present(donor_volume)) donor_volume = mesh%domain(donor_element%idomain_l)%elems(donor_element%ielement_l)%vol

        else
            call chidg_signal(FATAL,"find_gq_donor: invalid number of donors")
        end if

        ! Store donor as previous donor, only if one was found. Don't want to
        ! set to zero!
        if (ndonors > 0) then
            idomain_g_prev = donor_element%idomain_g
            idomain_l_prev = donor_element%idomain_l
            ielement_g_prev = donor_element%ielement_g
            ielement_l_prev = donor_element%ielement_l
        end if

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

    !>  Try to find an element from the list of mesh%parallel_elements(:) that have
    !!  already been identified and initialialized that contains a given quadrature
    !!  node and can donate interpolated solution values to the receiver face.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/24/2018
    !!
    !!  @param[in]      mesh                mesh_t instance.
    !!  @param[in]      gq_node             (c1,c2,c3) point that needs to find a donor.
    !!  @param[in]      offset              (dc1, dc2, dc3) offset to the search location.
    !!  @param[in]      receiver_face       Location of face containing the gq_node
    !!  @param[inout]   donor_element       Location of the donor element that was found
    !!  @param[inout]   donor_coordinate    Point defining the location of the GQ point in the donor coordinate system.
    !!  @param[inout]   donor_found         Logical, indicating if a donor element was found or not.
    !!  @param[inout]   donor_volume        Volume of the donor element that can be used to select between donors if
    !!                                      multiple are available.
    !!
    !-------------------------------------------------------------------------------------
    subroutine find_gq_donor_parallel(mesh,gq_node,offset,receiver_face,donor_element,donor_coordinate,donor_found,donor_volume)
        type(mesh_t),               intent(in)              :: mesh
        real(rk),                   intent(in)              :: gq_node(3)
        real(rk),                   intent(in)              :: offset(3)
        type(face_info_t),          intent(in)              :: receiver_face
        type(element_info_t),       intent(inout)           :: donor_element
        real(rk),                   intent(inout)           :: donor_coordinate(3)
        logical,                    intent(inout)           :: donor_found
        real(rk),                   intent(inout), optional :: donor_volume

        integer(ik)                 :: idom, ielem, inewton, idomain_g, idomain_l,      &
                                       ielement_g, ielement_l, icandidate, idonor,      &
                                       donor_index, pelem_ID

        real(rk), allocatable   :: xcenter(:), ycenter(:), zcenter(:), dist(:), donor_vols(:)
        real(rk)                :: xgq, ygq, zgq, dx, dy, dz, xi, eta, zeta, xn, yn, zn,    &
                                   xmin, xmax, ymin, ymax, zmin, zmax,                      &
                                   xcenter_recv, ycenter_recv, zcenter_recv

        real(rk)                :: donor_comp(3), recv_comp(3), search1, search2, search3, offset1, offset2, offset3
        type(ivector_t)         :: candidate_elements
        type(ivector_t)         :: donors_pelem_ID
        type(rvector_t)         :: donors_xi, donors_eta, donors_zeta

        logical                 :: contained  = .false.
        logical                 :: receiver   = .false.
        logical                 :: node_found = .false.
        logical                 :: node_self  = .false.

        xgq = gq_node(1)
        ygq = gq_node(2)
        zgq = gq_node(3)

        offset1 = offset(1)
        offset2 = offset(2)
        offset3 = offset(3)

        search1 = xgq + offset1
        search2 = ygq + offset2
        search3 = zgq + offset3

        ! Loop through PARALLEL elements and search for potential donor candidates.
        do pelem_ID = 1,mesh%nparallel_elements()

            ! Get bounding coordinates for the current element
            xmin = minval(mesh%parallel_element(pelem_ID)%node_coords(:,1))
            xmax = maxval(mesh%parallel_element(pelem_ID)%node_coords(:,1))
            ymin = minval(mesh%parallel_element(pelem_ID)%node_coords(:,2))
            ymax = maxval(mesh%parallel_element(pelem_ID)%node_coords(:,2))
            zmin = minval(mesh%parallel_element(pelem_ID)%node_coords(:,3))
            zmax = maxval(mesh%parallel_element(pelem_ID)%node_coords(:,3))

            ! Grow bounding box by 10%. Use delta x,y,z instead of scaling xmin etc. in case xmin is 0
            dx = abs(xmax - xmin)
            dy = abs(ymax - ymin)
            dz = abs(zmax - zmin)

            xmin = xmin - 0.1*dx
            xmax = xmax + 0.1*dx
            ymin = ymin - 0.1*dy
            ymax = ymax + 0.1*dy
            zmin = (zmin-0.001) - 0.1*dz    ! This is to help 2D
            zmax = (zmax+0.001) + 0.1*dz    ! This is to help 2D

            ! Test if gq_node is contained within the bounding coordinates
            contained = ( (xmin < search1) .and. (search1 < xmax ) .and. &
                          (ymin < search2) .and. (search2 < ymax ) .and. &
                          (zmin < search3) .and. (search3 < zmax ) )

            ! If the node was within the bounding coordinates, flag the element as a potential donor
            if (contained) then
                call candidate_elements%push_back(pelem_ID)
            end if

        end do ! ielem

        ! Test gq_node physical coordinates on candidate element volume to try and map to donor local coordinates
        do icandidate = 1,candidate_elements%size()

            pelem_ID   = candidate_elements%at(icandidate)
            idomain_g  = mesh%parallel_element(pelem_ID)%idomain_g
            ielement_g = mesh%parallel_element(pelem_ID)%ielement_g

            ! Try to find donor (xi,eta,zeta) coordinates for receiver (xgq,ygq,zgq)
            donor_comp = mesh%parallel_element(pelem_ID)%computational_point([search1,search2,search3])    ! Newton's method routine

            ! Node is not nan
            node_found = (any(ieee_is_nan(donor_comp)) .eqv. .false.)

            ! Node is not self: could be periodic, so same element is okay, but we don't want the same node
            if ( (idomain_g == receiver_face%idomain_g) .and. (ielement_g == receiver_face%ielement_g) ) then
                recv_comp  = mesh%parallel_element(pelem_ID)%computational_point([xgq, ygq, zgq])
                node_self = (abs(sum(recv_comp - donor_comp)) < 1.e-3_rk)
            else
                node_self = .false.
            end if

            ! Add donor if donor_comp is valid
            if ( node_found .and. (.not. node_self)) then
                call donors_pelem_ID%push_back(pelem_ID)
                call donors_xi%push_back(  donor_comp(1))
                call donors_eta%push_back( donor_comp(2))
                call donors_zeta%push_back(donor_comp(3))
            end if

        end do ! icandidate

        ! Sanity check on donors and set donor_element location
        if (donors_pelem_ID%size() == 0) then
            donor_element = element_info(idomain_g         = 0,       &
                                         idomain_l         = 0,       &
                                         ielement_g        = 0,       &
                                         ielement_l        = 0,       &
                                         iproc             = NO_PROC, &
                                         pelem_ID          = NO_ID,   &
                                         coordinate_system = NO_ID,   &
                                         eqn_ID            = NO_ID,   &
                                         nfields           = 0,       &
                                         ntime             = 0,       &
                                         nterms_s          = 0,       &
                                         nterms_c          = 0,       &
                                         dof_start         = NO_ID,   &
                                         dof_local_start   = NO_ID,   &
                                         xdof_start        = NO_ID,   &
                                         xdof_local_start  = NO_ID,   &
                                         recv_comm         = NO_ID,   &
                                         recv_domain       = NO_ID,   &
                                         recv_element      = NO_ID,   &
                                         recv_dof          = NO_ID,   &
                                         recv_xdof         = NO_ID)

            donor_found = .false.

        elseif (donors_pelem_ID%size() == 1) then
            pelem_ID = donors_pelem_ID%at(1)   ! donor index from candidates
            donor_element = element_info(idomain_g         = mesh%parallel_element(pelem_ID)%idomain_g,         &
                                         idomain_l         = mesh%parallel_element(pelem_ID)%idomain_l,         &
                                         ielement_g        = mesh%parallel_element(pelem_ID)%ielement_g,        &
                                         ielement_l        = mesh%parallel_element(pelem_ID)%ielement_l,        &
                                         iproc             = mesh%parallel_element(pelem_ID)%iproc,             &
                                         pelem_ID          = pelem_ID,                                          &
                                         coordinate_system = mesh%parallel_element(pelem_ID)%coordinate_system, &
                                         eqn_ID            = mesh%parallel_element(pelem_ID)%eqn_ID,            &
                                         nfields           = mesh%parallel_element(pelem_ID)%nfields,           &
                                         ntime             = mesh%parallel_element(pelem_ID)%ntime,             &
                                         nterms_s          = mesh%parallel_element(pelem_ID)%nterms_s,          &
                                         nterms_c          = mesh%parallel_element(pelem_ID)%nterms_c,          &
                                         dof_start         = mesh%parallel_element(pelem_ID)%dof_start,         &
                                         dof_local_start   = mesh%parallel_element(pelem_ID)%dof_local_start,   &
                                         xdof_start        = mesh%parallel_element(pelem_ID)%xdof_start,        &
                                         xdof_local_start  = mesh%parallel_element(pelem_ID)%xdof_local_start,  &
                                         recv_comm         = mesh%parallel_element(pelem_ID)%recv_comm,         &
                                         recv_domain       = mesh%parallel_element(pelem_ID)%recv_domain,       &
                                         recv_element      = mesh%parallel_element(pelem_ID)%recv_element,      &
                                         recv_dof          = mesh%parallel_element(pelem_ID)%recv_dof,          &
                                         recv_xdof         = mesh%parallel_element(pelem_ID)%recv_xdof)

            xi   = donors_xi%at(1)
            eta  = donors_eta%at(1)
            zeta = donors_zeta%at(1)
            donor_coordinate = [xi,eta,zeta]
            donor_found = .true.
            if (present(donor_volume)) donor_volume = mesh%parallel_element(pelem_ID)%vol

        elseif (donors_pelem_ID%size() > 1) then

            ! Handle multiple potential donors: Choose donor with minimum volume - should be best resolved
            if (allocated(donor_vols) ) deallocate(donor_vols)
            allocate(donor_vols(donors_pelem_ID%size()))

            do idonor = 1,donors_pelem_ID%size()
                pelem_ID = donors_pelem_ID%at(idonor)
                donor_vols(idonor) = mesh%parallel_element(pelem_ID)%vol
            end do

            ! Get index of domain with minimum volume
            donor_index = minloc(donor_vols,1)
            pelem_ID = donors_pelem_ID%at(donor_index)   ! donor index from candidates with minimum volume

            donor_element = element_info(idomain_g         = mesh%parallel_element(pelem_ID)%idomain_g,         &
                                         idomain_l         = mesh%parallel_element(pelem_ID)%idomain_l,         &
                                         ielement_g        = mesh%parallel_element(pelem_ID)%ielement_g,        &
                                         ielement_l        = mesh%parallel_element(pelem_ID)%ielement_l,        &
                                         iproc             = mesh%parallel_element(pelem_ID)%iproc,             &
                                         pelem_ID          = pelem_ID,                                          &
                                         coordinate_system = mesh%parallel_element(pelem_ID)%coordinate_system, &
                                         eqn_ID            = mesh%parallel_element(pelem_ID)%eqn_ID,            &
                                         nfields           = mesh%parallel_element(pelem_ID)%nfields,           &
                                         ntime             = mesh%parallel_element(pelem_ID)%ntime,             &
                                         nterms_s          = mesh%parallel_element(pelem_ID)%nterms_s,          &
                                         nterms_c          = mesh%parallel_element(pelem_ID)%nterms_c,          &
                                         dof_start         = mesh%parallel_element(pelem_ID)%dof_start,         &
                                         dof_local_start   = mesh%parallel_element(pelem_ID)%dof_local_start,   &
                                         xdof_start        = mesh%parallel_element(pelem_ID)%xdof_start,        &
                                         xdof_local_start  = mesh%parallel_element(pelem_ID)%xdof_local_start,  &
                                         recv_comm         = mesh%parallel_element(pelem_ID)%recv_comm,         &
                                         recv_domain       = mesh%parallel_element(pelem_ID)%recv_domain,       &
                                         recv_element      = mesh%parallel_element(pelem_ID)%recv_element,      &
                                         recv_dof          = mesh%parallel_element(pelem_ID)%recv_dof,          &
                                         recv_xdof         = mesh%parallel_element(pelem_ID)%recv_xdof)

            ! Set donor coordinate and volume if present
            xi   = donors_xi%at(donor_index)
            eta  = donors_eta%at(donor_index)
            zeta = donors_zeta%at(donor_index)
            donor_coordinate = [xi,eta,zeta]
            donor_found = .true.
            if (present(donor_volume)) donor_volume = mesh%parallel_element(pelem_ID)%vol

        else
            call chidg_signal(FATAL,"find_gq_donor_parallel: invalid number of donors")
        end if

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

    !>  Reset the module indices corresponding to the last detected overset donor.
    !!
    !!  This should be called when a new environment is initialized and is setup
    !!  to be called in chidg%start_up('core').
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   12/26/2018
    !!
    !------------------------------------------------------------------------------
    subroutine clear_donor_cache()

        ! Reset previous donor element to null, so future calls (maybe in tests) don't
        ! try to access an element that might not exist.
        idomain_g_prev = NO_ID
        idomain_l_prev = NO_ID
        ielement_g_prev = NO_ID
        ielement_l_prev = NO_ID

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

end module mod_chimera


module amr_parameters

  ! Define real types
  integer,parameter::sp=kind(1.0E0)
#ifndef NPRE
  integer,parameter::dp=kind(1.0E0) ! default
#else
#if NPRE==4
  integer,parameter::dp=kind(1.0E0) ! real*4
#else
  integer,parameter::dp=kind(1.0D0) ! real*8
#endif
#endif
#ifdef QUADHILBERT
  integer,parameter::qdp=kind(1.0_16) ! real*16
#else
  integer,parameter::qdp=kind(1.0_8) ! real*8
#endif
  integer,parameter::MAXOUT=1000
  integer,parameter::MAXLEVEL=100

  ! Number of dimensions
#ifndef NDIM
  integer,parameter::ndim=1
#else
  integer,parameter::ndim=NDIM
#endif
  integer,parameter::twotondim=2**ndim
  integer,parameter::threetondim=3**ndim
  integer,parameter::twondim=2*ndim

  ! Vectorization parameter
#ifndef NVECTOR
  integer,parameter::nvector=500  ! Size of vector sweeps
#else
  integer,parameter::nvector=NVECTOR
#endif

  integer, parameter :: nstride = 65536

  ! Run control
  logical::verbose =.false.   ! Write everything
  logical::hydro   =.false.   ! Hydro activated
  logical::pic     =.false.   ! Particle In Cell activated
  logical::poisson =.false.   ! Poisson solver activated
  logical::cosmo   =.false.   ! Cosmology activated
  logical::star    =.false.   ! Star formation activated
  logical::sink    =.false.   ! Sink particles activated
  logical::rt      =.false.   ! Radiative transfer activated
  logical::debug   =.false.   ! Debug mode activated
  logical::static  =.false.   ! Static mode activated
  logical::tracer  =.false.   ! Tracer particles activated
  logical::lightcone=.false.  ! Enable lightcone generation
  logical::clumpfind=.false.  ! Enable clump finder
  logical::gas_analytics=.false.  ! Turn on a routine that outputs some gas-related data at every output
  logical::aton=.false.       ! Enable ATON coarse grid radiation transfer

  ! Mesh parameters
  integer::geom=1             ! 1: cartesian, 2: cylindrical, 3: spherical
  integer::nx=1,ny=1,nz=1     ! Number of coarse cells in each dimension
  integer::levelmin=1         ! Full refinement up to levelmin
  integer::nlevelmax=1        ! Maximum number of level
  integer::ngridmax=0         ! Maximum number of grids
  integer,dimension(1:MAXLEVEL)::nexpand=1 ! Number of mesh expansion
  integer::nexpand_bound=1    ! Number of mesh expansion for virtual boundaries
  real(dp)::boxlen=1.0D0      ! Box length along x direction
  character(len=128)::ordering='hilbert'
  logical::cost_weighting=.true. ! Activate load balancing according to cpu time
  ! Recursive bisection tree parameters
  integer::nbilevelmax=1      ! Max steps of bisection partitioning
  integer::nbinodes=3         ! Max number of internal nodes
  integer::nbileafnodes=2     ! Max number of leaf (terminal) nodes
  real(dp)::bisec_tol=0.05d0  ! Tolerance for bisection load balancing

  ! Step parameters
  integer::nrestart=0         ! New run or backup file number
  integer::nstepmax=1000000   ! Maximum number of time steps
  integer::ncontrol=1         ! Write control variables
  integer::fbackup=1000000    ! Backup data to disk
  integer::nremap=0           ! Load balancing frequency (0: never)

  ! Output parameters
  integer::iout=1             ! Increment for output times
  integer::ifout=1            ! Increment for output files
  integer::iback=1            ! Increment for backup files
  integer::noutput=1          ! Total number of outputs
  integer::foutput=1000000    ! Frequency of outputs
  integer::output_mode=0      ! Output mode (for hires runs)
  logical::gadget_output=.false. ! Output in gadget format

  ! Lightcone parameters
  real(dp)::thetay_cone=12.5
  real(dp)::thetaz_cone=12.5
  real(dp)::zmax_cone=2.0

  ! Cosmology and physical parameters
  real(dp)::boxlen_ini        ! Box size in h-1 Mpc
  real(dp)::omega_b=0.0D0     ! Omega Baryon
  real(dp)::omega_m=1.0D0     ! Omega Matter
  real(dp)::omega_l=0.0D0     ! Omega Lambda
  real(dp)::omega_k=0.0D0     ! Omega Curvature
  real(dp)::h0     =1.0D0     ! Hubble constant in km/s/Mpc
  real(dp)::aexp   =1.0D0     ! Current expansion factor
  real(dp)::hexp   =0.0D0     ! Current Hubble parameter
  real(dp)::texp   =0.0D0     ! Current proper time
  real(dp)::n_sink =1D30      ! Sink particle density threshold in H/cc
  real(dp)::m_star =-1.0      ! Star particle mass in units of mass_sph
  real(dp)::n_star =0.1D0     ! Star formation density threshold in H/cc
  real(dp)::t_star =0.0D0     ! Star formation time scale in Gyr
  real(dp)::eps_star=0.0D0    ! Star formation efficiency (0.02 at n_star=0.1 gives t_star=8 Gyr)
  real(dp)::T2_star=0.0D0     ! Typical ISM polytropic temperature
  real(dp)::g_star =1.6D0     ! Typical ISM polytropic index
  real(dp)::jeans_ncells=-1   ! Jeans polytropic EOS
  real(dp)::del_star=2.D2     ! Minimum overdensity to define ISM
  real(dp)::eta_sn =0.0D0     ! Supernova mass fraction
  real(dp)::yield  =0.0D0     ! Supernova yield
  real(dp)::f_ek   =1.0D0     ! Supernovae kinetic energy fraction (only between 0 and 1)
  real(dp)::rbubble=0.0D0     ! Supernovae superbubble radius in pc
  real(dp)::f_w    =0.0D0     ! Supernovae mass loading factor
  integer ::ndebris=1         ! Supernovae debris particle number
  real(dp)::mass_gmc=-1.0     ! Stochastic exploding GMC mass
  real(dp)::z_ave  =0.0D0     ! Average metal abundance
  real(dp)::B_ave  =0.0D0     ! Average magnetic field
  real(dp)::z_reion=8.5D0     ! Reionization redshift
  real(dp)::T2_start          ! Starting gas temperature
  real(dp)::t_delay=1.0D1     ! Feedback time delay in Myr
  real(dp)::t_diss =20.0D0    ! Dissipation timescale for feedback
  real(dp)::J21    =0.0D0     ! UV flux at threshold in 10^21 units
  real(dp)::a_spec =1.0D0     ! Slope of the UV spectrum
  real(dp)::beta_fix=0.0D0    ! Pressure fix parameter
  real(dp)::rsink_max=10      ! Sink isolation criterion in kpc
  real(dp)::msink_max=1d5     ! Maximum seed mass in solar masses
  real(dp)::kappa_IR=0d0      ! IR dust opacity
  real(dp)::ind_rsink=4.0d0   ! Number of cells defining the radius of the sphere where AGN feedback is active
  real(dp)::ir_eff=0.75       ! efficiency of the IR feedback (only when ir_feedback=.true.)
  real(dp)::larson_lifetime=5000! lifetime of first larson core in years

  logical ::self_shielding=.false.
  logical ::pressure_fix=.false.
  logical ::nordlund_fix=.true.
  logical ::cooling=.false.
  logical ::neq_chem=.false.  ! Non-equilbrium chemistry activated
  logical ::isothermal=.false.
  logical ::metal=.false.
  logical ::bondi=.false.      ! Activate Bondi accretion onto sink particle
  logical ::haardt_madau=.false.
  logical ::delayed_cooling=.false.
  logical ::smbh=.false.
  logical ::agn=.false.
  logical ::use_proper_time=.false.
  logical ::ir_feedback=.false. ! Activate ir feedback from accreting sinks
  logical ::merge_stars=.false. ! Merge young star formation sink particles (first larson cores)
  logical ::flux_accretion=.false.

  ! Output times
  real(dp),dimension(1:MAXOUT)::aout=1.1       ! Output expansion factors
  real(dp),dimension(1:MAXOUT)::tout=0.0       ! Output times

  ! Movie
  integer::imovout=0             ! Increment for output times
  integer::imov=1                ! Initialize
  real(kind=8)::tendmov=0.,aendmov=0.
  real(kind=8),allocatable,dimension(:)::amovout,tmovout
  logical::movie=.false.
  integer::nx_frame=512
  integer::ny_frame=512
  integer::levelmax_frame=0
  integer::ivar_frame=1
  real(kind=8),dimension(1:4)::xcentre_frame=0d0
  real(kind=8),dimension(1:4)::ycentre_frame=0d0
  real(kind=8),dimension(1:4)::zcentre_frame=0d0
  real(kind=8),dimension(1:4)::deltax_frame=0d0
  real(kind=8),dimension(1:4)::deltay_frame=0d0
  real(kind=8),dimension(1:4)::deltaz_frame=0d0

  ! Refinement parameters for each level
  real(dp),dimension(1:MAXLEVEL)::m_refine =-1.0 ! Lagrangian threshold
  real(dp),dimension(1:MAXLEVEL)::r_refine =-1.0 ! Radius of refinement region
  real(dp),dimension(1:MAXLEVEL)::x_refine = 0.0 ! Center of refinement region
  real(dp),dimension(1:MAXLEVEL)::y_refine = 0.0 ! Center of refinement region
  real(dp),dimension(1:MAXLEVEL)::z_refine = 0.0 ! Center of refinement region
  real(dp),dimension(1:MAXLEVEL)::exp_refine = 2.0 ! Exponent for distance
  real(dp),dimension(1:MAXLEVEL)::a_refine = 1.0 ! Ellipticity (Y/X)
  real(dp),dimension(1:MAXLEVEL)::b_refine = 1.0 ! Ellipticity (Z/X)
  real(dp)::var_cut_refine=-1.0 ! Threshold for variable-based refinement
  real(dp)::mass_cut_refine=-1.0 ! Mass threshold for particle-based refinement
  integer::ivar_refine=-1 ! Variable index for refinement

  ! Initial condition files for each level
  logical::multiple=.false.
  character(LEN=80),dimension(1:MAXLEVEL)::initfile=' '
  character(LEN=20)::filetype='ascii'

  ! Initial condition regions parameters
  integer,parameter::MAXREGION=100
  integer                           ::nregion=0
  character(LEN=10),dimension(1:MAXREGION)::region_type='square'
  real(dp),dimension(1:MAXREGION)   ::x_center=0.
  real(dp),dimension(1:MAXREGION)   ::y_center=0.
  real(dp),dimension(1:MAXREGION)   ::z_center=0.
  real(dp),dimension(1:MAXREGION)   ::length_x=1.E10
  real(dp),dimension(1:MAXREGION)   ::length_y=1.E10
  real(dp),dimension(1:MAXREGION)   ::length_z=1.E10
  real(dp),dimension(1:MAXREGION)   ::exp_region=2.0

  ! Boundary conditions parameters
  integer,parameter::MAXBOUND=100
  logical                           ::simple_boundary=.false.
  integer                           ::nboundary=0
  integer                           ::icoarse_min=0
  integer                           ::icoarse_max=0
  integer                           ::jcoarse_min=0
  integer                           ::jcoarse_max=0
  integer                           ::kcoarse_min=0
  integer                           ::kcoarse_max=0
  integer ,dimension(1:MAXBOUND)    ::boundary_type=0
  integer ,dimension(1:MAXBOUND)    ::ibound_min=0
  integer ,dimension(1:MAXBOUND)    ::ibound_max=0
  integer ,dimension(1:MAXBOUND)    ::jbound_min=0
  integer ,dimension(1:MAXBOUND)    ::jbound_max=0
  integer ,dimension(1:MAXBOUND)    ::kbound_min=0
  integer ,dimension(1:MAXBOUND)    ::kbound_max=0

  !Number of processes sharing one token
  !Only one process can write at a time in an I/O group
  integer::IOGROUPSIZE=0           ! Main snapshot
  integer::IOGROUPSIZECONE=0       ! Lightcone
  integer::IOGROUPSIZEREP=0        ! Subfolder size
  logical::withoutmkdir=.false.    !If true mkdir should be done before the run
  logical::print_when_io=.false.   !If true print when IO
  logical::synchro_when_io=.false. !If true synchronize when IO

end module amr_parameters


      SUBROUTINE KSTERM
*
*
*       Termination of KS regularization.
*       ---------------------------------
*
      INCLUDE 'common6.h'
      COMMON/SLOW0/  RANGE,ISLOW(10)
      COMMON/BINARY/  CM(4,MMAX),XREL(3,MMAX),VREL(3,MMAX),
     &                HM(MMAX),UM(4,MMAX),UMDOT(4,MMAX),TMDIS(MMAX),
     &                NAMEM(MMAX),NAMEG(MMAX),KSTARM(MMAX),IFLAG(MMAX)
      REAL*8  SAVE(15)
*
*
*       Copy pair index from COMMON save and define KS components & c.m.
      IPAIR = KSPAIR
      I1 = 2*IPAIR - 1
      I2 = I1 + 1
      ICM = N + IPAIR
*
*       Predict coordinates and evaluate potential energy w.r.t. perturbers.
      CALL KSRES(IPAIR,J1,J2,0.0D0)
      NP = LIST(1,I1)
      DO 5 L = 1,NP
          JPERT(L) = LIST(L+1,I1)
    5 CONTINUE
      JLIST(1) = I1
      JLIST(2) = I2
      CALL NBPOT(2,NP,POT1)
*
*       Rectify the orbit to yield U & UDOT consistent with binding energy.
      CALL KSRECT(IPAIR)
*
*       Retain final KS variables for explicit restart at merge termination.
      IF (TIME.LE.TBLOCK.AND.IPHASE.EQ.6) THEN
          HM(NMERGE) = H(IPAIR)
          DO 6 K = 1,4
              UM(K,NMERGE) = U(K,IPAIR)
              UMDOT(K,NMERGE) = UDOT(K,IPAIR)
    6     CONTINUE
      END IF
*
*       Check optional diagnostic output for disrupted new hard binary.
      IF (KZ(8).EQ.0) GO TO 10
      IF (LIST(2,I1+1).NE.0.OR.H(IPAIR).GT.0.0) GO TO 10
      IF (GAMMA(IPAIR).GT.0.5.AND.JCOMP.GT.0.OR.IPHASE.EQ.7) THEN
          IF (JCOMP.EQ.0.OR.IPHASE.EQ.7) JCOMP = I1
          K = 0
          IF (JCOMP.GT.N) THEN
              J2 = 2*(JCOMP - N)
              K = LIST(2,J2)
          END IF
          SEMI = -0.5*BODY(ICM)/H(IPAIR)
          EB = -0.5*BODY(I1)*BODY(I2)/SEMI
          RI = SQRT((X(1,ICM) - RDENS(1))**2 +
     &              (X(2,ICM) - RDENS(2))**2 +
     &              (X(3,ICM) - RDENS(3))**2)
          WRITE (8,8)  TIME+TOFF, NAME(I1), NAME(I2), K, NAME(JCOMP),
     &                 BODY(JCOMP), EB, SEMI, R(IPAIR), GAMMA(IPAIR), RI
    8     FORMAT (' END BINARY   T =',F8.1,'  NAME = ',2I6,I3,I6,
     &                      '  M(J) =',F8.4,'  EB =',F10.5,'  A =',F8.5,
     &                          '  R =',F8.5,'  G =',F5.2,'  RI =',F5.2)
      END IF
*
   10 IF (KZ(10).GT.1) THEN
          RI = SQRT((X(1,ICM) - RDENS(1))**2 +
     &              (X(2,ICM) - RDENS(2))**2 +
     &              (X(3,ICM) - RDENS(3))**2)
*       Include error of the bilinear relation (cf. Book Eqn.(4.30)).
          ERR = U(4,IPAIR)*UDOT(1,IPAIR) - U(3,IPAIR)*UDOT(2,IPAIR) +
     &          U(2,IPAIR)*UDOT(3,IPAIR) - U(1,IPAIR)*UDOT(4,IPAIR)
          WRITE (6,15)  TIME+TOFF, BODY(I1), BODY(I1+1), DTAU(IPAIR),
     &                  R(IPAIR), RI, H(IPAIR), IPAIR, GAMMA(IPAIR),
     &                  STEP(I1), LIST(1,I1), LIST(1,ICM), ERR
   15     FORMAT (/,' END KSREG    TIME =',F8.2,1P,2E9.1,0P,F6.3,1P,
     &                E10.1,0P,F7.2,F9.2,I5,F8.3,1P,E10.1,2I5,1P,E10.2)
      END IF
*
*       Obtain global coordinates & velocities.
      CALL RESOLV(IPAIR,2)
*
*       Correct for differential potential energy due to rectification.
      CALL NBPOT(2,NP,POT2)
*       Add correction term with opposite sign for conservation.
*     ECOLL = ECOLL + (POT2 - POT1)
*     IF (ABS(POT1-POT2).GT.0.0001) WRITE (6,16)  POT1,BE(3),POT1-POT2
*  16 FORMAT (' CORRECT:    POT1 BE3 POT1-POT2  ',2F10.6,F10.6)
*
*       Modify c.m. neighbour radius by density contrast and set new values.
      NNB = LIST(1,ICM) + 1
*       Check predicted neighbour number and form volume ratio.
      NBP = MIN(ALPHA*SQRT(FLOAT(NNB)*RS(ICM))/(RS(ICM)**2),ZNBMAX)
      NBP = MAX(NBP,INT(ZNBMIN))
      A0 = FLOAT(NBP)/FLOAT(NNB)
*       Re-determine neighbour list on zero membership for distant binary.
      IF (LIST(1,ICM).EQ.0) THEN
          RS0 = 0.1*(ABS(X(1,ICM)) + ABS(X(2,ICM)))
          CALL NBLIST(ICM,RS0)
          NNB = LIST(1,ICM) + 1
      END IF
*       Copy all neighbours in the case of merger.
      IF (IPHASE.EQ.6) THEN
          A0 = 1.0
          NBP = NNB - 1
      END IF
      IF (RS(ICM).GT.-100.0*BODY(ICM)/H(IPAIR)) A0 = 1.0
*       Accept old c.m. values for small length scale ratio or H > 0.
      RS(I1) = RS(ICM)*A0**0.3333
      RS(I1+1) = RS(I1)
      RS2 = RS(I1)**2
*
*       Select neighbours for components inside the modified c.m. sphere.
   20 NNB1 = 1
      DO 25 L = 2,NNB
          J = LIST(L,ICM)
          RIJ2 = (X(1,ICM) - X(1,J))**2 + (X(2,ICM) - X(2,J))**2 +
     &                                    (X(3,ICM) - X(3,J))**2
*       Ensure that at least the predicted neighbour number is reached.
          IF (RIJ2.LT.RS2.OR.(NNB1 + NNB - L.LE.NBP.AND.
     &        NNB1.LT.NNBMAX-1)) THEN
              NNB1 = NNB1 + 1
              ILIST(NNB1) = J
          END IF
   25 CONTINUE
*
*       Check that there is space for adding dominant component later.
      IF (NNB1.GE.NNBMAX.AND.IPHASE.NE.6) THEN
          RS2 = 0.9*RS2
          GO TO 20
      END IF
*
*       Reduce pair index, total number & single particle index.
      NPAIRS = NPAIRS - 1
      NTOT = N + NPAIRS
      IFIRST = 2*NPAIRS + 1
*
*       Save name of components & flag for modifying LISTD in UPDATE.
      JLIST(1) = NAME(I1)
      JLIST(2) = NAME(I1+1)
      JLIST(3) = LIST(2,I1+1)
*
*       Skip adjustment of tables if last or only pair being treated.
      IF (IPAIR.EQ.NPAIRS + 1) GO TO 60
*
*       Move the second component before the first.
      DO 50 KCOMP = 2,1,-1
          I = 2*IPAIR - 2 + KCOMP
*
          DO 30 K = 1,3
              SAVE(K) = X(K,I)
              SAVE(K+3) = X0DOT(K,I)
   30     CONTINUE
*       Current velocity has been set in routine RESOLV.
          SAVE(7) = BODY(I)
          SAVE(8) = RS(I)
          SAVE(9) = RADIUS(I)
          SAVE(10) = TEV(I)
          SAVE(11) = BODY0(I)
          SAVE(12) = TEV0(I)
          SAVE(13) = EPOCH(I)
          SAVE(14) = SPIN(I)
          SAVE(15) = ZLMSTY(I)
          NAMEI = NAME(I)
          KSI = KSTAR(I)
          LAST = 2*NPAIRS - 1 + KCOMP
*
*       Move up global variables of other components.
          DO 40 J = I,LAST
              J1 = J + 1
              DO 35 K = 1,3
                  X(K,J) = X(K,J1)
*       Copy latest X & X0DOT (= 0) of single components for predictor.
                  X0(K,J) = X(K,J)
                  X0DOT(K,J) = X0DOT(K,J1)
   35         CONTINUE
              BODY(J) = BODY(J1)
              RS(J) = RS(J1)
              RADIUS(J) = RADIUS(J1)
              TEV(J) = TEV(J1)
              TEV0(J) = TEV0(J1)
              BODY0(J) = BODY0(J1)
              EPOCH(J) = EPOCH(J1)
              SPIN(J) = SPIN(J1)
              ZLMSTY(J) = ZLMSTY(J1)
              NAME(J) = NAME(J1)
              KSTAR(J) = KSTAR(J1)
              STEP(J) = STEP(J1)
              T0(J) = T0(J1)
              K = LIST(1,J1) + 1
              IF (K.EQ.1) K = 2
*       Transfer unmodified neighbour lists (include flag in 2nd comp).
              DO 38 L = 1,K
                  LIST(L,J) = LIST(L,J1)
   38         CONTINUE
   40     CONTINUE
*
*       Set new component index and copy basic variables.
          I = LAST + 1
          DO 45 K = 1,3
              X(K,I) = SAVE(K)
              X0DOT(K,I) = SAVE(K+3)
              XDOT(K,I) = SAVE(K+3)
   45     CONTINUE
          BODY(I) = SAVE(7)
          RS(I) = SAVE(8)
          RADIUS(I) = SAVE(9)
          TEV(I) = SAVE(10)
          BODY0(I) = SAVE(11)
          TEV0(I) = SAVE(12)
          EPOCH(I) = SAVE(13)
          SPIN(I) = SAVE(14)
          ZLMSTY(I) = SAVE(15)
          NAME(I) = NAMEI
          KSTAR(I) = KSI
   50 CONTINUE
*
*       Include removal of the circularization name NAMEC from chaos table.
      IF (KSTAR(ICM).GE.10.AND.NCHAOS.GT.0.AND.IPHASE.NE.6) THEN
*       Note that NAMEC may remain dormant for hierarchical systems.
          II = -ICM
          CALL SPIRAL(II)
      END IF
*
*       Update all regularized variables.
      CALL REMOVE(IPAIR,2)
*
*       Remove old c.m. from all COMMON tables (no F & FDOT correction).
      CALL REMOVE(ICM,3)
*
*       Set new global index of first & second component.
   60 ICOMP = 2*NPAIRS + 1
      JCOMP = ICOMP + 1
*
*       Save c.m. neighbour list for routine FPOLY1/2 (may be renamed below).
      ILIST(1) = NNB1 - 1
      DO 65 L = 1,NNB1
          LIST(L,ICOMP) = ILIST(L)
   65 CONTINUE
*
*       Modify all relevant COMMON list arrays.
      CALL UPDATE(IPAIR)
*
*       Check replacing of single KS component by corresponding c.m.
   70 IF (LIST(2,ICOMP).LT.ICOMP) THEN
          J2 = LIST(2,ICOMP)
          J = KVEC(J2) + N
          DO 80 L = 2,NNB1
              IF (L.LT.NNB1.AND.LIST(L+1,ICOMP).LT.J) THEN
                  LIST(L,ICOMP) = LIST(L+1,ICOMP)
              ELSE
                  LIST(L,ICOMP) = J
              END IF
   80     CONTINUE
*       Check again until first neighbour > ICOMP.
          GO TO 70
      END IF
*
*       Make space for dominant component and copy members to JCOMP list.
      DO 90 L = NNB1,2,-1
          LIST(L+1,ICOMP) = LIST(L,ICOMP)
          LIST(L+1,JCOMP) = LIST(L,ICOMP)
   90 CONTINUE
*
*       Set dominant component in first location and specify membership.
      LIST(2,ICOMP) = JCOMP
      LIST(2,JCOMP) = ICOMP
      LIST(1,ICOMP) = NNB1
      LIST(1,JCOMP) = NNB1
*
*       Initialize T0, T0R, X0 & X0DOT for both components.
      T0(ICOMP) = TIME
      T0(JCOMP) = TIME
      T0R(ICOMP) = TIME
      T0R(JCOMP) = TIME
      DO 95 K = 1,3
          X0(K,ICOMP) = X(K,ICOMP)
          X0(K,JCOMP) = X(K,JCOMP)
          X0DOT(K,ICOMP) = XDOT(K,ICOMP)
          X0DOT(K,JCOMP) = XDOT(K,JCOMP)
   95 CONTINUE
*
*       Form new force polynomials (skip triple, quad, merge & chain).
      IF (IPHASE.LT.4) THEN
*       Predict current coordinates & velocities for the neighbours.
          CALL XVPRED(ICOMP,NNB1)
*
*       Obtain new polynomials & steps.
          CALL FPOLY1(ICOMP,JCOMP,2)
          CALL FPOLY2(ICOMP,JCOMP,2)
      END IF
*
*       Check updating of global index for chain c.m.
      IF (NCH.GT.0) THEN
          CALL CHFIND
      END IF
*
      RETURN
*
      END


!
!  Copyright 2019-2020 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.
!

#include "config.h"

module nonlocal_potential
  implicit none

! WARNING: We must not call these except for hpsi routine.

contains

subroutine dpseudo(tpsi,htpsi,info,nspin,ppg)
  use structures
  use communication, only: comm_summation
  use timer
  implicit none
  integer,intent(in) :: nspin
  type(s_parallel_info),intent(in) :: info
  type(s_pp_grid),intent(in) :: ppg
  type(s_orbital),intent(in) :: tpsi
  type(s_orbital) :: htpsi
  !
  integer :: ispin,io,ik,im,im_s,im_e,ik_s,ik_e,io_s,io_e,norb
  integer :: ilma,ia,j,ix,iy,iz,Nlma,ilocal
  real(8) :: uVpsi,wrk
  real(8),allocatable :: uVpsibox (:,:,:,:,:)
  real(8),allocatable :: uVpsibox2(:,:,:,:,:)

  call timer_begin(LOG_UHPSI_PSEUDO)

  im_s = info%im_s
  im_e = info%im_e
  ik_s = info%ik_s
  ik_e = info%ik_e
  io_s = info%io_s
  io_e = info%io_e
  norb = Nspin* info%numo * info%numk * info%numm

  Nlma = ppg%Nlma

  if(info%if_divide_rspace) then

    allocate(uVpsibox (Nlma,Nspin,io_s:io_e,ik_s:ik_e,im_s:im_e))
    allocate(uVpsibox2(Nlma,Nspin,io_s:io_e,ik_s:ik_e,im_s:im_e))

!$omp parallel do collapse(4) &
!$omp             private(im,ik,io,ispin,ilma,ia,uVpsi,j,ix,iy,iz)
    do im=im_s,im_e
    do ik=ik_s,ik_e
    do io=io_s,io_e
    do ispin=1,Nspin

      do ilma=1,Nlma
        ia = ppg%ia_tbl(ilma)
        uVpsi = 0.d0
        do j=1,ppg%mps(ia)
          ix = ppg%jxyz(1,j,ia)
          iy = ppg%jxyz(2,j,ia)
          iz = ppg%jxyz(3,j,ia)
          uVpsi = uVpsi + ppg%uV(j,ilma) * tpsi%rwf(ix,iy,iz,ispin,io,ik,im)
        end do
        uVpsi = uVpsi * ppg%rinv_uvu(ilma)
        uVpsibox(ilma,ispin,io,ik,im) = uVpsi
      end do

    end do
    end do
    end do
    end do
!$omp end parallel do

    call timer_end(LOG_UHPSI_PSEUDO)

    call timer_begin(LOG_UHPSI_PSEUDO_COMM)
    call comm_summation(uVpsibox,uVpsibox2,Nlma*Norb,info%icomm_r)
    call timer_end(LOG_UHPSI_PSEUDO_COMM)

    call timer_begin(LOG_UHPSI_PSEUDO)

!$omp parallel do collapse(4) &
!$omp             private(im,ik,io,ispin,ilocal,ilma,ia,uVpsi,j,ix,iy,iz,wrk)
    do im=im_s,im_e
    do ik=ik_s,ik_e
    do io=io_s,io_e
    do ispin=1,Nspin

      do ilocal=1,ppg%ilocal_nlma
        ilma=ppg%ilocal_nlma2ilma(ilocal)
        ia  =ppg%ilocal_nlma2ia  (ilocal)
        uVpsi = uVpsibox2(ilma,ispin,io,ik,im)
!OCL norecurrence
        do j=1,ppg%mps(ia)
          ix = ppg%jxyz(1,j,ia)
          iy = ppg%jxyz(2,j,ia)
          iz = ppg%jxyz(3,j,ia)
          wrk = uVpsi * ppg%uV(j,ilma)
          htpsi%rwf(ix,iy,iz,ispin,io,ik,im) = htpsi%rwf(ix,iy,iz,ispin,io,ik,im) + wrk
        end do
      end do

    end do
    end do
    end do
    end do
!$omp end parallel do

    deallocate(uVpsibox,uVpsibox2)

  else

!$omp parallel do collapse(4) &
!$omp             private(im,ik,io,ispin,ilma,ia,uVpsi,j,ix,iy,iz,wrk)
    do im=im_s,im_e
    do ik=ik_s,ik_e
    do io=io_s,io_e
    do ispin=1,Nspin

      do ilma=1,Nlma
        ia = ppg%ia_tbl(ilma)
        uVpsi = 0.d0
        do j=1,ppg%mps(ia)
          ix = ppg%jxyz(1,j,ia)
          iy = ppg%jxyz(2,j,ia)
          iz = ppg%jxyz(3,j,ia)
          uVpsi = uVpsi + ppg%uV(j,ilma) * tpsi%rwf(ix,iy,iz,ispin,io,ik,im)
        end do
        uVpsi = uVpsi * ppg%rinv_uvu(ilma)
!OCL norecurrence
        do j=1,ppg%mps(ia)
          ix = ppg%jxyz(1,j,ia)
          iy = ppg%jxyz(2,j,ia)
          iz = ppg%jxyz(3,j,ia)
          wrk = uVpsi * ppg%uV(j,ilma)
          htpsi%rwf(ix,iy,iz,ispin,io,ik,im) = htpsi%rwf(ix,iy,iz,ispin,io,ik,im) + wrk
        end do
      end do

    end do
    end do
    end do
    end do
!$omp end parallel do

  end if

  call timer_end(LOG_UHPSI_PSEUDO)

  return
end subroutine dpseudo

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

subroutine zpseudo(tpsi,htpsi,info,nspin,ppg)
  use structures
  use timer
  implicit none
  integer,intent(in) :: nspin
  type(s_parallel_info),intent(in) :: info
  type(s_pp_grid),intent(in) :: ppg
  type(s_orbital),intent(in) :: tpsi
  type(s_orbital) :: htpsi
  !
  integer :: ispin,io,ik,im,im_s,im_e,ik_s,ik_e,io_s,io_e
  integer :: ilma,ia,j,ix,iy,iz,Nlma,ilocal
  complex(8) :: uVpsi,wrk
  complex(8),allocatable :: uVpsibox (:,:,:,:,:)
  complex(8),allocatable :: uVpsibox2(:,:,:,:,:)

#ifdef FORTRAN_COMPILER_HAS_2MB_ALIGNED_ALLOCATION
!dir$ attributes align : 2097152 :: uVpsibox, uVpsibox2
#endif

  call timer_begin(LOG_UHPSI_PSEUDO)

  im_s = info%im_s
  im_e = info%im_e
  ik_s = info%ik_s
  ik_e = info%ik_e
  io_s = info%io_s
  io_e = info%io_e

  Nlma = ppg%Nlma

  if(info%if_divide_rspace) then

    call timer_end(LOG_UHPSI_PSEUDO)

    call calc_uVpsi_rdivided(nspin,info,ppg,tpsi,uVpsibox,uVpsibox2)

    call timer_begin(LOG_UHPSI_PSEUDO)

!$omp parallel do collapse(4) &
!$omp             private(im,ik,io,ispin,ilocal,ilma,ia,uVpsi,j,ix,iy,iz,wrk)
    do im=im_s,im_e
    do ik=ik_s,ik_e
    do io=io_s,io_e
    do ispin=1,Nspin

      do ilocal=1,ppg%ilocal_nlma
        ilma=ppg%ilocal_nlma2ilma(ilocal)
        ia  =ppg%ilocal_nlma2ia  (ilocal)
        uVpsi = uVpsibox2(ispin,io,ik,im,ilma)
!OCL norecurrence
        do j=1,ppg%mps(ia)
          ix = ppg%jxyz(1,j,ia)
          iy = ppg%jxyz(2,j,ia)
          iz = ppg%jxyz(3,j,ia)
          wrk = uVpsi * ppg%zekr_uV(j,ilma,ik)
          htpsi%zwf(ix,iy,iz,ispin,io,ik,im) = htpsi%zwf(ix,iy,iz,ispin,io,ik,im) + wrk
        end do
      end do

    end do
    end do
    end do
    end do
!$omp end parallel do

    deallocate(uVpsibox,uVpsibox2)

  else

!$omp parallel do collapse(4) &
!$omp             private(im,ik,io,ispin,ilma,ia,uVpsi,j,ix,iy,iz,wrk)
    do im=im_s,im_e
    do ik=ik_s,ik_e
    do io=io_s,io_e
    do ispin=1,Nspin

      do ilma=1,Nlma
        ia = ppg%ia_tbl(ilma)
        uVpsi = 0.d0
        do j=1,ppg%mps(ia)
          ix = ppg%jxyz(1,j,ia)
          iy = ppg%jxyz(2,j,ia)
          iz = ppg%jxyz(3,j,ia)
          uVpsi = uVpsi + conjg(ppg%zekr_uV(j,ilma,ik)) * tpsi%zwf(ix,iy,iz,ispin,io,ik,im)
        end do
        uVpsi = uVpsi * ppg%rinv_uvu(ilma)
!OCL norecurrence
        do j=1,ppg%mps(ia)
          ix = ppg%jxyz(1,j,ia)
          iy = ppg%jxyz(2,j,ia)
          iz = ppg%jxyz(3,j,ia)
          wrk = uVpsi * ppg%zekr_uV(j,ilma,ik)
          htpsi%zwf(ix,iy,iz,ispin,io,ik,im) = htpsi%zwf(ix,iy,iz,ispin,io,ik,im) + wrk
        end do
      end do

    end do
    end do
    end do
    end do
!$omp end parallel do

  end if

  call timer_end(LOG_UHPSI_PSEUDO)

  return
end subroutine zpseudo

subroutine calc_uVpsi(nspin,info,ppg,tpsi,uVpsibox)
  use structures
  use timer
  implicit none
  integer        ,intent(in) :: nspin
  type(s_parallel_info),intent(in) :: info
  type(s_pp_grid),intent(in) :: ppg
  type(s_orbital),intent(in) :: tpsi
  complex(8)    ,allocatable :: uVpsibox (:,:,:,:,:)
  integer :: ispin,io,ik,im,im_s,im_e,ik_s,ik_e,io_s,io_e,norb
  integer :: ilma,ia,j,ix,iy,iz,Nlma
  complex(8) :: uVpsi
  integer :: ilocal

  call timer_begin(LOG_UHPSI_PSEUDO)

  im_s = info%im_s
  im_e = info%im_e
  ik_s = info%ik_s
  ik_e = info%ik_e
  io_s = info%io_s
  io_e = info%io_e
  norb = Nspin* info%numo * info%numk * info%numm

  Nlma = ppg%Nlma

  allocate(uVpsibox(Nspin,io_s:io_e,ik_s:ik_e,im_s:im_e,Nlma))

!$omp parallel do collapse(4) &
!$omp             private(im,ik,io,ispin,ilocal,ilma,ia,uVpsi,j,ix,iy,iz)
  do im=im_s,im_e
  do ik=ik_s,ik_e
  do io=io_s,io_e
  do ispin=1,Nspin

    do ilocal=1,ppg%ilocal_nlma
      ilma=ppg%ilocal_nlma2ilma(ilocal)
      ia  =ppg%ilocal_nlma2ia  (ilocal)
      uVpsi = 0.d0
      do j=1,ppg%mps(ia)
        ix = ppg%jxyz(1,j,ia)
        iy = ppg%jxyz(2,j,ia)
        iz = ppg%jxyz(3,j,ia)
        uVpsi = uVpsi + conjg(ppg%zekr_uV(j,ilma,ik)) * tpsi%zwf(ix,iy,iz,ispin,io,ik,im)
      end do
      uVpsi = uVpsi * ppg%rinv_uvu(ilma)
      uVpsibox(ispin,io,ik,im,ilma) = uVpsi
    end do

  end do
  end do
  end do
  end do
!$omp end parallel do

  call timer_end(LOG_UHPSI_PSEUDO)

  return
end subroutine calc_uVpsi

subroutine calc_uVpsi_rdivided(nspin,info,ppg,tpsi,uVpsibox,uVpsibox2)
  use structures
  use timer
#ifdef FORTRAN_COMPILER_HAS_MPI_VERSION3
  use salmon_global, only: natom
  use communication, only: comm_wait_all,comm_show_error
  use mpi, only: MPI_SUM,MPI_DOUBLE_COMPLEX
#else
  use communication, only: comm_summation
#endif
  implicit none
  integer        ,intent(in) :: nspin
  type(s_parallel_info),intent(in) :: info
  type(s_pp_grid),intent(in) :: ppg
  type(s_orbital),intent(in) :: tpsi
  complex(8)    ,allocatable :: uVpsibox (:,:,:,:,:)
  complex(8)    ,allocatable :: uVpsibox2(:,:,:,:,:)
  integer :: ispin,io,ik,im,im_s,im_e,ik_s,ik_e,io_s,io_e,norb
  integer :: ilma,ia,j,ix,iy,iz,Nlma,ilocal
  complex(8) :: uVpsi
#ifdef FORTRAN_COMPILER_HAS_MPI_VERSION3
  integer :: ireqs(natom),nreq,ierr,is,ie,ns
#endif

  call timer_begin(LOG_UHPSI_PSEUDO)

  im_s = info%im_s
  im_e = info%im_e
  ik_s = info%ik_s
  ik_e = info%ik_e
  io_s = info%io_s
  io_e = info%io_e
  norb = Nspin* info%numo * info%numk * info%numm

  Nlma = ppg%Nlma

  allocate(uVpsibox (Nspin,io_s:io_e,ik_s:ik_e,im_s:im_e,Nlma))
  allocate(uVpsibox2(Nspin,io_s:io_e,ik_s:ik_e,im_s:im_e,Nlma))

#ifdef FORTRAN_COMPILER_HAS_MPI_VERSION3
  uVpsibox2 = 0d0
#else
  uVpsibox  = 0d0
#endif

!$omp parallel do collapse(4) &
!$omp             private(im,ik,io,ispin,ilocal,ilma,ia,uVpsi,j,ix,iy,iz)
  do im=im_s,im_e
  do ik=ik_s,ik_e
  do io=io_s,io_e
  do ispin=1,Nspin

    do ilocal=1,ppg%ilocal_nlma
      ilma=ppg%ilocal_nlma2ilma(ilocal)
      ia  =ppg%ilocal_nlma2ia  (ilocal)
      uVpsi = 0.d0
      do j=1,ppg%mps(ia)
        ix = ppg%jxyz(1,j,ia)
        iy = ppg%jxyz(2,j,ia)
        iz = ppg%jxyz(3,j,ia)
        uVpsi = uVpsi + conjg(ppg%zekr_uV(j,ilma,ik)) * tpsi%zwf(ix,iy,iz,ispin,io,ik,im)
      end do
      uVpsi = uVpsi * ppg%rinv_uvu(ilma)
      uVpsibox(ispin,io,ik,im,ilma) = uVpsi
    end do

  end do
  end do
  end do
  end do
!$omp end parallel do

  call timer_end(LOG_UHPSI_PSEUDO)

  call timer_begin(LOG_UHPSI_PSEUDO_COMM)
#ifdef FORTRAN_COMPILER_HAS_MPI_VERSION3
! FIXME: This subroutine uses MPI functions directly...
  nreq = 0
  do ia=1,natom
    is = ppg%irange_atom(1,ia)
    ie = ppg%irange_atom(2,ia)
    ns = ie - is + 1

    if (ppg%ireferred_atom(ia)) then
      nreq = nreq + 1
      call MPI_Iallreduce( uvpsibox (1,io_s,ik_s,im_s,is) &
                         , uvpsibox2(1,io_s,ik_s,im_s,is) &
                         , ns*norb, MPI_DOUBLE_COMPLEX, MPI_SUM, ppg%icomm_atom(ia) &
                         , ireqs(nreq), ierr )
      call comm_show_error(ierr)
    !else
      ! uvpsibox2(:,:,:,:,ppg%irange_ia(1:2,ia)) does not use in this process...
      ! We can skip self copy, but zero clear required
    end if
  end do
  call comm_wait_all(ireqs(1:nreq))
#else
  call comm_summation(uVpsibox,uVpsibox2,Nlma*Norb,info%icomm_r)
#endif
  call timer_end(LOG_UHPSI_PSEUDO_COMM)

  return
end subroutine calc_uVpsi_rdivided

end module nonlocal_potential