!>  This module contains procedures for initializing and maintaining the Chimera
!!  interfaces.
!!
!!  detect_chimera_faces
!!  detect_chimera_donors
!!  compute_chimera_interpolators
!!  find_gq_donor
!!
!!  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 mod_reference_elements, only: ref_elems

    use type_point
    use type_mesh,              only: mesh_t
    use type_chimera_send,      only: chimera_send
    use type_element_info,      only: element_info_t
    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

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, ndom, ielem, iface, nnodes, ierr, ChiID
        logical     :: orphan_face = .false.
        logical     :: chimera_face = .false.

        !
        ! Get number of domains
        !
        ndom = mesh%ndomains()

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

                    !
                    ! 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 = ( mesh%domain(idom)%faces(ielem,iface)%ftype == ORPHAN .or. &
                                    mesh%domain(idom)%faces(ielem,iface)%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
                        mesh%domain(idom)%faces(ielem,iface)%ftype = CHIMERA
                        nnodes = size(mesh%domain(idom)%faces(ielem,iface)%jinv)

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

                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, neqns, 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,        &
                       neqns_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(5), parallel_indices(9)

        real(rk)                :: donor_metric(3,3), parallel_metric(3,3)
        real(rk), allocatable   :: donor_vols(:)
        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(),'   :   ', 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_if()

                            !
                            ! 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))

                            gq_node = gq_node + offset

                            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)

                            ! 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
                            call MPI_BCast(receiver_indices,5,MPI_INTEGER4, iproc, ChiDG_COMM, ierr)

                            !
                            ! Call routine to find LOCAL gq donor for current node
                            !
                            call find_gq_donor(mesh,point_t(gq_node), 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(FATAL,"detect_chimera_donor: no valid donor found")
                            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,9,MPI_INTEGER4, idonor_proc, MPI_ANY_TAG, ChiDG_COMM, MPI_STATUS_IGNORE, ierr)
                                donor%idomain_g  = parallel_indices(1)
                                donor%idomain_l  = parallel_indices(2)
                                donor%ielement_g = parallel_indices(3)
                                donor%ielement_l = parallel_indices(4)
                                donor%iproc      = parallel_indices(5)
                                donor%eqn_ID     = parallel_indices(6)
                                donor%neqns      = parallel_indices(7)
                                donor%nterms_s   = parallel_indices(8)
                                donor%nterms_c   = parallel_indices(9)

                                ! 1: Receive donor local coordinate
                                ! 2: Receive donor metric matrix
                                ! 3: Receive donor inverse jacobian 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)

                            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

                                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)

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

                            end if

                            !
                            ! Add donor
                            !
                            donor_ID = mesh%domain(idom)%chimera%recv(ichimera_face)%add_donor(donor%idomain_g, donor%idomain_l, donor%ielement_g, donor%ielement_l, donor%iproc)
                            call mesh%domain(idom)%chimera%recv(ichimera_face)%donor(donor_ID)%set_properties(donor%nterms_c,donor%nterms_s,donor%neqns,donor%eqn_ID)
                            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)

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

                    !
                    ! Try to find donor
                    !
                    call find_gq_donor(mesh,point_t(gq_node),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%eqn_ID
                            parallel_indices(7) = donor%neqns
                            parallel_indices(8) = donor%nterms_s
                            parallel_indices(9) = donor%nterms_c

                            call MPI_Send(parallel_indices,9,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)

                            ! 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)

                        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

    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)

        real(rk)        :: 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)%idomain_g
                    donor_idomain_l  = mesh%domain(idom)%chimera%recv(ChiID)%donor(idonor)%idomain_l
                    donor_ielement_g = mesh%domain(idom)%chimera%recv(ChiID)%donor(idonor)%ielement_g
                    donor_ielement_l = mesh%domain(idom)%chimera%recv(ChiID)%donor(idonor)%ielement_l
                    donor_nterms_s   = mesh%domain(idom)%chimera%recv(ChiID)%donor(idonor)%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,receiver_face,donor_element,donor_coordinate,donor_found,donor_volume)
        type(mesh_t),               intent(in)              :: mesh
        type(point_t),              intent(in)              :: gq_node
        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, ncandidates, &
                                       idonor, ndonors, donor_index

        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)                :: gq_comp(3)
        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.

        xgq = gq_node%c1_
        ygq = gq_node%c2_
        zgq = gq_node%c3_

        !
        ! Loop through LOCAL domains and search for potential donor candidates
        !
        ncandidates = 0
        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 < xgq) .and. (xgq < xmax ) .and. &
                              (ymin < ygq) .and. (ygq < ymax ) .and. &
                              (zmin < zgq) .and. (zgq < zmax ) )

                !
                ! Make sure that we arent adding the receiver element itself as a potential donor
                !
                receiver = ( (idomain_g == receiver_face%idomain_g) .and. (ielement_g == receiver_face%ielement_g) )

                !
                ! If the node was within the bounding coordinates, flag the element as a potential donor
                !
                if (contained .and. (.not. receiver)) 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)
            !
            gq_comp = mesh%domain(idomain_l)%elems(ielement_l)%computational_point([xgq,ygq,zgq])    ! Newton's method routine
            node_found = (any(ieee_is_nan(gq_comp)) .eqv. .false.)

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

        end do ! icandidate

        !
        ! Sanity check on donors and set donor_element location
        !
        if (ndonors == 0) then
            donor_element%idomain_g  = 0
            donor_element%idomain_l  = 0
            donor_element%ielement_g = 0
            donor_element%ielement_l = 0
            donor_element%iproc      = NO_PROC

            donor_found = .false.

        elseif (ndonors == 1) then
            idonor = donors%at(1)   ! donor index from candidates
            donor_element%idomain_g  = candidate_domains_g%at(idonor)
            donor_element%idomain_l  = candidate_domains_l%at(idonor)
            donor_element%ielement_g = candidate_elements_g%at(idonor)
            donor_element%ielement_l = candidate_elements_l%at(idonor)
            donor_element%iproc      = IRANK
            donor_element%eqn_ID     = mesh%domain(donor_element%idomain_l)%eqn_ID
            donor_element%neqns      = mesh%domain(donor_element%idomain_l)%elems(donor_element%ielement_l)%neqns
            donor_element%nterms_s   = mesh%domain(donor_element%idomain_l)%elems(donor_element%ielement_l)%nterms_s
            donor_element%nterms_c   = mesh%domain(donor_element%idomain_l)%elems(donor_element%ielement_l)%nterms_c

            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()))

            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

            !
            ! Get index of domain with minimum volume
            !
            donor_index = minloc(donor_vols,1)
            idonor = donors%at(donor_index)

            donor_element%idomain_g  = candidate_domains_g%at(idonor)
            donor_element%idomain_l  = candidate_domains_l%at(idonor)
            donor_element%ielement_g = candidate_elements_g%at(idonor)
            donor_element%ielement_l = candidate_elements_l%at(idonor)
            donor_element%iproc      = IRANK
            donor_element%eqn_ID     = mesh%domain(donor_element%idomain_l)%eqn_ID
            donor_element%neqns      = mesh%domain(donor_element%idomain_l)%elems(donor_element%ielement_l)%neqns
            donor_element%nterms_s   = mesh%domain(donor_element%idomain_l)%elems(donor_element%ielement_l)%nterms_s
            donor_element%nterms_c   = mesh%domain(donor_element%idomain_l)%elems(donor_element%ielement_l)%nterms_c

            !
            ! 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

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

end module mod_chimera


!***********************************************************************
! Transfer MODFLOW data to PRMS
!***********************************************************************
!     ******************************************************************
!     Mapping module to convert MODFLOW to PRMS states for use by GSFLOW
!   Declared Parameters
!     gvr_hru_id, gvr_cell_id
!     ******************************************************************
      INTEGER FUNCTION gsflow_mf2prms()
      USE GSFMODFLOW, ONLY: Mfq2inch_conv, Gwc_col, Gwc_row
      USE PRMS_SOILZONE, ONLY: Hrucheck, Gvr_hru_id, Gw2sm_grav
      USE GWFUZFMODULE, ONLY: SEEPOUT
      USE PRMS_MODULE, ONLY: Process, Nhrucell, Gvr_cell_id
      IMPLICIT NONE
! Functions
      EXTERNAL print_module
! Local Variables
      INTEGER :: i
!      CHARACTER(LEN=14) :: MODNAME
! Save Variables
      CHARACTER(LEN=80), SAVE :: Version_gsflow_mf2prms
!***********************************************************************
      gsflow_mf2prms = 0

      IF ( Process(:3)=='run' ) THEN
        DO i = 1, Nhrucell
          IF ( Hrucheck(Gvr_hru_id(i))==1 ) &
     &         Gw2sm_grav(i) = SEEPOUT(Gwc_col(Gvr_cell_id(i)), Gwc_row(Gvr_cell_id(i)))*Mfq2inch_conv(i)
        ENDDO

      ELSEIF ( Process(:4)=='decl' ) THEN
        Version_gsflow_mf2prms = 'gsflow_mf2prms.f90 2017-11-15 09:58:00Z'
        CALL print_module(Version_gsflow_mf2prms, 'GSFLOW MODFLOW to PRMS      ', 90)
!        MODNAME = 'gsflow_mf2prms'
      ENDIF

      END FUNCTION gsflow_mf2prms


      subroutine fkfiex( buf, cbuf, ibuf, scr, lscr, iscr )
!-------------------------------------------------------------------------------
!
!  FKFIEX is the execution phase of the SIOSEIS seismic process FKFILT.
!  FKFILT performs filtering in the FK domain. See subroutine FKFIED for the
!  user description.
!
!     The input traces are supplied with wavenumbers varying from k = 0 to +Nyq
!  Each trace contains frequencies from -Nyq to + Nyq. This arrangement is the
!  one supplied by the 2D FFT and is convenient for the F-K migration.
!  However it differs from the conceptual model of the user which has
!  wavenumbers running from -Nyq -> 0 -> Nyq and only positive frequencies.
!
!    This setup is convenient for velocities filtering since lines are sorted
!  by FKFIED into increasing order, but care must be taken to add appropriate
!  velocity lines near v = 0 if the user wants different velocity filters in
!  0+ & 0-. Care is also need to ensure proper continuity of filter across
!  v (inf).
!
!     Conversely filters defined in terms of dips are consistent with the
!  conceptual model, since they vary smoothly from -inf -> 0 -> +inf, but are a
!  odds with the way the traces are given to FKFIEX. Thus the input dip lines
!  are converted to velocities as part of the input process.
!
! Inputs:
!    buf/cbuf/ibuf  : Equivalenced set of arrays holding the trace (header+data)
!    scr/lscr/iscr) : Equivalence set of scratch arrays.
!
! Outputs:
!    buf/cbuf/ibuf  : Filtered version of trace
!
! Call Chain:
!    CONTRO:FKFIEX
!
! Externals:
!   ClcWpt, FrmWnd                                                      ! Local fkfiex subroutines
!   INAP, RLSEAP EXIT
!   PODISC, RDDISC                                                      ! disk i/o
!
! Mdofications
!      10/12/88 ajh.  ( SZAPMEM )
! Last Modified
!      12/20/88 ajh   Altered Logic of line addition at v = 0
!                     Changed definition of vzerop
!                     Added more Debug info
!      3/16/89 ajh  Added read of binary header info thru common /READT/
!     7 Nov 91 pch  Add reinitialization stuff for prestack.
! 8 Apr 09 - Use common numdat rather than segy header word ISAMPPTR
! 27 Sept 10 - Don't cal FrmWnd if cut/pass goes across 0

      integer SZAPMEM, SZTRANP
      parameter (SZAPMEM = 65537)                                       ! Size of /APMEM/ : AP memory
      parameter (SZTRANP = 262144)                                      ! Size of /TRANP/: Transpose array at 512x512
! parameter definitions for the stop signal istop
      integer STOPNOTR, STOPTR, NOSTOP
      parameter (STOPNOTR  = -1)                                        ! last call but no trace passed
      parameter (STOPTR    =  1)                                        ! last call and a trace passed
      parameter (NOSTOP    =  0)                                        ! normal call to the routine
!
! parameter for AP
      integer CLEARAP, USEAP, NOAP
      integer DATINAP
      parameter (USEAP    = 1)                                          ! There is an AP available
      parameter (NOAP     = 0)                                          ! No AP available
      parameter (CLEARAP  = 0)                                          ! Get data out of AP simulator
      parameter (DATINAP   = 1)                                         ! Data is in the AP
! This include file include all (?) of the parameters needed to define SIOSEIS
! I/O routines. In particular it defines positions of objects in the SEGY
! headers & constants for these values
!
! EBCDIC HEADER
! Declare Header lengths. These are the length of the EXTERNAL disk image in
! host words.
      integer     CRAYEBC, NORMEBC
      parameter ( CRAYEBC  = 400)
      parameter ( NORMEBC  = 2*CRAYEBC)
!
! BINARY HEADER
      integer     CRAYBIN, NORMBIN
      parameter ( CRAYBIN  =  50)                                       ! length of external disk image
      parameter ( NORMBIN  = 2*CRAYBIN)
!
!  The position of objects in the Binary header
      integer    NTRCPTR,IFMTPTR, IDTYPPTR, INKPTR, ITSIPTR
      integer    ITDELPTR
      parameter (NTRCPTR  =  7)                                         ! No of traces / gather
      parameter (IFMTPTR  = 13)                                         ! The SEGY Format of the data
      parameter (IDTYPPTR = 31)                                         ! The Domain/ID of the data e.q. T-X data
      parameter (INKPTR   = 32)                                         ! The No. of wavenumbers in an f-k dataset
      parameter (ITSIPTR  = 33)                                         ! Record of tx sample interval in us
      parameter (ITDELPTR = 34)                                         ! Record of tx time delay in ms.
!
!..Constants for SEGY Format (IFMTPTR)
      integer IBMFP, INT16, INT32, HOSTFP
      parameter (IBMFP  = 1)                                            ! IBM floating point
      parameter (INT32  = 2)
      parameter (INT16  = 3)
      parameter (HOSTFP = 5)                                            ! Host FP. In actuality Host FP >= 5
!
!.. Data Domains/Types (IDTYPPTR)
      integer    IDTX, IDFKRCT, IDFKPLR, IDFKPLRU
      parameter (IDTX     = 1)
      parameter (IDFKRCT  = 2)
      parameter (IDFKPLR  = 3)
      parameter (IDFKPLRU = 8)
!
! TRACE HEADER
!.. Declare header length on external disk files. Internal length is given by
! Numhdr in common block READT.
      integer  CRAYTHDR, NORMTHDR
      parameter ( CRAYTHDR =  30)                                       ! Length of external disk image
      parameter ( NORMTHDR = 2*CRAYTHDR)
!
      common /SEGYPTR/ LLSEQPTR, LRSEQPTR, LSHOTPTR, LSHTRPTR, LRPNPTR,
     *                 LRPTRPTR, ITRIDPTR, LDISTPTR, LWBDPTR,  LSXCOPTR,
     *                 LRXCOPTR, IDELMPTR, ISTMPTR,  IENDMPTR, ISAMPPTR,
     *                 ISIPTR,   IYRPTR,   IDAYPTR,  IHRPTR,   IMINPTR,
     *                 ISECPTR,  IGMTPTR,  LDELSPTR, LSMUSPTR, LEMUSPTR,
     *                 LSISPTR,  LWBTSPTR, LGATPTR,  LSSMSPTR, LESMSPTR,
     *                 LSBPTR
!
!.. Define Constants for Trace Header
!
!.. Constants for Trace ID (ITRIDPTR)
      integer    LIVETR, DEADTR                                         ! Parameters for trace Type
      parameter (LIVETR  = 1)
      parameter (DEADTR  = 2)
!
!.. Define constants for use with the DISKIO subroutines getfil, frefil,
! podisc
! GETFIL constants
      integer    CREATTMP, CREATNEW
      parameter (CREATTMP   = 1)                                        ! Create a temporary file
      parameter (CREATNEW   = 3)                                        ! Create a new named file
! FREFIL constants
      integer    RLDLCLS
      parameter (RLDLCLS = 3)
! PODISC constants
      integer    POSABS, POSREL, DSKSTRT
      parameter (POSABS     = 1)
      parameter (POSREL     = 2)
      parameter (DSKSTRT    = 0)                                        ! The starting position on the disk
! fkfilt.inc
! Include file for the FK filter routines FKFIED & FKFIEX
!
      integer    NSETSP, DBLSETSP
      parameter (NSETSP = 20 )                                          ! The max. no. of FKFIED input values
      parameter (DBLSETSP  = 2*NSETSP)
!
      integer    SINGPARM                                               ! The number of single valued params
      parameter( SINGPARM = 6)
!
      integer     FILNOTST , FILTERR, FILTVEL, FILTDIP
      parameter ( FILNOTST  = -8)                                       ! Declare constants for the filter types
      parameter ( FILTERR   = -7)
      parameter ( FILTVEL   =  1)
      parameter ( FILTDIP   =  2)
!
      integer    CUT, PASS, ATINF
      parameter (CUT = 2, PASS = 1)
      parameter ( ATINF = 2)                                            ! Constant signifying lines near v = inf
!
      Integer PCdir, CPdir, PCinf, CPinf
      Parameter (PCdir =  Cut - Pass)
      Parameter (CPdir = Pass - Cut)
      Parameter (PCinf = AtInf * PCdir)
      Parameter (CPinf = AtInf * CPdir)
!
      Integer INITWDW
      Parameter (INITWDW = 32)
      Parameter (NOINIT  = 0)
!
!..                         Declare constants for the available window types
      integer     NUMWINDT
      parameter (NUMWINDT = 8)                                          ! The number of available window types
      Integer Hamming, Hanning, Gaussian, Bartlett, Rectang
      Integer Blackman, ExctBlck, BlckHarr
      Parameter (Hamming  = 1)
      Parameter (Hanning  = 2)
      Parameter (Gaussian = 3)
      Parameter (Bartlett = 4)                                          ! Triangular Window
      Parameter (RectAng  = 5)
      Parameter (BlackMan = 6)
      Parameter (ExctBlck = 7)                                          ! Exact Blackman
      Parameter (BlckHarr = 8)
!
!..                              Parameters for the window options
      Integer    NUMWOPT
      parameter (NUMWOPT = 3)                                           ! The number of windowing options
      Integer  BYA, BYK, BYW
      Parameter (ByA = 1)
      Parameter (ByK = 2)
      Parameter (ByW = 3)
! PROGRAM
!
      dimension buf(111),scr(111),lscr(111)
      integer*2 ibuf(111), iscr(111)
      complex   cbuf(111)
!
      common /FKFILT/ munit, nlists, kTrace
      common /SIOAP/ iasgnd,irelse,in,iout,nextad,lapsiz,ifree,iuseap
      common /APMEM/ ap(SZAPMEM)
      common /READT/lun,numhdr,numdat,iunhdr,ireeln,intrcs,ifmt,nskip,
     *               secs,lrenum,isrcf,idtype,
     *               nfskip, jform, itxsi, itxdel, nfktrc
!
      real    vLine(DBLSETSP + 2)
      integer vType(DBLSETSP + 2), wPt(DBLSETSP + 2)
      integer FiltTyp, wBase, Offs
      integer BasAddr0, BasAddr1
      integer Taper
      logical first, Found
!
      save
!
      data first/.TRUE./, kTrace/-1/
!
      if (first) then
          first = .FALSE.
          if ( (idtype.ne.IDFKRCT).AND.(idtype.ne.IDFKPLR).AND.
     *        (idtype.ne.IDFKPLRU) ) then
             print *,' ***  FKFILT ERROR  ***  The input must be ',
     *               ' in the FK domain.'
              STOP
          endif
!
          call podisc( munit, POSABS, DSKSTRT)                          ! Get single parameters
          call rddisc( munit, scr, SINGPARM, istat )
!
          dx      = scr(1)                                              ! trace spacing
          iwindo  = lscr(2)                                             ! type of window function
          lprint  = lscr(3)                                             ! debug print option
          iwopt   = lscr(4)                                             ! manner in which to apply window
          FiltTyp = lscr(5)                                             ! Type of filter
          nLine   = lscr(6)                                             ! Number of filter lines
!
!         call podisc( iunhdr, POSABS, NORMEBC+DSKSTRT )
!         call rddisc( iunhdr, scr, NORMBIN, istat )                    ! read Binary Header
          nk     = 2*nfktrc - 1                                         ! The no. of wavenumbers
          dt     = itxsi / 1.0E6                                        ! Sample interval in secs
          if (IAND(lprint,2).ne.0) then
            print *,'FKFIEX Initialization info'
            print *,'dx: ', dx,' nk: ', nk,' dt: ', dt
            print *,'No. of Filter Lines (nLine): ', nLine
          endif
!
!..                                   Calculate the constants
!          nsamps = ibuf(ISAMPPTR)                                       ! The no. of 4 byte samples
          nsamps = numdat
!          nw     = ibuf(ISAMPPTR) / 2                                   ! The no. of frequencies
          nw = numdat / 2
          wBase  = nw / 2 + 1                                           ! The 0 frequency position
          If (FiltTyp.eq.FILTDIP) dx = 0.001                            ! Includes allowance for mS.
          vnorm  = float(nk) * dx / dt / float(nw)                      ! Non dimensioning velocity
          pnorm  = 1. / vnorm
          vinfp  = float(nw)                                            ! Velocity  ~ Inf
          vzerop = 1./ float(nk)                                        ! Velocity  = 0+
!
          BasAddr0  = DBLSETSP + 1                                      ! Set base address in scr for type info
          BasAddr1  = BasAddr0 + 1
!
          call rddisc( munit, scr, DBLSETSP, istat )                    ! Read in filter lines
          call rddisc( munit, lscr(BasAddr1), DBLSETSP, istat )         ! & cut/pass
!
          found   = .False.                                             ! Look for filter lines stradling zero
          i       = 1
  5       continue
            i     = i + 1
            if ((scr(i) * scr(i-1) ) .le. 0.) then
              found = .true.
              izm   = i - 1                                             ! Index of  last line <  0
              izp   = i                                                 ! Index of first line >= 0
            endif
          if ( (.not.Found).AND.(i.lt.nLine) ) go to 5
!
          if (.not.Found) then                                          ! Filter Line do not straddle zero
            if(scr(1).lt.0.) then
              izm = nLine                                               ! -ve Lines only
              izp = nLine + 1
              lscr(BasAddr0+izp) = lscr(BasAddr0+1)
            else                                                        ! +ve Lines only
              izm = 0
              izp = 1
              lscr(BasAddr0+izm) = lscr(BasAddr0+nline)
            endif
          endif
!...            *** Input lines were defined as dips : Convert to velocities ***
          If (FiltTyp.eq.FILTDIP) then
            j          = izp
            do 10 i = 1, izm                                            ! Convert -ve Dips
              j        = j - 1                                          ! Reverse index to preserve ordering
              vLine(j) = pnorm / scr(i)
              vType(j) = lscr(BasAddr0 + i)
  10        continue
!
!..                 Filter lines differ across v = 0 so add lines at v = 0+ & 0-
            if ( lscr(BasAddr0+1).ne.lscr(BasAddr0+nLine) ) then
              vLine(izm+1) = -vzerop
              vLine(izm+2) =  vzerop
              vType(izm+1) = lscr(BasAddr0 + 1)
              vType(izm+2) = lscr(BasAddr0 + nLine)
              ntop         = nLine + 2
              izm          = izm   + 2
            else
              ntop         = nLine
            endif
!
            if ( Found .AND. (scr(izp).eq.0.) ) then                    ! A line at zero dip ?
              vLine(izm+1) = vInfp                                      ! Convert to inf. velocity
            else
              vLine(izm+1) = pnorm/scr(nLine)
            endif
            vType(izm+1) = lscr(BasAddr0 + nLine)
!
            j = nTop + 1                                                ! Convert +ve dips to velocity
            do 20 i = izp, nLine-1
              j        = j - 1
              vLine(j) = pnorm / scr(i)
              vType(j) = lscr(BasAddr0 + i)
  20        continue
!
            nLine        = nTop
!....                                ***  Filter lines are given as velocity ***
          else if (FiltTyp.eq.FILTVEL) then
!
            do 25 i = 1, izm                                            ! Normalize -ve velocities
              vLine(i) = pnorm * scr(i)
              vType(i) = lscr(BasAddr0 + i)
  25        continue
!..
            Offs = 0
            izpp = izp + 1
            if ( Found.and.(scr(izp).eq.0.) ) then                      ! Line at v = 0
              vLine(izp)  = -vzerop                                     ! Split into 0+ & 0- lines
              vLine(izpp) =  vzerop
              vType(izp)  = lscr(BasAddr0 + izp)
              vType(izpp) = lscr(BasAddr0 + izp)
              izp         = izpp                                        ! Adjust to first v > 0
              Offs        = 1                                           ! Added a line
!
!...                                            Line types differ across v = 0.
            else if ( lscr(BasAddr0+izm).ne.lscr(BasAddr0+izp) ) then
              vLine(izp)  = -vzerop
              vLine(izpp) =  vzerop                                     ! Add lines at v = 0+ & 0-
              vType(izp)  = lscr(BasAddr0 + izm)
              vType(izpp) = lscr(BasAddr0 + izp)
              Offs        = 2
            endif
!
            do 30 i = izp, nLine                                        ! Normalize +ve velocities
              vLine(i + Offs) = pnorm * scr(i)
              vType(i + Offs) = lscr(BasAddr0 + i)
 30         continue
!
            nLine = nLine + Offs                                        ! Allow for added lines
          endif                                                         ! of if FiltTyp =
          if (IAND(lprint,2).ne.0) then
            print '(/A)','FKFIEX : Normalized Velocities'
            print *,'Adjusted No. of Filter Lines (nLine): ', nLine
            do 40 i = 1, nLine
              if (vType(i).eq.CUT) then
                print *,' Cut Velocity : ', Vline(i)
              else if (vType(i).eq.PASS) then
                print *,'Pass Velocity : ', Vline(i)
              else
                print *,'     Velocity : ', Vline(i),' Type : ',vType(i)
              endif
  40        continue
          endif
      Endif                                                             ! of if First
!
!*************************                             *************************
!*                      Start of the Main Filtering loop
!*************************                             *************************
!
      call inap( buf(numhdr+1), nsamps )                                ! Put the data in the AP
      BasAddr0            = NextAd - 1                                  ! Base address in the AP for window
      BasAddr1            = NextAd
      ap(BasAddr0 + wbase) = 0.                                         ! Zero frequency
      kTrace              = kTrace + 1                                  ! Current wavenumber (k)
!
!***                                *** Generate a Window function for trace ***
!
      If (kTrace.eq.0) then                                             ! This is the Zero wavenumber Trace
        wPt(1)     = wbase - 1
        wPt(nLine) = wbase
      else                                                              ! Wavenumber <> 0
        call ClcWpt(0, wPt, kTrace, vLine, nLine, nw)
!..                                     Position of Line Intercepts on the trace
        iprev = wPt(1)
        i     = 1
!
  120   If ( (iprev.lt.nw).AND.(i.lt.nLine) ) then
          i = i + 1
          if (wPt(i).gt.iprev) then                                     ! Gaps between lines
            if (vType(i).eq.vType(i-1))then                             ! Simple pass/cut sector
              If (vType(i).eq.CUT ) then
                 val = 0.0
              else                                                      ! if pass then
                 val = 1.0
              endif
              do jj = iprev + 1, wPt(i)
  130           ap(BasAddr0 + jj) = val
              enddo
            else                                                        ! Taper at ends of pass/cut
              Taper = vType(i) - vType(i-1)                             ! Pass -> Cut or Cut -> Pass ?
              IF( vLine(i)*vLine(i-1) .GE. 0 ) call FrmWnd
     *         ( iwindo, iwopt, vLine(i-1), vLine(i), kTrace,
     *         iprev+1-wbase, wPt(i)-wbase, ap(BasAddr1 + iprev), Taper)
!
            endif                                                       ! of vType(i) <> vType(i-1)
          endif                                                         ! of Gaps between lines
          iprev = wpt(i)
          go to 120
        endif                                                           ! of iprev < nw & i < nLine
      endif                                                             ! of Wavenumber <> 0
!
!...                                Check the form of the sector across v = inf
      if (vType(1).eq.vType(nLine)) then                                ! Simple pass/cut sector
          if (vType(1).eq.CUT ) then
            val = 0.0
          else                                                          ! if pass
            val = 1.0
          endif
          do jj = 1, wPt(1)
 150        ap(BasAddr0 + jj) = val
          enddo
          do jj = wPt(nLine)+1, nw
 160        ap(BasAddr0 + jj) = val
          enddo
      else                                                              ! Else tapering at v(inf)
        Taper = ATINF * (vType(1) - vType(nLine))
!..                                                  Taper large -ve velocities
        call FrmWnd(iwindo, iwopt, vLine(1), vLine(nLine), kTrace,
     *                1 - wbase, wPt(1) - wbase, ap(BasAddr1), Taper)
!..                                                  Taper large +ve velocities
        call FrmWnd(iwindo, iwopt, vLine(1), vLine(nLine), kTrace,
     *                  wPt(nLine)+1-wbase, nw-wbase,
     *                  ap(BasAddr1 + wPt(nline)), Taper)
      endif
!
!*************************                             *************************
!                       Multiply Trace by its Window Fn
!*************************                             *************************
!
      If ( (idtype.eq.IDFKPLR).OR.idtype.eq.IDFKPLRU ) then
        do i = 1, nw
 200       ap(i) = ap(i) * ap(BasAddr0 + i)
        enddo
      else if (idtype.eq.IDFKRCT) then
        j = -1
        do 210 i = BasAddr0 + 1, BasAddr0 + nw
          j       = j + 2
          ap(j)   = ap(j)   * ap(i)
          ap(j+1) = ap(j+1) * ap(i)
 210    continue
      endif
!
      iout = CLEARAP                                                    ! Get the modified trace out of the Ap
      call rlseap( buf(NumHdr+1), nsamps)
      RETURN
      end
!++
!++
      Subroutine ClcWpt(type, wPt, k, v, nLine, nw)
!------------------------------------------------------------------------------
!    ClcWpt calculates the positions at which the filtering lines cross the
! current trace. These positions are returned as indices of the input trace in
! the integer array wPt. The indices are chosen to be the nearest index below
! the actual crossing line.
!
! Inputs:
!   type      This is an index denoting the form of the filtering lines.
!             Currently ignored as all lines are currently are radial lines
!             from the origin.
!   k         The input wavenumber trace k E [0,nk/2]
!   v(nLine)  The array of normalized velocities for the filter lines
!   nLine     The number of filter lines.
!   nw        The length of the input trace. Frequencies are assumed to run
!             -Nyq -> 0 -> +Nyq - dw
! Outputs:
!    wpt(nLine)  The array of returned indices
!
! Call Chain:
!    CONTRO:FKFIEX:ClcWpt
!
! Externals:
!    IBLW
!
! Last Modified:
!    10/6/88 ajh
!
!------------------------------------------------------------------------------
!
      integer type
      integer k, nw
      integer nLine
      integer wpt(nLine)
      real      v(nLine)
!
      integer wbase, iblw
!
      wbase = nw/2 + 1                                                  ! Position of the zero frequency sample
      do 10 i = 1, nLine
        wpt(i)   = iBlw(v(i) * k) + wbase                               ! Calculate crossing position
        if(wPt(i).lt.0) then                                            ! Make sure wpt in [0,nw]
          wPt(i) = 0
        else if (wPt(i).gt.nw) then
          wPt(i) = nw
        endif
  10  continue
      RETURN
      end
!**
!**
      Integer Function Iblw(x)
!-------------------------------------------------------------------------------
! Iblw returns the nearest integer below a real value x. Not the integer part.
!-------------------------------------------------------------------------------
!
      real x
!
      if(x.ge.0.) then
        Iblw = Int(x)
      else
        Iblw = Int(x) - 1
      endif
      RETURN
      end
!++
!++
      Subroutine FrmWnd(iwindo,iwopt,vst,vend,k,stPt,endPt,buf,dir)
!-------------------------------------------------------------------------------
!   FrmWnd calculates the half window function between vst & vend for the
! points stPt to endPt. vst & vend are real so the window does not necessarily
! start & finish on integer values.
!
! Inputs:
!   iwindo Type of window function
!   iwopt  Variable for windowing
!          = BYA - Window as a function of angle
!          = BYW - Window as a function of frequency
!          = BYK - Window as a function of wavenumber
!
!   vst    Start velocity of filter
!   vend   Final velocity of filter
!    stPt  First point in window
!   EndPt  Last point in window
!
!    dir  Direction of the windowing function
!         = PCDIR - The window is from pass at vst to cut vend
!         = CPDIR - The window is from cut at vst to pass vend
!         = PCINF - The velocity lines straddle v infinity +ve v is pass
!         = CPINF - "       "       "       "       "      +ve v is cut
!
! Outputs:
!   buf(stPt:EndPt)                                                     ! buffer in which to place window fn
!
! Call Chain:
!    CONTRO:FKFIEX:FrmWnd
!
! Externals:
!    Fwindw
!
! Last Modified:
!    10/6/88 ajh
!-------------------------------------------------------------------------------
!
! INCLUDE FILES
! fkfilt.inc
! Include file for the FK filter routines FKFIED & FKFIEX
!
      integer    NSETSP, DBLSETSP
      parameter (NSETSP = 20 )                                          ! The max. no. of FKFIED input values
      parameter (DBLSETSP  = 2*NSETSP)
!
      integer    SINGPARM                                               ! The number of single valued params
      parameter( SINGPARM = 6)
!
      integer     FILNOTST , FILTERR, FILTVEL, FILTDIP
      parameter ( FILNOTST  = -8)                                       ! Declare constants for the filter types
      parameter ( FILTERR   = -7)
      parameter ( FILTVEL   =  1)
      parameter ( FILTDIP   =  2)
!
      integer    CUT, PASS, ATINF
      parameter (CUT = 2, PASS = 1)
      parameter ( ATINF = 2)                                            ! Constant signifying lines near v = inf
!
      Integer PCdir, CPdir, PCinf, CPinf
      Parameter (PCdir =  Cut - Pass)
      Parameter (CPdir = Pass - Cut)
      Parameter (PCinf = AtInf * PCdir)
      Parameter (CPinf = AtInf * CPdir)
!
      Integer INITWDW
      Parameter (INITWDW = 32)
      Parameter (NOINIT  = 0)
!
!..                         Declare constants for the available window types
      integer     NUMWINDT
      parameter (NUMWINDT = 8)                                          ! The number of available window types
      Integer Hamming, Hanning, Gaussian, Bartlett, Rectang
      Integer Blackman, ExctBlck, BlckHarr
      Parameter (Hamming  = 1)
      Parameter (Hanning  = 2)
      Parameter (Gaussian = 3)
      Parameter (Bartlett = 4)                                          ! Triangular Window
      Parameter (RectAng  = 5)
      Parameter (BlackMan = 6)
      Parameter (ExctBlck = 7)                                          ! Exact Blackman
      Parameter (BlckHarr = 8)
!
!..                              Parameters for the window options
      Integer    NUMWOPT
      parameter (NUMWOPT = 3)                                           ! The number of windowing options
      Integer  BYA, BYK, BYW
      Parameter (ByA = 1)
      Parameter (ByK = 2)
      Parameter (ByW = 3)
! PROGRAM
!
      integer iwindo, iwopt
      real    vst, vend
      integer stPt, EndPt
      real    buf(stPt:EndPt)
      integer dir
!
      parameter (DUMV = 0.)
!
      integer DirLcl
      real    Fwindw
!
      if (endPt.lt.StPt) then
        print *, '*** FKFIEX (FrmWnd) ERROR *** ',
     *           ' FrmWnd stPt > Endpt', StPt,endPt
        STOP
      endif
!
      rk = float(k)                                                     ! Convert wavenumber to real
!
      if ((dir.eq.PCDIR).OR.(dir.eq.CPDIR)) then                        !.... Simple window
        if (iwopt.eq.BYA) then
            buf(StPt) = Fwindw(ATan(stPt/rk), ATan(vst), ATan(vend),
     *                          iwindo, dir, INITWDW )
!
        do i = StPt, EndPt
  10      buf(i) = Fwindw(ATan(i/rk), Dumv, Dumv, iwindo,dir, NOINIT)
        enddo
        else if (iwopt.eq.BYW) then
          buf(StPt) = Fwindw(float(StPt), rk*vst, rk*vend, iwindo,
     *                                                  dir, INITWDW )
          do i = StPt, EndPt
  20        buf(i) = Fwindw(float(i), Dumv, Dumv, iwindo, dir, NOINIT)
        enddo
        else if (iwopt.eq.BYK) then
          do i = StPt, EndPt
  30        buf(i) = Fwindw( rk, i/vst, i/vend, iwindo, dir, INITWDW )
          enddo
        endif
!
      else                                                              !........ Filter lines across vinf
        if(dir.eq.PCINF) then
          dirLcl = PCDIR
        else
          dirLcl = CPDIR
        endif
!
        if (iwopt.eq.BYW) then
           print *,'**** FKFILT(FrmWnd) Warning *** ',
     *                'Cannot window as a fn. of w across v = inf'
           print *, 'Using Angle (BYA) instead'
        endif
!
        if (iwopt.eq.BYA .OR. iwopt.eq.BYW) then
           buf(StPt) = Fwindw(ATan(rk/stPt), ATan(1./vst),
     *                         ATan(1./vend), iwindo, dirLcl,INITWDW)
             do i = StPt, EndPt
 110         buf(i) = Fwindw(ATan(rk/i), DumV, DumV, iwindo,
     *                                                dirLcl, NOINIT)
             enddo
        else if (iwopt.eq.BYK) then
          do i = StPt, EndPt
 120       buf(i) = Fwindw(rk, i/vst, i/vend, iwindo, dirLcl,INITWDW)
          enddo
        endif
      endif                                                             ! of (dir == PCDIR) | (dir == CPDIR)
      RETURN
      end
!++
!++
      Real Function Fwindw(theta, start, end, iwindo, dir, init)
!------------------------------------------------------------------------------
!   Fwindw returns the value of a window function . The windows supported
! are the standard SIOSEIS ones.
!
! Inputs:
!   theta  Value within the window. Within Fwindw it is normalized to [0,1] wrt
!          the total range of the window |end - start|
!          = 0  => complete pass
!          = 1  => cut off end of window
!
!   start  Start value of window. Used only on Initialization
!   end    End   value of window.  "    "    "    "    "    "
!   iwindo The type of window to be applied
!   dir    Direction of windowing
!          = PCDIR - The window is from pass to cut
!          = CPDIR - The window is from cut to pass
!
! Last Modified:
!   10/6/88 ajh.
!------------------------------------------------------------------------------
!
      real    theta
      real    start, end
      integer iwindo
      integer dir
!
      Parameter ( PI    = 3.1415927)
      Parameter ( TWOPI = 2. * PI)
      Parameter ( BETA  = 0.5)                                          ! Width constant for Gaussian window
!
      integer    DirLcl
!
      save thetaSt, thetaEnd, Range, b2
!
! INCLUDE FILES
! fkfilt.inc
! Include file for the FK filter routines FKFIED & FKFIEX
!
      integer    NSETSP, DBLSETSP
      parameter (NSETSP = 20 )                                          ! The max. no. of FKFIED input values
      parameter (DBLSETSP  = 2*NSETSP)
!
      integer    SINGPARM                                               ! The number of single valued params
      parameter( SINGPARM = 6)
!
      integer     FILNOTST , FILTERR, FILTVEL, FILTDIP
      parameter ( FILNOTST  = -8)                                       ! Declare constants for the filter types
      parameter ( FILTERR   = -7)
      parameter ( FILTVEL   =  1)
      parameter ( FILTDIP   =  2)
!
      integer    CUT, PASS, ATINF
      parameter (CUT = 2, PASS = 1)
      parameter ( ATINF = 2)                                            ! Constant signifying lines near v = inf
!
      Integer PCdir, CPdir, PCinf, CPinf
      Parameter (PCdir =  Cut - Pass)
      Parameter (CPdir = Pass - Cut)
      Parameter (PCinf = AtInf * PCdir)
      Parameter (CPinf = AtInf * CPdir)
!
      Integer INITWDW
      Parameter (INITWDW = 32)
      Parameter (NOINIT  = 0)
!
!..                         Declare constants for the available window types
      integer     NUMWINDT
      parameter (NUMWINDT = 8)                                          ! The number of available window types
      Integer Hamming, Hanning, Gaussian, Bartlett, Rectang
      Integer Blackman, ExctBlck, BlckHarr
      Parameter (Hamming  = 1)
      Parameter (Hanning  = 2)
      Parameter (Gaussian = 3)
      Parameter (Bartlett = 4)                                          ! Triangular Window
      Parameter (RectAng  = 5)
      Parameter (BlackMan = 6)
      Parameter (ExctBlck = 7)                                          ! Exact Blackman
      Parameter (BlckHarr = 8)
!
!..                              Parameters for the window options
      Integer    NUMWOPT
      parameter (NUMWOPT = 3)                                           ! The number of windowing options
      Integer  BYA, BYK, BYW
      Parameter (ByA = 1)
      Parameter (ByK = 2)
      Parameter (ByW = 3)
! PROGRAM
!
!...                                Initialize the window variables
      DirLcl = dir
!
      if ( init.eq.INITWDW ) then                                       ! Test for INIT bit
!****  pcdir =1, cpdir = -1
        if (DirLcl.eq.PCDIR) then
          thetaSt  = start
          thetaEnd = end
        else if (DirLcl.eq.CPDIR) then
          thetaSt  = end
          thetaEnd = start
        else
          stop '*** Error *** Fwindw incorrect direction specified'
        endif
!
        range = thetaEnd - thetaSt
        if (iwindo.eq.GAUSSIAN)
     *         b2 = 2 * BETA * BETA
      endif
!
      thetaN = (theta - thetaSt) / range                                ! Normalize theta to [0,1]
!
      if ( thetaN .lt.0.) then
        print '(A,G12.3)',
     *        '*** Fwindw Warning *** Normalized theta < 0 ', ThetaN
        thetaN = 0.
      else if (thetaN.gt.1.) then
        print '(A,G12.3)',
     *        '*** Fwindw Warning  *** Normalized theta > 1 ', ThetaN
        thetaN = 1.
      endif
!
      if (iwindo.eq.HAMMING) then
         Fwindw = 0.54 + 0.46 * Cos(PI * thetaN)
      else if (iwindo.eq.HANNING) then
         Fwindw = 0.5 + 0.5 * Cos(PI * thetaN)
      else if (iwindo.eq.GAUSSIAN) then
         Fwindw = Exp( -thetaN*b2)
      else if (iwindo.eq.BARTLETT) then
         Fwindw = 1. - ThetaN
      else if (iwindo.eq.RECTANG) then
         Fwindw = 1.
      else if (iwindo.eq.BLACKMAN) then
         Temp = PI * ThetaN
         Fwindw = 0.42 + 0.5 * Cos(temp) + 0.08 * Cos( 2 * temp)
      else if (iwindo.eq.EXCTBLCK) then
         Temp = PI * ThetaN
         Fwindw = 0.42659071 + 0.49656062 * Cos(temp) +
     *             0.07684867 * Cos( 2 * temp)
      else if (iwindo.eq.BLCKHARR) then
         Temp = PI * ThetaN
         Fwindw = 0.35875 + 0.48829 * Cos(temp) +
     *             0.14128 * Cos( 2 * temp) + 0.01168 * Cos(3 * temp)
      endif
!
      RETURN
      end