module type_mesh
#include <messenger.h>
    use mod_kinds,                  only: rk,ik
    use mod_constants,              only: NO_ID, INTERIOR, NFACES, CARTESIAN, CYLINDRICAL
    use type_element,               only: element_t
    use type_domain,                only: domain_t
    use type_domain_connectivity,   only: domain_connectivity_t
    use type_boundary_connectivity, only: boundary_connectivity_t
    use type_bc_patch,              only: bc_patch_t
    use type_bc_patch_group,        only: bc_patch_group_t
    use type_ivector,               only: ivector_t
    use type_mpi_request_vector,    only: mpi_request_vector_t
    use mpi_f08,                    only: mpi_isend, mpi_recv, mpi_integer4, mpi_real8, &
                                          mpi_waitall, mpi_request, mpi_status_ignore,  &
                                          mpi_statuses_ignore, mpi_character
    implicit none
    private

    !> Data type for mesh information
    !!      - contains array of elements, array of faces for each element
    !!      - calls initialization procedure for elements and faces
    !!
    !!  @author Nathan A. Wukie
    !!  @date   4/6/2017
    !!
    !!
    !----------------------------------------------------------------------------------
    type, public :: mesh_t

        integer(ik)                         :: ntime_

        ! Local data
        type(domain_t),         allocatable :: domain(:)
        type(bc_patch_group_t), allocatable :: bc_patch_group(:)

        ! Parallel data
        type(element_t),        allocatable :: parallel_element(:)
        type(mpi_request_vector_t)          :: comm_requests

    contains

        ! Domain procedures
        procedure           :: add_domain
        procedure           :: get_domain_id
        procedure, private  :: new_domain
        procedure           :: ndomains

        ! Boundary patch group procedures
        procedure, private  :: new_bc_patch_group
        procedure           :: get_bc_patch_group_id
        procedure           :: nbc_patch_groups
        procedure           :: add_bc_patch

        ! Chimera
        procedure           :: assemble_chimera_data

        ! Resouce management
        procedure           :: release

        ! Parallel communication pattern
        procedure           :: get_recv_procs
        procedure           :: get_send_procs

        procedure           :: get_proc_ninterior_neighbors
        procedure           :: get_proc_nchimera_donors
        !procedure           :: get_proc_nchimera_receivers
        procedure           :: get_nelements_recv

        procedure           :: find_parallel_element
        procedure           :: new_parallel_element
        procedure           :: nparallel_elements

        ! Extra routines for testing private procedures
        procedure           :: stub_new_domain

        ! Communication
        procedure           :: comm_send
        procedure           :: comm_recv
        procedure           :: comm_wait

    end type mesh_t
    !**********************************************************************************

contains

    !>  Add a domain to the mesh.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   4/4/2017
    !!
    !!
    !----------------------------------------------------------------------------------
    subroutine add_domain(self, name, nodes, dnodes, vnodes, connectivity, nelements_g, coord_system, eqn_ID)
        class(mesh_t),                  intent(inout)   :: self
        character(*),                   intent(in)      :: name
        real(rk),                       intent(in)      :: nodes(:,:)
        real(rk),                       intent(in)      :: dnodes(:,:)
        real(rk),                       intent(in)      :: vnodes(:,:)
        type(domain_connectivity_t),    intent(in)      :: connectivity
        integer(ik),                    intent(in)      :: nelements_g
        character(*),                   intent(in)      :: coord_system
        integer(ik),                    intent(in)      :: eqn_ID

        integer(ik) :: idomain_l

        !
        ! Create new domain, initialize
        !
        idomain_l = self%new_domain()
        self%domain(idomain_l)%name = trim(name)

        !
        ! Initialize reference domain
        !
        call self%domain(idomain_l)%init_geom(idomain_l,    &
                                              nelements_g,  &
                                              nodes,        &
                                              connectivity, &
                                              coord_system )

        !
        ! Initialize ALE
        !
        call self%domain(idomain_l)%set_displacements_velocities(dnodes,vnodes)

        !
        ! Set equation set identifier
        !
        call self%domain(idomain_l)%init_eqn(eqn_ID)

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

    !>  Extend domain storage by one and return the domain identifier of the newly
    !!  allocated domain.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   4/4/2017
    !!
    !!
    !-----------------------------------------------------------------------------------
    function new_domain(self) result(idomain_l)
        class(mesh_t),  intent(inout)   :: self

        integer(ik)                 :: idomain_l, ierr
        type(domain_t), allocatable :: temp_domains(:)

        !
        ! Resize array storage
        !
        allocate(temp_domains(self%ndomains() + 1), stat=ierr)

        ! Copy previously initialized instances to new array. Be careful about pointers
        ! components here. For example, a pointer from a face to an element would no
        ! longer be valid in the new array.
        if (self%ndomains() > 0) then
            temp_domains(1:size(self%domain)) = self%domain(1:size(self%domain))
        end if

        !
        ! Move resized temp allocation back to mesh container.
        ! Be careful about pointer components here! Their location in memory has changed.
        !
        call move_alloc(temp_domains,self%domain)

        !
        ! Set domain identifier of newly allocated domain that will be returned
        !
        idomain_l = self%ndomains()

    end function new_domain
    !*********************************************************************************

    !>  Return the number of domains in the chidg_data_t instance.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/1/2016
    !!
    !!
    !--------------------------------------------------------------------------------
    function ndomains(self) result(ndomains_)
        class(mesh_t),  intent(in)      :: self

        integer :: ndomains_

        if (allocated(self%domain)) then
            ndomains_ = size(self%domain)
        else
            ndomains_ = 0
        end if

    end function ndomains
    !********************************************************************************

    !>  Given a domain name, return the domain identifier so that it can be
    !!  indexed in self%domains(:).
    !!
    !!  @author Nathan A. Wukie
    !!  @date   4/6/2017
    !!
    !!
    !--------------------------------------------------------------------------------
    function get_domain_id(self,domain_name) result(domain_index)
        class(mesh_t),  intent(in)  :: self
        character(*),   intent(in)  :: domain_name

        character(:),   allocatable :: user_msg
        integer(ik)  :: idom
        integer(ik)  :: domain_index

        domain_index = 0

        do idom = 1,self%ndomains()
            if ( trim(domain_name) == trim(self%domain(idom)%name) ) then
                domain_index = idom
                exit
            end if
        end do

        user_msg = "mesh%get_domain_index: No domain was found with a name &
                    matching the incoming string"
        if (domain_index == 0) call chidg_signal_one(FATAL,user_msg,domain_name)

    end function get_domain_id
    !********************************************************************************

    !>  Add a bc_patch to the specified group.
    !!
    !!  Notes:
    !!      - the bc_patch_group will always be created here
    !!      - the bc_patch may or may not get created. It depends on if the current
    !!        processor contains geometry associated with the boundary patch. If
    !!        geometry is found on the local processor, the patch will be created.
    !!        If geometry is not found, the patch will not be created.
    !!
    !!
    !!  @param[in]  domain_name     Name of the domain associated with the patch
    !!  @param[in]  group_name      Name of the boundary condition group
    !!  @param[in]  bc_connectivity Boundary condition face connectivity to initialize
    !!  @param[in]  bc_ID           Identifier for the associated bc_state_group
    !!
    !!
    !!  @author Nathan A. Wukie
    !!  @date   4/6/2017
    !!
    !!
    !--------------------------------------------------------------------------------
    subroutine add_bc_patch(self,domain_name, group_name, patch_name, bc_connectivity, bc_ID)
        class(mesh_t),                  intent(inout)   :: self
        character(*),                   intent(in)      :: domain_name
        character(*),                   intent(in)      :: group_name
        character(*),                   intent(in)      :: patch_name
        type(boundary_connectivity_t),  intent(in)      :: bc_connectivity
        integer(ik),                    intent(in)      :: bc_ID

        integer(ik) :: group_ID, idomain

        !
        ! Add new group, if not already in existence
        !
        group_ID = self%get_bc_patch_group_id(group_name)
        if (group_ID == NO_ID) then
            group_ID = self%new_bc_patch_group()
            self%bc_patch_group(group_ID)%name     = trim(group_name)
            self%bc_patch_group(group_ID)%group_ID = group_ID
        end if

        !
        ! Find domain identifier
        !
        idomain = self%get_domain_id(domain_name)

        !
        ! Add bc_patch
        !
        call self%bc_patch_group(group_ID)%add_bc_patch(self%domain(idomain), patch_name, bc_connectivity, bc_ID)

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

    !>  Extend the allocation of bc_patch_group's by one and return index of new
    !!  bc_patch_group object in self%bc_patch_group(:)
    !!
    !!  @author Nathan A. Wukie
    !!  @date   4/6/2017
    !!
    !---------------------------------------------------------------------------------
    function new_bc_patch_group(self) result(group_ID)
        class(mesh_t),  intent(inout)   :: self

        integer(ik)                         :: group_ID, ierr
        type(bc_patch_group_t), allocatable :: temp_groups(:)

        !
        ! Resize array storage
        !
        allocate(temp_groups(self%nbc_patch_groups() + 1), stat=ierr)

        ! Copy previously initialized instances to new array. Be careful about pointers
        ! components here. For example, a pointer from a face to an element would no
        ! longer be valid in the new array.
        if (self%nbc_patch_groups() > 0) then
            temp_groups(1:size(self%bc_patch_group)) = self%bc_patch_group(1:size(self%bc_patch_group))
        end if

        !
        ! Move resized temp allocation back to mesh container.
        ! Be careful about pointer components here! Their location in memory has changed.
        !
        call move_alloc(temp_groups,self%bc_patch_group)

        !
        ! Set domain identifier of newly allocated domain that will be returned
        !
        group_ID = self%nbc_patch_groups()

    end function new_bc_patch_group
    !*********************************************************************************

    !>  Return the number of bc_patch_group's on the mesh.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   4/6/2017
    !!
    !!
    !---------------------------------------------------------------------------------
    function nbc_patch_groups(self) result(n)
        class(mesh_t),  intent(in)  :: self

        integer(ik) :: n

        if (allocated(self%bc_patch_group)) then
            n = size(self%bc_patch_group)
        else
            n = 0
        end if

    end function nbc_patch_groups
    !*********************************************************************************

    !>  Given a patch group name, return its index on self%bc_patch_group(:).
    !!
    !!  If no group is found, return NO_ID.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   4/6/2017
    !!
    !!
    !--------------------------------------------------------------------------------
    function get_bc_patch_group_id(self,group_name_in) result(group_ID)
        class(mesh_t),  intent(in)  :: self
        character(*),   intent(in)  :: group_name_in

        integer(ik)                 :: igroup, group_ID
        character(:),   allocatable :: group_name
        logical                     :: found_group

        group_ID = NO_ID
        do igroup = 1,self%nbc_patch_groups()

            found_group = trim(group_name_in) == trim(self%bc_patch_group(igroup)%name)

            if (found_group) group_ID = igroup
            if (found_group) exit

        end do

    end function get_bc_patch_group_id
    !********************************************************************************

    !>
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   7/26/2017
    !!
    !!
    !--------------------------------------------------------------------------------
    subroutine assemble_chimera_data(self)
        class(mesh_t),  intent(inout)   :: self

        integer(ik)             :: idom, ChiID, idonor, donor_proc, npts, ipt,      &
                                   idomain_g, ielement_g, idomain_l, ielement_l,    &
                                   pelem_ID, igq
        real(rk),   allocatable :: ref_coords(:,:)
        real(rk)                :: ale_g_pt, ale_g_grad_pt(3), &
                                   ale_Dinv_pt(3,3), interp_coords_vel_pt(3), xi, eta, zeta
        logical                 :: parallel_donor

        !
        ! Construct receiver interpolations
        !
        !
        do idom = 1,self%ndomains()
           do ChiID = 1,self%domain(idom)%chimera%nreceivers()
              do idonor = 1,self%domain(idom)%chimera%recv(ChiID)%ndonors()

                  ! Get donor location
                  donor_proc = self%domain(idom)%chimera%recv(ChiID)%donor(idonor)%iproc
                  ref_coords = self%domain(idom)%chimera%recv(ChiID)%donor(idonor)%coords
                  npts = size(ref_coords,1)

                  parallel_donor = (donor_proc /= IRANK)

                  if (parallel_donor) then
                      idomain_g   = self%domain(idom)%chimera%recv(ChiID)%donor(idonor)%idomain_g
                      ielement_g  = self%domain(idom)%chimera%recv(ChiID)%donor(idonor)%ielement_g
                      pelem_ID    = self%find_parallel_element(idomain_g,ielement_g)
                      if (pelem_ID == NO_ID) call chidg_signal_three(FATAL,"mesh%assemble_chimera_data: did not find parallel chimera element.", IRANK, idomain_g, ielement_g)

                      do ipt = 1, npts
                          igq  = self%domain(idom)%chimera%recv(ChiID)%donor(idonor)%node_index(ipt)
                          xi   = ref_coords(ipt,1)
                          eta  = ref_coords(ipt,2)
                          zeta = ref_coords(ipt,3)
                          call self%parallel_element(pelem_ID)%ale_point(xi, eta, zeta,ale_g_pt,ale_g_grad_pt,ale_Dinv_pt,interp_coords_vel_pt)
                          self%domain(idom)%chimera%recv(ChiID)%ale_g(igq)               = ale_g_pt
                          self%domain(idom)%chimera%recv(ChiID)%ale_g_grad1(igq)         = ale_g_grad_pt(1)
                          self%domain(idom)%chimera%recv(ChiID)%ale_g_grad2(igq)         = ale_g_grad_pt(2)
                          self%domain(idom)%chimera%recv(ChiID)%ale_g_grad3(igq)         = ale_g_grad_pt(3)
                          self%domain(idom)%chimera%recv(ChiID)%ale_Dinv(:,:,igq)        = ale_Dinv_pt
                          self%domain(idom)%chimera%recv(ChiID)%interp_coords_vel(igq,:) = interp_coords_vel_pt
                      end do

                   else

                      idomain_l   = self%domain(idom)%chimera%recv(ChiID)%donor(idonor)%idomain_l
                      ielement_l  = self%domain(idom)%chimera%recv(ChiID)%donor(idonor)%ielement_l

                      do ipt = 1, npts
                          igq  = self%domain(idom)%chimera%recv(ChiID)%donor(idonor)%node_index(ipt)
                          xi   = ref_coords(ipt,1)
                          eta  = ref_coords(ipt,2)
                          zeta = ref_coords(ipt,3)
                          call self%domain(idomain_l)%elems(ielement_l)%ale_point(xi, eta, zeta,ale_g_pt,ale_g_grad_pt,ale_Dinv_pt,interp_coords_vel_pt)
                          self%domain(idom)%chimera%recv(ChiID)%ale_g(igq)               = ale_g_pt
                          self%domain(idom)%chimera%recv(ChiID)%ale_g_grad1(igq)         = ale_g_grad_pt(1)
                          self%domain(idom)%chimera%recv(ChiID)%ale_g_grad2(igq)         = ale_g_grad_pt(2)
                          self%domain(idom)%chimera%recv(ChiID)%ale_g_grad3(igq)         = ale_g_grad_pt(3)
                          self%domain(idom)%chimera%recv(ChiID)%ale_Dinv(:,:,igq)        = ale_Dinv_pt
                          self%domain(idom)%chimera%recv(ChiID)%interp_coords_vel(igq,:) = interp_coords_vel_pt
                      end do
                   end if

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

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

    !>  Release any allocated resource on the object.
    !!
    !!
    !!  @author Nathan A. Wukie
    !!  @date   4/5/2017
    !!
    !!
    !---------------------------------------------------------------------------------
    subroutine release(self)
        class(mesh_t),  intent(inout)   :: self

        if (allocated(self%domain)) deallocate(self%domain)

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

    !>  Return the MPI ranks that the current rank is receiving information from.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   4/10/2017
    !!
    !!
    !---------------------------------------------------------------------------------
    function get_recv_procs(self) result(recv_procs_array)
        class(mesh_t),  intent(in)  :: self

        integer(ik)                 :: idom, igroup, iproc
        integer(ik),    allocatable :: recv_procs_dom(:), recv_procs_bc(:), recv_procs_array(:)
        type(ivector_t)             :: recv_procs

        !
        ! Accumulate processor ranks that we are receiving from: domains
        !
        do idom = 1,self%ndomains()
            recv_procs_dom = self%domain(idom)%get_recv_procs()

            do iproc = 1,size(recv_procs_dom)
                call recv_procs%push_back_unique(recv_procs_dom(iproc))
            end do ! iproc

        end do ! idom

        !
        ! Accumulate processor ranks that we are receiving from: bc_patch_groups
        !
        do igroup = 1,self%nbc_patch_groups()
            recv_procs_bc = self%bc_patch_group(igroup)%get_recv_procs()

            do iproc = 1,size(recv_procs_bc)
                call recv_procs%push_back_unique(recv_procs_bc(iproc))
            end do ! iproc

        end do ! igroup

        !
        ! Return as integer array
        !
        recv_procs_array = recv_procs%data()

    end function get_recv_procs
    !*********************************************************************************

    !>  Return the MPI ranks that the current rank is sending information to.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   4/10/2017
    !!
    !!
    !---------------------------------------------------------------------------------
    function get_send_procs(self) result(send_procs_array)
        class(mesh_t),  intent(in)  :: self

        integer(ik)                 :: idom, iproc, igroup
        integer(ik),    allocatable :: send_procs_dom(:), send_procs_bc(:), send_procs_array(:)
        type(ivector_t)             :: send_procs

        !
        ! Accumulate processor ranks that we are receiving from: domains
        !
        do idom = 1,self%ndomains()
            send_procs_dom = self%domain(idom)%get_send_procs()

            do iproc = 1,size(send_procs_dom)
                call send_procs%push_back_unique(send_procs_dom(iproc))
            end do ! iproc

        end do ! idom

        !
        ! Accumulate processor ranks that we are receiving from: bc_patch_groups
        !
        do igroup = 1,self%nbc_patch_groups()
            send_procs_bc = self%bc_patch_group(igroup)%get_send_procs()

            do iproc = 1,size(send_procs_bc)
                call send_procs%push_back_unique(send_procs_bc(iproc))
            end do ! iproc

        end do ! igroup

        !
        ! Return as integer array
        !
        send_procs_array = send_procs%data()

    end function get_send_procs
    !*********************************************************************************

    !>  Return the number of interior neighbor elements that live on processor, iproc.
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   7/19/2017
    !!
    !---------------------------------------------------------------------------------
    function get_proc_ninterior_neighbors(self,iproc) result(n)
        class(mesh_t),  intent(in)  :: self
        integer(ik),    intent(in)  :: iproc

        integer(ik) :: idom, ielem, iface, n

        !
        ! Accumulate number of INTERIOR neighbors that live on iproc
        !
        n = 0
        do idom = 1,self%ndomains()
            do ielem = 1,self%domain(idom)%get_nelements_local()
                do iface = 1,NFACES
                    if (self%domain(idom)%faces(ielem,iface)%ineighbor_proc == iproc) n = n + 1
                end do !iface
            end do !ielem
        end do !idom

    end function get_proc_ninterior_neighbors
    !**********************************************************************************

    !>  Return the number of chimera donors that live on processor, iproc.
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   7/27/2017
    !!
    !---------------------------------------------------------------------------------
    function get_proc_nchimera_donors(self,iproc) result(n)
        class(mesh_t),  intent(in)  :: self
        integer(ik),    intent(in)  :: iproc

        integer(ik)     :: idom, ChiID, idonor, n, donor_domain_g, donor_element_g, i
        type(ivector_t) :: donor_domains_g, donor_elements_g
        logical         :: already_counted, proc_has_donor

        !
        ! Accumulate number of CHIMERA donors that live on iproc
        !
        do idom = 1,self%ndomains()
            do ChiID = 1,self%domain(idom)%chimera%nreceivers()
                do idonor = 1,self%domain(idom)%chimera%recv(ChiID)%ndonors()

                    proc_has_donor = (self%domain(idom)%chimera%recv(ChiID)%donor(idonor)%iproc == iproc)
                    if (proc_has_donor) then

                        donor_domain_g  = self%domain(idom)%chimera%recv(ChiID)%donor(idonor)%idomain_g
                        donor_element_g = self%domain(idom)%chimera%recv(ChiID)%donor(idonor)%ielement_g

                        ! Check if donor was already counted
                        already_counted = .false.
                        do i = 1,donor_elements_g%size()
                            already_counted = (donor_domains_g%at(i) == donor_domain_g .and. donor_elements_g%at(i) == donor_element_g)
                            if (already_counted) exit
                        end do

                        if (.not. already_counted) then
                            call donor_domains_g%push_back(donor_domain_g)
                            call donor_elements_g%push_back(donor_element_g)
                        end if

                    end if

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

        !
        ! Get number of counted donors coming from iproc
        !
        n = donor_elements_g%size()

    end function get_proc_nchimera_donors
    !**********************************************************************************

    !>  Return the number of elements being received into self%parallel_elements
    !!  by the mesh.
    !!
    !!  NOTE: currently, we are only receiving off-processor chimera donors into
    !!        self%parallel_elements. So, even though we may have interior neighbors
    !!        that are off-processor, those elements are not included in this count
    !!        atthe moment, because they are not stored in self%parallel_elements.
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   7/26/2017
    !!
    !!
    !-----------------------------------------------------------------------------------
    function get_nelements_recv(self) result(n)
        class(mesh_t),  intent(in)  :: self

        integer(ik)     :: idom, irecv, idonor, donor_iproc, idomain_g, ielement_g, &
                           idomain_g_list, ielement_g_list, ientry, n
        logical         :: parallel_donor, already_counted
        type(ivector_t) :: donor_domain_g, donor_element_g

        do idom = 1,self%ndomains()
            do irecv = 1,self%domain(idom)%chimera%nreceivers()
                do idonor = 1,self%domain(idom)%chimera%recv(irecv)%ndonors()

                    donor_iproc = self%domain(idom)%chimera%recv(irecv)%donor(idonor)%iproc

                    parallel_donor = (donor_iproc /= IRANK)
                    if (parallel_donor) then
                        idomain_g  = self%domain(idom)%chimera%recv(irecv)%donor(idonor)%idomain_g
                        ielement_g = self%domain(idom)%chimera%recv(irecv)%donor(idonor)%ielement_g

                        already_counted = .false.
                        do ientry = 1,donor_element_g%size()
                            idomain_g_list  = donor_domain_g%at(ientry)
                            ielement_g_list = donor_element_g%at(ientry)
                            if ( (idomain_g_list  == idomain_g ) .and. &
                                 (ielement_g_list == ielement_g) ) already_counted = .true.
                            if (already_counted) exit
                        end do

                        if (.not. already_counted) then
                            call donor_domain_g%push_back(idomain_g)
                            call donor_element_g%push_back(ielement_g)
                        end if
                    end if

                end do !idonor
            end do !irecv
        end do !idom

        !
        ! Get size of accumulated elements being received
        !
        n = donor_element_g%size()

    end function get_nelements_recv
    !***********************************************************************************

    !>  Try to locate an element in self%parallel_element(:). If found, return valid
    !!  pelem_ID for self%parallel_element(pelem_ID). If not found, return NO_ID.
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   7/25/2017
    !!
    !-----------------------------------------------------------------------------------
    function find_parallel_element(self,idomain_g, ielement_g) result(pelem_ID)
        class(mesh_t),  intent(in)  :: self
        integer(ik),    intent(in)  :: idomain_g
        integer(ik),    intent(in)  :: ielement_g

        integer(ik) :: ielem, pelem_ID

        pelem_ID = NO_ID
        do ielem = 1,self%nparallel_elements()

            if ( (self%parallel_element(ielem)%idomain_g == idomain_g) .and.    &
                 (self%parallel_element(ielem)%ielement_g == ielement_g) ) then
                pelem_ID = ielem
                exit
            end if

        end do !ielem

    end function find_parallel_element
    !***********************************************************************************

    !>  Extend allocation for parallel_element and return new identifier, pelem_ID.
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   7/25/2017
    !!
    !----------------------------------------------------------------------------------
    function new_parallel_element(self) result(pelem_ID)
        class(mesh_t),  intent(inout)   :: self

        integer(ik)                     :: pelem_ID, ierr
        type(element_t),    allocatable :: temp(:)

        !
        ! Resize array storage
        !
        allocate(temp(self%nparallel_elements() + 1), stat=ierr)

        ! Copy previously initialized instances to new array. Be careful about pointers
        ! components here. For example, a pointer from a face to an element would no
        ! longer be valid in the new array.
        if (self%nparallel_elements() > 0) then
            temp(1:size(self%parallel_element)) = self%parallel_element(1:size(self%parallel_element))
        end if

        !
        ! Move resized temp allocation back to mesh container.
        ! Be careful about pointer components here! Their location in memory has changed.
        !
        call move_alloc(temp,self%parallel_element)

        !
        ! Set domain identifier of newly allocated domain that will be returned
        !
        pelem_ID = self%nparallel_elements()

    end function new_parallel_element
    !**********************************************************************************

    !>  Return number of parallel elements on the mesh.
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   7/25/2017
    !!
    !---------------------------------------------------------------------------------
    function nparallel_elements(self) result(n)
        class(mesh_t),  intent(in)  :: self

        integer(ik) :: n

        if (allocated(self%parallel_element)) then
            n = size(self%parallel_element)
        else
            n = 0
        end if

    end function nparallel_elements
    !**********************************************************************************

    !>  Initialiate parallel communication of mesh quantities.
    !!
    !!  Currently communicates just ALE quantities.
    !!
    !!  Order of operations:
    !!      1: mesh%comm_send()
    !!      2: mesh%comm_recv()
    !!      3: mesh%comm_wait()
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   7/13/2017
    !!
    !!
    !---------------------------------------------------------------------------------
    subroutine comm_send(self)
        class(mesh_t),  intent(inout)   :: self

        integer(ik)         :: idom, ielem, iface, isend, isend_proc, iproc, ierr,  &
                               send_size_a, send_size_b, send_size_c, send_size_d,  &
                               idomain_l, ielement_l
        type(mpi_request)   :: request(7)
        logical             :: interior_face, parallel_neighbor

        !
        ! Send interior face data
        !
        do idom = 1,self%ndomains()
            do ielem = 1,self%domain(idom)%nelem
                do iface = 1,NFACES

                    interior_face     = (self%domain(idom)%faces(ielem,iface)%ftype == INTERIOR)
                    parallel_neighbor = (self%domain(idom)%faces(ielem,iface)%ineighbor_proc /= IRANK)

                    !
                    ! For INTERIOR faces that have off-processor neighbors we need to communicate ALE data.
                    !
                    if ( interior_face .and. parallel_neighbor ) then

                        associate ( face => self%domain(idom)%faces(ielem,iface) )

                        send_size_a = size(face%neighbor_location)
                        send_size_b = size(face%interp_coords_vel)
                        send_size_c = size(face%ale_g)
                        send_size_d = size(face%ale_Dinv)

                        ! First, send neighbor location. This way, the receiving processor knows where to put the data.
                        ! Next, send all ALE information
                        call mpi_isend(self%domain(idom)%faces(ielem,iface)%neighbor_location, send_size_a, mpi_integer4, face%ineighbor_proc, 0, ChiDG_COMM, request(1), ierr)
                        call mpi_isend(self%domain(idom)%faces(ielem,iface)%interp_coords_vel, send_size_b, mpi_real8,    face%ineighbor_proc, 0, ChiDG_COMM, request(2), ierr)
                        call mpi_isend(self%domain(idom)%faces(ielem,iface)%ale_g,             send_size_c, mpi_real8,    face%ineighbor_proc, 0, ChiDG_COMM, request(3), ierr)
                        call mpi_isend(self%domain(idom)%faces(ielem,iface)%ale_g_grad1,       send_size_c, mpi_real8,    face%ineighbor_proc, 0, ChiDG_COMM, request(4), ierr)
                        call mpi_isend(self%domain(idom)%faces(ielem,iface)%ale_g_grad2,       send_size_c, mpi_real8,    face%ineighbor_proc, 0, ChiDG_COMM, request(5), ierr)
                        call mpi_isend(self%domain(idom)%faces(ielem,iface)%ale_g_grad3,       send_size_c, mpi_real8,    face%ineighbor_proc, 0, ChiDG_COMM, request(6), ierr)
                        call mpi_isend(self%domain(idom)%faces(ielem,iface)%ale_Dinv,          send_size_d, mpi_real8,    face%ineighbor_proc, 0, ChiDG_COMM, request(7), ierr)

                        call self%comm_requests%push_back(request(1))
                        call self%comm_requests%push_back(request(2))
                        call self%comm_requests%push_back(request(3))
                        call self%comm_requests%push_back(request(4))
                        call self%comm_requests%push_back(request(5))
                        call self%comm_requests%push_back(request(6))
                        call self%comm_requests%push_back(request(7))

                        end associate

                    end if

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

        !
        ! Send chimera donors
        !
        do idom = 1,self%ndomains()
            ! For each element that needs sent
            do isend = 1,self%domain(idom)%chimera%nsend()
                ! For each processor the current element gets sent to
                do isend_proc = 1,self%domain(idom)%chimera%send(isend)%nsend_procs()

                    ! Get the processor rank we are sending to
                    iproc = self%domain(idom)%chimera%send(isend)%send_procs%at(isend_proc)

                    ! If receiver is off-processor, send reference and physical nodes/velocities
                    if (iproc /= IRANK) then

                        idomain_l  = self%domain(idom)%chimera%send(isend)%idomain_l
                        ielement_l = self%domain(idom)%chimera%send(isend)%ielement_l

                        send_size_a = size(self%domain(idomain_l)%elems(ielement_l)%connectivity)
                        send_size_b = size(self%domain(idomain_l)%elems(ielement_l)%node_coords)
                        send_size_c = size(self%domain(idomain_l)%elems(ielement_l)%node_coords_def)
                        send_size_d = size(self%domain(idomain_l)%elems(ielement_l)%node_coords_vel)

                        ! First send location of donor
                        call mpi_isend(self%domain(idomain_l)%elems(ielement_l)%element_location,             4, mpi_integer4, iproc, 0, ChiDG_COMM, request(1), ierr)
                        call mpi_isend(self%domain(idomain_l)%elems(ielement_l)%element_data,                 8, mpi_integer4, iproc, 0, ChiDG_COMM, request(2), ierr)
                        call mpi_isend(self%domain(idomain_l)%elems(ielement_l)%node_coords,        send_size_b, mpi_real8,    iproc, 0, ChiDG_COMM, request(3), ierr)
                        call mpi_isend(self%domain(idomain_l)%elems(ielement_l)%node_coords_def,    send_size_c, mpi_real8,    iproc, 0, ChiDG_COMM, request(4), ierr)
                        call mpi_isend(self%domain(idomain_l)%elems(ielement_l)%node_coords_vel,    send_size_d, mpi_real8,    iproc, 0, ChiDG_COMM, request(5), ierr)

                        call self%comm_requests%push_back(request(1))
                        call self%comm_requests%push_back(request(2))
                        call self%comm_requests%push_back(request(3))
                        call self%comm_requests%push_back(request(4))
                        call self%comm_requests%push_back(request(5))

                    end if

                end do !isend_procs
            end do !isend
        end do !idom

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

    !>  Initiates parallel recieve of mesh quantities.
    !!
    !!  Order of operations:
    !!      1: mesh%comm_send()
    !!      2: mesh%comm_recv()
    !!      3: mesh%comm_wait()
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   7/13/2017
    !!
    !!
    !---------------------------------------------------------------------------------
    subroutine comm_recv(self)
        class(mesh_t),  intent(inout)   :: self

        character(:),   allocatable :: coord_system
        real(rk),       allocatable :: nodes(:,:), nodes_def(:,:), nodes_vel(:,:), nodes_disp(:,:)
        integer(ik),    allocatable :: recv_procs(:), connectivity(:)
        integer(ik)                 :: idom, ielem, iface, iproc, irecv, ierr,      &
                                       etype, nnodes, nterms_s, nterms_c, nfields,  &
                                       ntime, pelem_ID, interpolation_level,        &
                                       idomain_g, ielement_g, coordinate_system,    &
                                       recv_size_a, recv_size_b, recv_size_c,       &
                                       face_location(5), element_location(4),       &
                                       element_data(8), spacedim, inode

        logical :: parallel_donor

        real(rk), allocatable :: ref_coords(:,:)
        real(rk) :: xi, eta, zeta, det_jacobian_grid_pt, det_jacobian_grid_grad_pt(3),&
            inv_jacobian_grid_pt(3,3), grid_vel_pt(3)
        integer(ik) :: npts, ipt, donor_proc, idonor, idomain_l, ielement_l,  igq, ChiID

        !
        ! Receive interior face data
        !
        recv_procs = self%get_recv_procs()
        do iproc = 1,size(recv_procs)
            do irecv = 1,self%get_proc_ninterior_neighbors(recv_procs(iproc))

                ! The sending proc sent its neighbor location, which is a face on our local processor
                ! here where we will store the incoming ALE data
                ! face_location = [idomain_g, idomain_l, ielement_g, ielement_l, iface]
                call mpi_recv(face_location, 5, mpi_integer4, recv_procs(iproc), 0, ChiDG_COMM, mpi_status_ignore, ierr)
                idom  = face_location(2)
                ielem = face_location(4)
                iface = face_location(5)

                recv_size_a = size(self%domain(idom)%faces(ielem,iface)%neighbor_interp_coords_vel)
                recv_size_b = size(self%domain(idom)%faces(ielem,iface)%neighbor_ale_g)
                recv_size_c = size(self%domain(idom)%faces(ielem,iface)%neighbor_ale_Dinv)

                call mpi_recv(self%domain(idom)%faces(ielem,iface)%neighbor_interp_coords_vel, recv_size_a, mpi_real8, recv_procs(iproc), 0, ChiDG_COMM, mpi_status_ignore, ierr)
                call mpi_recv(self%domain(idom)%faces(ielem,iface)%neighbor_ale_g,             recv_size_b, mpi_real8, recv_procs(iproc), 0, ChiDG_COMM, mpi_status_ignore, ierr)
                call mpi_recv(self%domain(idom)%faces(ielem,iface)%neighbor_ale_g_grad1,       recv_size_b, mpi_real8, recv_procs(iproc), 0, ChiDG_COMM, mpi_status_ignore, ierr)
                call mpi_recv(self%domain(idom)%faces(ielem,iface)%neighbor_ale_g_grad2,       recv_size_b, mpi_real8, recv_procs(iproc), 0, ChiDG_COMM, mpi_status_ignore, ierr)
                call mpi_recv(self%domain(idom)%faces(ielem,iface)%neighbor_ale_g_grad3,       recv_size_b, mpi_real8, recv_procs(iproc), 0, ChiDG_COMM, mpi_status_ignore, ierr)
                call mpi_recv(self%domain(idom)%faces(ielem,iface)%neighbor_ale_Dinv,          recv_size_c, mpi_real8, recv_procs(iproc), 0, ChiDG_COMM, mpi_status_ignore, ierr)

            end do !irecv
        end do !iproc

        !
        ! Receive/construct parallel chimera donors
        !
        do iproc = 1,size(recv_procs)
            do irecv = 1,self%get_proc_nchimera_donors(recv_procs(iproc))

                ! element_location = [idomain_g, idomain_l, ielement_g, ielement_l]
                call mpi_recv(element_location, 4, mpi_integer4,  recv_procs(iproc), 0, ChiDG_COMM, mpi_status_ignore, ierr)
                idomain_g           = element_location(1)
                ielement_g          = element_location(3)

                ! element_data = [element_type, spacedim, coordinate_system, nfields, nterms_s, nterms_c, ntime, interpolation_level]
                call mpi_recv(element_data,     8, mpi_integer4,  recv_procs(iproc), 0, ChiDG_COMM, mpi_status_ignore, ierr)
                etype               = element_data(1)
                spacedim            = element_data(2)
                coordinate_system   = element_data(3)
                nfields             = element_data(4)
                nterms_s            = element_data(5)
                nterms_c            = element_data(6)
                ntime               = element_data(7)
                interpolation_level = element_data(8)
                nnodes = (etype+1)*(etype+1)*(etype+1)

                ! Allocate buffers and receive: nodes, displacements, and velocities.
                ! These quantities are located at the element support nodes, not interpolation
                ! nodes.
                if (allocated(nodes)) deallocate(nodes, nodes_def, nodes_vel, connectivity)
                allocate(nodes(       nnodes,3), &
                         nodes_def(   nnodes,3), &
                         nodes_vel(   nnodes,3), &
                         connectivity(nnodes  ), stat=ierr)
                if (ierr /= 0) call AllocationError

                call mpi_recv(nodes,     nnodes*3, mpi_real8, recv_procs(iproc), 0, ChiDG_COMM, mpi_status_ignore, ierr)
                call mpi_recv(nodes_def, nnodes*3, mpi_real8, recv_procs(iproc), 0, ChiDG_COMM, mpi_status_ignore, ierr)
                call mpi_recv(nodes_vel, nnodes*3, mpi_real8, recv_procs(iproc), 0, ChiDG_COMM, mpi_status_ignore, ierr)

                !
                ! Compute node displacements
                !
                nodes_disp = nodes_def - nodes

                !
                ! Build local connectivity
                !   : we construct the parallel element using just a local ordering
                !   : so connectivity starts at 1 and goes to the number of nodes in
                !   : the element, nnodes.
                !   :
                !   :   connectivity = [1, 2, 3, 4, 5, 6, 7, 8 ...]
                !   :
                !   : We assume here that the displacements and velocities are ordered
                !   : appropriately.
                !
                do inode = 1,nnodes
                    connectivity(inode) = inode
                end do

                !
                ! Check for existing parallel element. If one does not
                ! exist, get an identifier for a new parallel element.
                !
                pelem_ID = self%find_parallel_element(idomain_g,ielement_g)
                if (pelem_ID == NO_ID) pelem_ID = self%new_parallel_element()

                !
                ! Initialize element geometry
                !
                select case(coordinate_system)
                    case(CARTESIAN)
                        coord_system = 'Cartesian'
                    case(CYLINDRICAL)
                        coord_system = 'Cylindrical'
                    case default
                        call chidg_signal(FATAL,"element%comm_recv: invalid coordinate system.")
                end select

                !
                ! Construct/initialize/reinitialize parallel element
                !
                if (.not. self%parallel_element(pelem_ID)%geom_initialized) then
                    call self%parallel_element(pelem_ID)%init_geom(nodes,connectivity,etype,element_location,trim(coord_system))
                end if

                call self%parallel_element(pelem_ID)%init_sol('Quadrature',interpolation_level,nterms_s,nfields,ntime)
                call self%parallel_element(pelem_ID)%set_displacements_velocities(nodes_disp,nodes_vel)
                call self%parallel_element(pelem_ID)%update_interpolations_ale()

            end do !irecv
        end do !iproc

        !
        ! Assemble overset interpolations on receiver exterior state
        !
        call self%assemble_chimera_data()

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

    !>  Wait until all outstanding requests initiated by mesh%comm_send() have
    !!  been completed.
    !!
    !!  Order of operations:
    !!      1: mesh%comm_send()
    !!      2: mesh%comm_recv()
    !!      3: mesh%comm_wait()
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   7/13/2017
    !!
    !!
    !---------------------------------------------------------------------------------
    subroutine comm_wait(self)
        class(mesh_t),  intent(inout)   :: self

        integer(ik) :: nwait, ierr

        nwait = self%comm_requests%size()
        call mpi_waitall(nwait, self%comm_requests%data(1:nwait), mpi_statuses_ignore, ierr)
        call self%comm_requests%clear()

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

    !>  A public interface for calling 'new_domain'.
    !!
    !!  Used for tests.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   4/6/2017
    !!
    !--------------------------------------------------------------------------------
    function stub_new_domain(self) result(idomain)
        class(mesh_t),  intent(inout)   :: self

        integer(ik) :: idomain

        idomain = self%new_domain()

    end function stub_new_domain
    !********************************************************************************

end module type_mesh


      SUBROUTINE PRNTX2(IN,IOUT,NIN,NOUT)
!      PRNTX CONVERTS A STRING OF RASTERS (A CONTINUOUS STRING OF BITS, EITHER
!  ON OR OFF, EACH BIT REPRESENTING A DOT) TO A PRINTRONIX PLOT MODE
!  CHARACTER STRING.  THE PRINTRONIX EXPECTS an UPPER BIT ON to indicate
!  THE PLOT MODE).  THIS ROUTINE THUS TAKES 6 BIT BYTES FROM THE INPUT,
!  CONVERTS IT TO AN 8 BIT BYTE, AND PUTS ON THE appropriate HIGH ORDER BIT.
!  PRNTX1 does not swap the bit order as PRNTX2 does.
!     Use INTEGER*2 rather than CHARACTER*1 because ANSII standard character
! handling may be different on different machines.
!
!  ARGUMENTS:
!  IN    - INPUT RASTER STRING TO BE CONVERTED.
!  IOUT  - THE OUTPUT CHARCTER STRING.  IOUT MUST BE DIFFERENT FROM IN. IOUT
!          WILL BE LONGER THAN IN!!!
!  NIN   - THE NUMBER OF 16 BIT INTEGERS IS IN.  NIN*2 BYTES WILL BE CONVERTED.
!  NOUT  - THE NUMBER OF INTEGER*2 WORDS RETURNED IN IOUT.  NOUT*2 BYTES WILL
!          BE IN IOUT.  ***  NOTE  *** THIS IS A RETURN ARGUMENT!!
!
!  COPYRIGHT (C) BY:
!  PAUL HENKART, SEISMIC REFLECTION PROCESSORS, SAN DIEGO, 13 August 1987
!  ALL RIGHTS RESERVED.
! mod 14 Aug 07 - g95 IAND requires arguments to be same type and kind.
!
      INTEGER*2 RSHIFT, LSHIFT
      INTEGER*4 NIN,NOUT
      INTEGER*2 IN(1),IOUT(1)
      INTEGER*2 itemp,jtemp, itemp1, itemp2, i63, i60, i3, i48, i15, i10
      DATA i63/63/, i60/60/, i3/3/, i48/48/, i15/15/, i10/10/
      INTEGER*2 iflip(64), idec(64)
!      DATA IFLIP /:100,:140,:120,:160,:110,:150,:130,:170,
!     1            :104,:144,:124,:164,:114,:154,:134,:174,
!     2            :102,:142,:122,:162,:112,:152,:132,:172,
!     3            :106,:146,:126,:166,:116,:156,:136,:176,
!     4            :101,:141,:121,:161,:111,:151,:131,:171,
!     5            :105,:145,:125,:165,:115,:155,:135,:175,
!     6            :103,:143,:123,:163,:113,:153,:133,:173,
!     7            :107,:147,:127,:167,:117,:157,:137,:177/
      DATA IFLIP /64,96,80,112,72,104,88,120,
     *            68,100,84,116,76,108,92,124,
     *            66,98,82,114,74,106,90,122,
     *            70,102,86,118,78,110,94,126,
     *            65,97,81,113,73,105,89,121,
     *            69,101,85,117,77,109,93,125,
     *            67,99,83,115,75,107,91,123,
     *            71,103,87,119,79,111,95,127/
      DATA IDEC/64,65,66,67,68,69,70,71,
     *          72,73,74,75,76,77,78,79,
     *          80,81,82,83,84,85,86,87,
     *          88,89,90,91,92,93,94,95,
     *          96,97,98,99,100,101,102,103,
     *          104,105,106,107,108,109,110,111,
     *          112,113,114,115,116,117,118,119,
     *          120,121,122,123,124,125,126,127/

      i = 1
!  start the string with a 5 - put the printronix in plot mode
      itemp = 5
      j = 1
   10 CONTINUE
      jtemp = iflip( IAND( rshift(in(i),10), i63) + 1 )   ! 63=hex(3f)
      iout(j) = IOR( lshift(itemp,8), jtemp )
      j = j + 1
      itemp = iflip( IAND( rshift(in(i),4), i63 ) + 1 )
      itemp1 = IAND( lshift(in(i),2), i60)                ! 003c
      i = i + 1
      itemp2 = IAND( rshift(in(i),14), i3)
      jtemp = iflip( IOR(itemp1,itemp2) + 1 )
      iout(j) = IOR( lshift(itemp,8), jtemp )
      j = j + 1
      itemp = iflip( IAND( rshift(in(i),8), i63) + 1 )
      jtemp = iflip( IAND( rshift(in(i),2), i63) + 1 )
      iout(j) = IOR( lshift(itemp,8), jtemp )
      j = j + 1
      itemp1 = IAND( lshift(in(i),4), i48)
      i = i + 1
      itemp2 = IAND( rshift(in(i),12), i15)
      itemp = iflip( IOR(itemp1,itemp2) + 1 )
      jtemp = iflip( IAND( rshift(in(i),6), i63) + 1 )
      iout(j) = IOR( lshift(itemp,8), jtemp )
      j = j + 1
      itemp = iflip( IAND(in(i),i63) + 1 )
      i = i + 1
      IF( i .LT. nin ) GO TO 10
!****
      iout(j) = IOR( lshift(itemp,8), i10 )
      nout = j
      RETURN
      END


      subroutine analyze_list_core(me_cov,me_contrv,nvec,idxrec,mode,
     &     orb_info,str_info)

      implicit none

      include 'opdim.h'
      include 'stdunit.h'
      include 'def_orbinf.h'
      include 'def_graph.h'
      include 'def_strinf.h'
      include 'mdef_operator_info.h'

       integer, parameter ::
     &     ntest = 0
      character(len=17), parameter ::
     &     i_am='analyze_list_core'
      integer, parameter ::
     &     maxlist = 50

      integer, intent(in) ::
     &     nvec, idxrec
      type(me_list_array), intent(inout) ::
     &     me_cov(nvec), me_contrv(nvec)
      character(len=*), intent(in) ::
     &     mode

      type(orbinf), intent(inout) ::
     &     orb_info
      type(strinf), intent(inout) ::
     &     str_info

      integer ::
     &     maxblk, idx, ioff, iii
      real(8) ::
     &     xnrm, weight_last

      real(8), pointer ::
     &     xnorm(:,:), coeff_list(:), weight_list(:)
      integer, pointer ::
     &     idx_list(:)
      character(len=80), pointer ::
     &     label_list(:)

      maxblk=1
      do idx = 1, nvec
        maxblk = max(maxblk,me_cov(idx)%mel%op%n_occ_cls)
      end do

      ! get all info
      if (mode(1:4).eq.'NORM'.or.mode(1:4).eq.'norm') then

        allocate(xnorm(maxblk,nvec))

        do idx = 1, nvec
          call blk_norm_for_list(xnorm(1,idx),maxblk,
     &         me_cov(idx)%mel,me_contrv(idx)%mel)
        end do

        ! print it:
        write(luout,'(1x,60("-"))')
        write(luout,'(2x,a,i4)') 'record # ',idxrec
        write(luout,'(1x,60("-"))')
        do idx = 1, nvec
          call print_mel_contribs(luout,me_cov(idx)%mel,'e10.4',
     &         xnorm(1,idx),maxblk)
          write(luout,'(1x,60("-"))')
        end do

        deallocate(xnorm)

      else if (mode(1:7).eq.'CONTRIB'.or.mode(1:7).eq.'contrib') then

        allocate(label_list(maxlist),coeff_list(maxlist),
     &       weight_list(maxlist),idx_list(maxlist))

        ioff = 0
        do idx = 1, nvec
           call quit(0,i_am,'not yet active')
c          call maxcontrb_for_list(
c     &         coeff_list,weight_list,idx_list,
c     &         maxlist,ioff,idx.eq.1,
c     &         me_cov(idx)%mel,me_contrv(idx)%mel)
c          ioff = ioff + me_cov(idx)%mel%len_op
        end do

        ! reduce list to 99% of norm (but cut behind degen. dets.)
        xnrm = 0d0
        iii = 1
        weight_last = 0d0
        do while(iii.lt.maxlist.and.
     &       (xnrm.lt.0.99d0.or.
     &       abs(weight_list(iii)-weight_last).lt.1d-10))
c          write(luout,'(i7,2x,f12.8,2x,f12.8,2x,f12.8)')
c     &         idx_list(iii),coeff_list(iii),weight_list(iii),
c     &         xnrm+weight_list(iii)
          weight_last = weight_list(iii)
          xnrm=xnrm+weight_list(iii)
          iii = iii+1
        end do
c        lenlist = iii-1

        ! idx_list -> labels
        ! (label_list,me_cov(idx)%mel,str_info,orb_info)

        ! must assemble indices for the contributing list and inquire labels
c        do iii = 1, lenlist
c          ioff = 0
c          do idx = 1, nvec
c            if (idx_list(iii).le.ioff+me_cov(idx)%mel%len_op) then
c              idx_list2(1,iii) = idx
c              idx_list2(2,iii) = idx_list(iii)-ioff
c            end if
c          end do
c        end do
c
c        do idx = 1, nvec
c          jjj = 0
c          do iii = 1, nvec
c            if (idx_list2(1,iii).eq.idx) then
c              jjj = jjj+1
c              list3(jjj) = idx_list2(2,iii)
c            end if
c          end do
c        end do

        deallocate(label_list,coeff_list,
     &             weight_list,idx_list)

      else
        call quit(1,i_am,'not yet programmed!')
      end if

      end


!-----------------------------------------------------------------------
! Fortran interface to CUDA Library for Skeleton 2D Electrostatic
! GPU-MPI PIC Code */
! written by Viktor K. Decyk, UCLA
      module gpuppush2_h
      implicit none
!
      interface
         subroutine cgpuppgppush2l(gp_ppart,gp_fxy,gp_kpic,noff,nyp,qbm,&
     &dt,gp_ek,nx,ny,mx,my,idimp,nppmx,nxv,nypmx,mx1,mxyp1,ipbc)
         implicit none
         integer :: nx, ny, mx, my, idimp, nppmx, nxv, nypmx, mx1, mxyp1
         integer :: ipbc
         integer :: noff, nyp
         real :: qbm, dt
         integer, dimension(2) :: gp_ppart, gp_fxy, gp_kpic, gp_ek
         end subroutine
      end interface
!
      interface
         subroutine cgpu2ppgppost2l(gp_ppart,gp_q,gp_kpic,noff,qm,idimp,&
     &nppmx,mx,my,nxv,nypmx,mx1,mxyp1)
         implicit none
         integer :: idimp, nppmx, mx, my, nxv, nypmx, mx1, mxyp1
         integer :: noff
         real :: qm
         integer, dimension(2) :: gp_ppart, gp_q, gp_kpic
         end subroutine
      end interface
!
      interface
         subroutine cgpuppcaguard2xl(gp_qc,gp_scs,gp_q,nyp,nx,nxe,nypmx,&
     &nxvh,kypd)
         implicit none
         integer :: nx, nxe, nypmx, nxvh, kypd
         integer :: nyp
         integer, dimension(2) :: gp_qc, gp_scs, gp_q
         end subroutine
      end interface
!
      interface
         subroutine cgpuppcaguard2yl(gp_qc,gp_scr,nx,nxvh,kypd)
         implicit none
         integer :: nx, nxvh, kypd
         integer, dimension(2) :: gp_qc, gp_scr
         end subroutine
      end interface
!
      interface
         subroutine cgpuppccguard2xl(gp_fxyc,gp_scs,gp_fxy,nyp,nx,nxe,  &
     &nypmx,nxvh,kypd)
         implicit none
         integer :: nx, nxe, nypmx, nxvh, kypd
         integer :: nyp
         integer, dimension(2) :: gp_fxyc, gp_scs, gp_fxy
         end subroutine
      end interface
!
      interface
         subroutine cgpuppccguard2yl(gp_fxy,gp_scr,nyp,nx,nxe,nxvh,nypmx&
     &)
         implicit none
         integer :: nx, nxe, nxvh, nypmx
         integer :: nyp
         integer, dimension(2) :: gp_fxy, gp_scr
         end subroutine
      end interface
!
      interface
         subroutine cgpupppord2la(gp_ppart,gp_ppbuff,gp_sbufl,gp_sbufr, &
     &gp_kpic,gp_ncl,gp_ihole,gp_ncll,gp_nclr,noff,nyp,idimp,nppmx,nx,ny&
     &,mx,my,mx1,myp1,npbmx,ntmax,nbmax,gp_irc)
         implicit none
         integer :: idimp, nppmx, nx, ny, mx, my, mx1, myp1, npbmx
         integer :: ntmax, nbmax
         integer :: noff, nyp
         integer, dimension(2) :: gp_ppart, gp_ppbuff
         integer, dimension(2) :: gp_sbufl, gp_sbufr
         integer, dimension(2) :: gp_kpic, gp_ncl, gp_ihole
         integer, dimension(2) :: gp_ncll, gp_nclr, gp_irc
         end subroutine
      end interface
!
      interface
         subroutine cgpupppord2lb(gp_ppart,gp_ppbuff,gp_rbufl,gp_rbufr, &
     &gp_kpic,gp_ncl,gp_ihole,gp_mcll,gp_mclr,idimp,nppmx,mx1,myp1,npbmx&
     &,ntmax,nbmax,gp_irc)
         implicit none
         integer :: idimp, nppmx, mx1, myp1, npbmx, ntmax, nbmax
         integer, dimension(2) :: gp_ppart, gp_ppbuff
         integer, dimension(2) :: gp_rbufl, gp_rbufr
         integer, dimension(2) :: gp_kpic, gp_ncl, gp_ihole
         integer, dimension(2) :: gp_mcll, gp_mclr, gp_irc
         end subroutine
      end interface
!
      interface
         subroutine cgpuppois22t(gp_qt, gp_fxyt,gp_ffct,gp_we,nx,ny,    &
     &kstrt,nyv,kxp1,nyhd)
         implicit none
         integer :: nx, ny, kstrt, nyv, kxp1, nyhd
         integer, dimension(2) :: gp_qt, gp_fxyt, gp_ffct, gp_we
         end subroutine
      end interface
!
      interface
         subroutine cgpuwppfft2rcsx(gp_f,gp_bsm,isign,gp_mixup,gp_sct,  &
     &indx,indy,kstrt,nvp,kxp1,kyp,nxhd,kypd,nxhyd,nxyhd)
         implicit none
         integer :: isign, indx, indy, kstrt, nvp, kxp1, kyp
         integer :: nxhd, kypd, nxhyd, nxyhd
         integer, dimension(2) :: gp_f, gp_bsm, gp_mixup, gp_sct
         end subroutine
      end interface
!
      interface
         subroutine cgpuwppfft2rcsy(gp_g,gp_brm,isign,gp_mixup,gp_sct,  &
     &indx,indy,kstrt,nvp,kxp1,kyp,nyd,nxhyd,nxyhd)
         implicit none
         integer :: isign, indx, indy, kstrt, nvp, kxp1, kyp
         integer :: nyd, nxhyd, nxyhd
         integer, dimension(2) :: gp_g, gp_brm, gp_mixup, gp_sct
         end subroutine
      end interface
!
      interface
         subroutine cgpuwppfft2rcsxn(gp_fn,gp_bsm,isign,gp_mixup,gp_sct,&
     &indx,indy,ndim,kstrt,nvp,kxp1,kyp,nxhd,kypd,nxhyd,nxyhd)
         implicit none
         integer :: isign, indx, indy, ndim, kstrt, nvp, kxp1, kyp
         integer :: nxhd, kypd, nxhyd, nxyhd
         integer, dimension(2) :: gp_fn, gp_bsm, gp_mixup, gp_sct
         end subroutine
      end interface
!
      interface
         subroutine cgpuwppfft2rcsyn(gp_gn,gp_brm,isign,gp_mixup,gp_sct,&
     &indx,indy,ndim,kstrt,nvp,kxp1,kyp,nyd,nxhyd,nxyhd)
         implicit none
         integer :: isign, indx, indy, ndim, kstrt, nvp, kxp1, kyp
         integer :: nyd, nxhyd, nxyhd
         integer, dimension(2) :: gp_gn, gp_brm, gp_mixup, gp_sct
         end subroutine
      end interface
!
      interface
         subroutine cgpuppltpose(gp_f,gp_g,nx,ny,kxp,kyp,kstrt,nxv,nyv)
         implicit none
         integer :: nx, ny, kxp, kyp, kstrt, nxv, nyv
         integer, dimension(2) :: gp_f, gp_g
         end subroutine
      end interface
!
      interface
         subroutine cgpuppltposen(gp_fn,gp_gn,nx,ny,kxp,kyp,kstrt,ndim, &
     &nxv,nyv)
         implicit none
         integer :: nx, ny, kxp, kyp, kstrt, ndim, nxv, nyv
         integer, dimension(2) :: gp_fn, gp_gn
         end subroutine
      end interface
!
      interface
         subroutine cgpusum2(gp_a,gp_sa,nx)
         implicit none
         integer :: nx
         integer, dimension(2) :: gp_a, gp_sa
         end subroutine
      end interface
!
      end module


    !!!!!!!!!!!!!!!!!!!!!!!!!Main parogram for call!!!!!!!!!!!!!!!!!!!!
    subroutine forcchn2(fj,yxc2,dayout,yearout,ntrees,ny0,ny,ndays,lat,lon,ele,tmax,tmin,tmean,dayl1,prec,ra,rh,wind,sfc,pwp,vw,sc0,sn0,silt,sand,class,evergr0,deci0,lai0,co2)
    !!!!output: fj: the phenology dates, which included the start time of leaf growth (SOS) and the end time of leaf growth (EOS)
    !!!!output: yxc2: the allocation parameter of each soil pool, which can be used as input instead of the initial soil allocation parameters
    !!!!output: dayout: the daily carbon dynamics, which included above- and belowground biomass, gross primary productivity (GPP), above- and belowground respiration, soil heterotrophic respiration, litter-fall biomass, and soil carbon
    !!!!output: yearout: the yearly carbon dynamics
    !!!!input: the variables can be found in the example run
    integer ny,ny0,ndays,class,iderr,ii3,kdays,nplot
    real ta,dmean,dayl1(ny,366),ds,yb
    real lat,lon,ele,tmax(ny,366),tmin(ny,366), prec(ny,366),ra(ny,366),rh(ny,366),wind(ny,366),sfc,pwp,vw,sc,snn,lai,evergr,deci,co2(ny,366),re_soil,tt(366),tmean(ny,366),tmean1,gpp(ndays,ntrees),nscfast(ny,2),nscd(ndays,7)
    real sc1,sn1,lai1,evergr1,deci1,sc0,sn0,lai0,evergr0,deci0
    real dayout(ndays,8),yearout(ny,8),key(900,3),soc,w_soil1(4)
    real gaparea,par_soil(8),c_soil(15),n_soil(15),l_soil(15),w_soil(4),npp_c,npp_n,fall_c,fall_n,yxc2(11),snc0,forcn(600,19),par_tree(28,9),hold0,wata,parcano(120)
    real tp_resp,tl_resp,t_photo(9),ts_resp,outlai1(999),dry_photo(9),dry_lit,dry_hum,phenfac(366),phenot
    real c_out,n_out,cout(8),hr,year(ny,8),day(ndays,8),outlai(999),fall11(ndays,4),phe1(366),tb,sn11,ypheno1
    real nppmean10,soilresp10,fall10,treeresp10,nepend(12),no3
    integer iy,id,IDUM,nn,ndy,ii,ij,nd1(12),nd2(12),nd(12),lyear
    real nppmean0,soilresp0,fall0,treeresp0,leafwt,leafwt0
    real pp,son,ttc(4),zttc(ndays,4),nva,znva(ny),n_soil11(ny,15),znl11,znl12(ny,366),nav(ndays,15),nim,nim1(ndays),rn1(ndays),no31(ndays),bdh(ny,ntrees), th(ny,ntrees),zbdh(ny,ntrees),everytree(ntrees,5),sw(366),htmax,htmax1,petd1(366)
    real gn,gs,gd,gr,sn,ss,sd,sr,fn,fs,fd,fr,snc,ssc,sdc,src,nscstart(600),ypheno(366),para(1,6),sn00(366,1)
    real xs0,xn0,ne(ntrees),nwa(ntrees),ncell(ntrees),xs(ntrees),xn(ntrees),ff1(ntrees,366),ff2(ntrees,366),ff3(ntrees,366),ff4(ntrees,366),ff5(ntrees,366),ff6(ntrees,366),ff7(ntrees,366),ff8(ntrees,366),ff9(ntrees,366),nsc0(ntrees),ff10(ntrees,366),treeage0(ntrees),tran(ntrees),ht(ntrees,1)
    integer iii,jjj,fj(ny,3),num,dbhnum,itree,woodp(ny,2)
    real ls(ntrees),ls0(ntrees),ln(ntrees),ln0(ntrees),ld0,ldy(ndays,1),ldp(ny,366),ld1(366,ny),lsp,lnp,ld(ny,366,ntrees),ld11(ntrees),pheno12(366,1),tever
    real fj1,fj2,fj3,fj4,fj5,gpp1(ndays,ntrees),npp,npp1(ndays,1)
    real ls01,ln01,leafn(ndays,3),ta1,tb1,ds1
    real bb1(100),dinc1(366,50),dinc2(ny*366,50),dinc3(100,50)
    real dorm(ntrees),dist(ntrees),gmax
    integer time(ntrees)
    data nd1/31,28,31,30,31,30,31,31,30,31,30,31/
    data nd2/31,28,31,30,31,30,31,31,30,31,30,31/
    real,allocatable :: leafage(:,:,:)
    real dd11(366,ntrees),d11(366,ntrees),cfj(366,3)

    gaparea=400.0
    ntrees=0
    nplot=1
    call param(par_tree)
    znl12=0.0
    leafwt0=0.0
    nppmean10=0.0
    soilresp10=0.0
    fall10=0.0
    treeresp10=0.0
    nppmean0=0.0
    soilresp0=0.0
    fall0=0.0
    treeresp0=0.0
    n_soil=0.0
    do kk=1,12
        nepend(kk)=0.0
    end do
    do id=1,ndays
        do il=1,8
            dayout(id,il)=0.0
        end do
    end do
    do iy=1,ny
        do il=1,8
            yearout(iy,il)=0.0
        end do
    end do
    do kk=1,ny*12
        outlai1(kk)=0.0
    end do
    gmax=0.15
    do iplot=1,nplot

        !!!!!!!!!!!!!!!!!!!!!!initialization!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        hr=2.0
        sc1=sc0
        sn1=sn0
        evergr1=evergr0
        deci1=deci0
        !lai1=max(min(lai0,7.0),0.5)

        !!!!!!!!!!!!!!!!vegetation initialization
        call initialer2(trh,sc1,sn1,sfc,pwp,vw,silt,sand,class,evergr1,deci1,lai0,lat,ele,gaparea,par_soil,c_soil,n_soil,l_soil,w_soil,hold0,wata,forcn,ntrees,par_tree,yxc2,tever)

        do id=1,ntrees
            nsc0(id)=forcn(id,9)
            treeage0(id)=treeage(forcn(id,2)*2.0,forcn(id,3))
        enddo

        htmax1=0.0
        if (ntrees.eq.1)then
            htmax=forcn(1,3)
        else
            do id=1,ntrees-1
                htmax=max(forcn(id,3),forcn(id+1,3))
                htmax1=max(htmax,htmax1)
            enddo
        endif

        call zeros2(ny,8,year)
        call zeros2(ndays,8,day)

        !!!!!!!!!!!!!predict phenology
        ta1=0.0
        tb1=0.0
        ds1=0.0
        if (fj(1,2).ne.0)then
            do kk=1,fj(1,2)
               ta1=ta1+tmean(1,kk)
            enddo
            ta1=ta1/fj(1,2)
        else
            ta1=0.0
        endif
        if (fj(1,3).ne.0)then
            do kk=1,fj(1,3)
               tb1=tb1+tmean(1,kk)
               ds1=ds1+dayl1(1,kk)
            enddo
            tb1=tb1/fj(1,3)
            ds1=ds1/fj(1,3)
        else
            tb1=0.0
            ds1=0.0
        endif
        ta=0.0/-1.0692*ta1!!!!the effective temperature threshold of spring
        tb=30.0/8.6060*tb1!!!!the effective temperature threshold of autumn
        ds=12.5/12.0*ds1!!!!the effective photoperiod threshold of autumn
        call pheno11(tmean(1,:),ta,pheno12)
        call phe(phe1,tmean(1,:),dayl1(1,:),tb,ds)
        sn11=-pheno12(fj(1,2),1)!!!!the critical heat theshold of spring
        dmean=pheno12(fj(1,3),1)+sn11!!!!the critical heat theshold of autumn
        yb=phe1(fj(1,3))
        snc0=0.0
        fj=0
        do iy=1,ny
            nn=iy+ny0-1

            if (mod(nn,4).eq.0) then
                ndy=366
            else
                ndy=365
            endif

            do it=1,900
                key(it,1)=0.0
                key(it,2)=0.0
            end do
            do it=1,8
                year(iy,it)=0.0
            end do

            do id=1,ndy
                tt(id)=tmean(iy,id)
            end do
            call pheno(tt,phenfac)
            lyear=0.0
            do id =1,ndy
                lyear=lyear+phenfac(id)
            end do
            lai0=tever!!!!!!!!!!!!

            call pheno11(tmean(iy,:),ta,pheno12)
            call phe(phe1,tmean(iy,:),dayl1(iy,:),tb,ds)
            pheno12=pheno12+sn11

        do id=1,ndy
            if (pheno12(id,1).ge.0.0)then
                fj(iy,2)=id!!!!!!!!!!!!!!!SOS(unit: doy)
                exit
            endif
        enddo
        do id=1,ndy
            if (phe1(id).le.yb)then
                fj(iy,3)=min(365,id)!!!!!!!!!!!!!!!!!EOS(unit: doy)
            endif
        enddo
        if(fj(iy,2)>=fj(iy,3))then
            goto 30
        endif
        enddo
        do iy=1,ny
           fj(iy,1)=iy+ny0-1
        enddo
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!begin to predict carbon dynamics and tree growth
        ii=0
        do iy=1,ny
            nn=iy+ny0-1
            if (mod(nn,4).eq.0) then
                ndy=366
            else
                ndy=365
            endif
            do it=1,900
                key(it,1)=0.0
                key(it,2)=0.0
            end do
            do it=1,8
                year(iy,it)=0.0
            end do
            do id=1,ndy
                tt(id)=tmean(iy,id)
            end do
            call pheno(tt,phenfac)
            phenfac(1:fj(iy,2))=0.0
            phenfac(fj(iy,2)+1:fj(iy,3))=1.0
            phenfac(fj(iy,3)+1:366)=0.0

            call pheno(tt,phenfac)
            lyear=0.0
            do id =1,ndy
                lyear=lyear+phenfac(id)
            end do

            call pheno11(tmean(iy,:),ta,pheno12)
            snc0=pheno12(fj(iy,3),1)+sn11
            sn00=pheno12+sn11

            ypheno=0.0
            ypheno(fj(iy,2):fj(iy,3))=1.0
            lai0=tever
            num=ndy
            allocate(leafage(ntrees,2,num))
            leafage=0.0
            sn=0.0

            !!!!calculate on daily step
            do id=1,ndy
                ii=ii+1
                do ij=1,ntrees
                    ht(ij,1)=forcn(ij,3)
                enddo
                w_soil1=w_soil
                if (iy.eq.1) then
                    !!!soil initialization
                    call newenv(id,lat,ele,lai0,tmax(iy,id),tmin(iy,id),tmean(iy,id),prec(iy,id),ra(iy,id),rh(iy,id),wind(iy,id),w_soil,par_soil,parmax,dl,tday,t_photo,tave,tp_resp,ts_resp,tl_resp,dry_photo,dry_lit,dry_hum,par_tree,runoff,aet_pet,rn,htmax,pwp,petd) !!!!!!!!tp,tl,ts
                else
                    call newenv(id,lat,ele,lai,tmax(iy,id),tmin(iy,id),tmean(iy,id),prec(iy,id),ra(iy,id),rh(iy,id),wind(iy,id),w_soil,par_soil,parmax,dl,tday,t_photo,tave,tp_resp,ts_resp,tl_resp,dry_photo,dry_lit,dry_hum,par_tree,runoff,aet_pet,rn,htmax,pwp,petd)
                endif
                sw(id)=w_soil(1)+w_soil(2)
                sw(id)=min(sw(id),sfc)
                petd1(id)=petd

                !!!!predict phenology of leaf, fine roots, and woods
                call gf(ny,iy,id,tmean(iy,id),tmean(iy,id),sw(id),par_soil,sfc,gn,gs,gd,gr,sn,ss,sd,sr,fn,fs,fd,fr,snc0,ssc,sdc,src,fj)
                call phenoleaf(tmean(iy,id),sn00(id,1),snc0,fn,gn)
                !rn1(ii)=rn
                tmean1=tmean(iy,id)

                !!!!predict soil dynamics
                call soil_cn1(tmean1,sw(id),iy,id,sand,runoff,c_soil,n_soil,ph,l_soil,par_soil,tl_resp,dry_lit,dry_hum,re_soil,c_out,n_out,nim,no3)!!!!!!!!!!!!!!!!!!!
                nim1(ii)=nim
                no31(ii)=no3
                day(ii,6)=re_soil

                !!!!allocation of Effective Radiation (layer by layer)
                call newphenology(forcn,ntrees,tday,par_tree,parmax,gaparea,lai,parcano,key,sn,ss,sd,sr,snc0,ssc,sdc,src,phenfac(id))

                !!!!!calculate transpiration
                call tran1(id,lat,ele,ntrees,ht,parcano,lai,tmax(iy,id),tmin(iy,id),tmean(iy,id),prec(iy,id),rh(iy,id),wind(iy,id),tran,htmax,pwp,w_soil1)

                if (mod(id,30).eq.15) then
                    id1=int(id/30)+1+(ny-1)*12
                    outlai(id1)=lai
                endif

                !!!!co2 fertilization
                c=(co2(iy,id)-350.0)/(co2(iy,id)+700.0)+1.0
                phenot=phenfac(id)
                ypheno1=ypheno(id)

                !!!!tree daily growth and carbon dynamics
                call newdaily_c(lat,ndays,ii,id,iy,tmax(iy,id),tmin(iy,id),sw(id),silt,sand,sfc,tran,ny,num,tmean1,ntrees,dl,c,forcn,t_photo,dry_photo,tp_resp,tl_resp,c_soil,n_soil,l_soil,par_tree,parcano,gaparea, npp_c,npp_n,fall_c,fall_n,phenot,cout,leafwt,gn,fn,fs,fd,fr,ld11,ls,ln,ne,nwa,ncell,xn,xs,ff1,ff2,ff3,ff4,ff5,ff6,ff7,ff8,ff9,ff10,fj,leafage,nsc0,treeage0,bb1,time,dorm,dist,dd11,d11,cfj,key,dinc1,dinc3,gpp1,ls0,nscstart,woodp,ttc,nscfast,nscd,wt1,npp,ypheno1,leafn)
                if (iy.eq.ny) then
                    leafwt0=max(leafwt,leafwt0)
                end if
                npp1(ii,1)=npp
                fall11(ii,1)=ttc(1)/gaparea
                fall11(ii,2)=ttc(2)/gaparea
                fall11(ii,3)=ttc(3)/gaparea
                fall11(ii,4)=ttc(4)/gaparea
                day(ii,1)=cout(1)/gaparea
                day(ii,2)=cout(2)/gaparea
                day(ii,3)=cout(3)/gaparea
                day(ii,4)=cout(4)/gaparea
                day(ii,5)=cout(5)/gaparea
                day(ii,7)=cout(7)/gaparea
                day(ii,8)=0.0
                do ij=1,11
                    day(ii,8)=day(ii,8)+c_soil(ij)
                end do
                year(iy,3)=year(iy,3)+day(ii,3)
                year(iy,4)=year(iy,4)+day(ii,4)
                year(iy,5)=year(iy,5)+day(ii,5)
                year(iy,6)=year(iy,6)+day(ii,6)
                year(iy,7)=year(iy,7)+day(ii,7)
                do ij=1,15
                    nav(ii,ij)=n_soil(ij)
                enddo
                !write(*,*) id
            end do!!!!end the daily step

            do it=1,900
                key(it,1)=key(it,1)/lyear
                key(it,2)=key(it,2)/lyear
            end do

            !!!!!!!!!!!!!!!calculate on yearly step
            call grow2(ntrees,par_tree,forcn,l_soil,c_soil,n_soil,cout,key,gaparea,coutn)
            year(iy,1)=max(cout(1)/gaparea,0.001)
            year(iy,2)=max(cout(2)/gaparea,0.001)
            year(iy,8)=max(cout(8),0.001)
            deallocate(leafage)
        end do

        !!!!!!!!!!!!!!!!output results
        do il=1,8
            do iy=1,ny
                yearout(iy,il)=yearout(iy,il)+year(iy,il)/nplot
            end do
            do id=1,ndays
                dayout(id,il)=dayout(id,il)+day(id,il)/nplot
            end do
        end do

        do ii3=1,11
            yxc2(ii3)=c_soil(ii3)/sum(c_soil(1:11))
        end do
30  end do!!!!end the calculation
    return
    end


      SUBROUTINE DERIV(GEO,GRAD)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES'
      DIMENSION GRAD(*), GEO(3,*)
************************************************************************
*
*    DERIV CALCULATES THE DERIVATIVES OF THE ENERGY WITH RESPECT TO THE
*          INTERNAL COORDINATES. THIS IS DONE BY FINITE DIFFERENCES.
*
*    THE MAIN ARRAYS IN DERIV ARE:
*        LOC    INTEGER ARRAY, LOC(1,I) CONTAINS THE ADDRESS OF THE ATOM
*               INTERNAL COORDINATE LOC(2,I) IS TO BE USED IN THE
*               DERIVATIVE CALCULATION.
*        GEO    ARRAY \GEO\ HOLDS THE INTERNAL COORDINATES.
*        GRAD   ON EXIT, CONTAINS THE DERIVATIVES
*
************************************************************************
      COMMON / EULER/ TVEC(3,3), ID
      COMMON /OKMANY/ ISOK
      COMMON /GEOVAR/ NVAR,LOC(2,MAXPAR), IDUMY, DUMMY(MAXPAR)
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM),
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA,
     2                NCLOSE,NOPEN,NDUMY,FRACT
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM),
     1NA(NUMATM),NB(NUMATM),NC(NUMATM)
      COMMON /GRAVEC/ COSINE
      COMMON /GEOSYM/ NDEP, LOCPAR(MAXPAR), IDEPFN(MAXPAR),
     1LOCDEP(MAXPAR)
      COMMON /PATH  / LATOM,LPARAM,REACT(200)
      COMMON /UCELL / L1L,L2L,L3L,L1U,L2U,L3U
      COMMON /XYZGRA/ DXYZ(9*NUMATM)
      COMMON /ENUCLR/ ENUCLR
      COMMON /NUMCAL/ NUMCAL
      COMMON /HMATRX/ H(MPACK)
      COMMON /ATHEAT/ ATHEAT
      COMMON /KEYWRD/ KEYWRD
      COMMON /ERRFN / ERRFN(MAXPAR), AICORR(MAXPAR)
      COMMON /WORK3 / WORK2(4*MPACK)
      COMMON /GENRAL/ COORD(3,NUMATM), COLD(3,NUMATM*3), GOLD(MAXPAR),
     1 XPARAM(MAXPAR)
      CHARACTER*241 KEYWRD, LINE*80, GETNAM*80
      DIMENSION CHANGE(3), XJUC(3), AIDREF(MAXPAR)
      SAVE SCF1, HALFE, IDELTA, SLOW
      LOGICAL DEBUG, HALFE, SCF1, CI, PRECIS, SLOW, AIC, NOANCI,
     1AIFRST, ISOK, GEOOK, INT
      DATA ICALCN /0/
      IF(ICALCN.NE.NUMCAL) THEN
         AIFRST= (INDEX(KEYWRD,'RESTART').EQ.0)
         DEBUG = (INDEX(KEYWRD,'DERIV') .NE. 0)
         PRECIS= (INDEX(KEYWRD,'PREC') .NE. 0)
         INT   = (INDEX(KEYWRD,' XYZ') .EQ. 0)
         GEOOK = (INDEX(KEYWRD,'GEO-OK') .NE. 0)
         CI    = (INDEX(KEYWRD,'C.I.') .NE. 0)
         SCF1  = (INDEX(KEYWRD,'1SCF') .NE. 0)
         AIC=(INDEX(KEYWRD,'AIDER').NE.0)
         ICAPA=ICHAR('A')
         ILOWA=ICHAR('a')
         ILOWZ=ICHAR('z')
         IF(AIC.AND.AIFRST)THEN
            OPEN(UNIT=5,FILE=GETNAM('FOR005'),STATUS='OLD',BLANK='ZERO')
            REWIND 5
C
C  ISOK IS SET FALSE: ONLY ONE SYSTEM ALLOWED
C
            ISOK=.FALSE.
            DO 10 I=1,3
   10       READ(5,'(A)')LINE
            DO 30 J=1,1000
               READ(5,'(A)',END=40,ERR=40)LINE
************************************************************************
               DO 20 I=1,80
                  ILINE=ICHAR(LINE(I:I))
                  IF(ILINE.GE.ILOWA.AND.ILINE.LE.ILOWZ) THEN
                     LINE(I:I)=CHAR(ILINE+ICAPA-ILOWA)
                  ENDIF
   20          CONTINUE
************************************************************************
   30       IF(INDEX(LINE,'AIDER').NE.0)GOTO 60
   40       WRITE(6,'(//,A)')' KEYWORD "AIDER" SPECIFIED, BUT NOT'
            WRITE(6,'(A)')' PRESENT AFTER Z-MATRIX.  JOB STOPPED'
            STOP
   50       WRITE(6,'(//,A)')'  FAULT IN READ OF AB INITIO DERIVATIVES'
            WRITE(6,'(A)')'  DERIVATIVES READ IN ARE AS FOLLOWS'
            WRITE(6,'(6F12.6)')(AIDREF(J),J=1,I)
            STOP
   60       CONTINUE
            IF(NATOMS.GT.2)THEN
               J=3*NATOMS-6
            ELSE
               J=1
            ENDIF
            READ(5,*,END=50,ERR=50)(AIDREF(I),I=1,J)
            WRITE(6,'(/,A,/)')
     1' AB-INITIO DERIVATIVES IN KCAL/MOL/(ANGSTROM OR RADIAN)'
            WRITE(6,'(5F12.6)')(AIDREF(I),I=1,J)
            DO 70 I=1,NVAR
               IF(LOC(1,I).GT.3)THEN
                  J=3*LOC(1,I)+LOC(2,I)-9
               ELSEIF(LOC(1,I).EQ.3)THEN
                  J=LOC(2,I)+1
               ELSE
                  J=1
               ENDIF
   70       AIDREF(I)=AIDREF(J)
            WRITE(6,'(/,A,/)')
     1' AB-INITIO DERIVATIVES FOR VARIABLES'
            WRITE(6,'(5F12.6)')(AIDREF(I),I=1,NVAR)
            IF(NDEP.NE.0)THEN
               DO 90 I=1,NVAR
                  SUM=AIDREF(I)
                  DO 80 J=1,NDEP
                     IF(LOC(1,I).EQ.LOCPAR(J).AND.(LOC(2,I).EQ.IDEPFN(J)
     1.OR.LOC(2,I).EQ.3.AND.IDEPFN(J).EQ.14)) AIDREF(I)=AIDREF(I)+SUM
   80             CONTINUE
   90          CONTINUE
               WRITE(6,'(/,A,/)')
     1' AB-INITIO DERIVATIVES AFTER SYMMETRY WEIGHTING'
               WRITE(6,'(5F12.6)')(AIDREF(J),J=1,NVAR)
            ENDIF
         ENDIF
         ICALCN=NUMCAL
         IF(INDEX(KEYWRD,'RESTART') .EQ. 0) THEN
            DO 100 I=1,NVAR
  100       ERRFN(I)=0.D0
         ENDIF
         GRLIM=0.01D0
         IF(PRECIS)GRLIM=0.0001D0
         HALFE = (NOPEN.GT.NCLOSE.AND.FRACT.NE.2.D0.AND.FRACT.NE.0.D0
     1 .OR. CI)
         IDELTA=-7
*
*   IDELTA IS A MACHINE-PRECISION DEPENDANT INTEGER
*
         CHANGE(1)= 10.D0**IDELTA
         CHANGE(2)= 10.D0**IDELTA
         CHANGE(3)= 10.D0**IDELTA
C
C    CHANGE(I) IS THE STEP SIZE USED IN CALCULATING THE DERIVATIVES.
C    FOR "CARTESIAN" DERIVATIVES, CALCULATED USING DCART,AN
C    INFINITESIMAL STEP, HERE 0.000001, IS ACCEPTABLE. IN THE
C    HALF-ELECTRON METHOD A QUITE LARGE STEP IS NEEDED AS FULL SCF
C    CALCULATIONS ARE NEEDED, AND THE DIFFERENCE BETWEEN THE TOTAL
C    ENERGIES IS USED. THE STEP CANNOT BE VERY LARGE, AS THE SECOND
C    DERIVITIVE IN FLEPO IS CALCULATED FROM THE DIFFERENCES OF TWO
C    FIRST DERIVATIVES. CHANGE(1) IS FOR CHANGE IN BOND LENGTH,
C    (2) FOR ANGLE, AND (3) FOR DIHEDRAL.
C
      ENDIF
      IF(NVAR.EQ.0) RETURN
      IF(DEBUG)THEN
         WRITE(6,'('' GEO AT START OF DERIV'')')
         WRITE(6,'(F19.5,2F12.5)')((GEO(J,I),J=1,3),I=1,NATOMS)
      ENDIF
      GNORM=0.D0
      DO 110 I=1,NVAR
         GOLD(I)=GRAD(I)
         XPARAM(I)=GEO(LOC(2,I),LOC(1,I))
  110 GNORM=GNORM+GRAD(I)**2
      GNORM=SQRT(GNORM)
      SLOW=.FALSE.
      NOANCI=.FALSE.
      IF(HALFE) THEN
         NOANCI=(INDEX(KEYWRD,'NOANCI').NE.0 .OR. NOPEN.EQ.NORBS)
         SLOW=(NOANCI.AND.(GNORM .LT. GRLIM .OR. SCF1))
      ENDIF
      IF(NDEP.NE.0) CALL SYMTRY
      CALL GMETRY(GEO,COORD)
C
C  COORD NOW HOLDS THE CARTESIAN COORDINATES
C
      IF(HALFE.AND..NOT.NOANCI) THEN
         IF(DEBUG)WRITE(6,*) 'DOING ANALYTICAL C.I. DERIVATIVES'
         CALL DERNVO(COORD,DXYZ)
      ELSE
         IF(DEBUG)WRITE(6,*) 'DOING VARIATIONALLY OPIMIZED DERIVATIVES'
         CALL DCART(COORD,DXYZ)
      ENDIF
      IJ=0
      DO 150 II=1,NUMAT
         DO 140 IL=L1L,L1U
            DO 140 JL=L2L,L2U
               DO 140 KL=L3L,L3U
C$DOIT ASIS
                  DO 120 LL=1,3
  120             XJUC(LL)=COORD(LL,II)+TVEC(LL,1)*IL+TVEC(LL,2)*JL+TVEC
     1(LL,3)*KL
                  IJ=IJ+1
C$DOIT ASIS
                  DO 130 KK=1,3
                     COLD(KK,IJ)=XJUC(KK)
  130             CONTINUE
  140    CONTINUE
  150 CONTINUE
      STEP=CHANGE(1)
      CALL JCARIN (COORD,XPARAM,STEP,PRECIS,WORK2,NCOL)
      CALL MXM (WORK2,NVAR,DXYZ,NCOL,GRAD,1)
      IF (PRECIS) THEN
         STEP=0.5D0/STEP
      ELSE
         STEP=1.0D0/STEP
      ENDIF
      DO 160 I=1,NVAR
  160 GRAD(I)=GRAD(I)*STEP
C
C  NOW TO ENSURE THAT INTERNAL DERIVATIVES ACCURATELY REFLECT CARTESIAN
C  DERIVATIVES
C
      IF(INT.AND. .NOT. GEOOK .AND. NVAR.GE.NUMAT*3-6.AND.ID.EQ.0)THEN
C
C  NUMBER OF VARIABLES LOOKS O.K.
C
         SUM=DOT(GRAD,GRAD,NVAR)
         IF(SUM.LT.2.D0.AND.DOT(DXYZ,DXYZ,3*NUMAT).GT.MAX(4.D0,SUM*4.D0)
     1)THEN
C
C OOPS, LOOKS LIKE AN ERROR.
C
            DO 170 I=1,NVAR
               J=XPARAM(I)/3.141D0
               IF(LOC(2,I).EQ.2.AND.LOC(1,I).GT.3.AND.
     1 ABS(XPARAM(I)-J*3.1415926D0).LT.0.005D0 )THEN
C
C  ERROR LOCATED, BUT CANNOT CORRECT IN THIS RUN
C
                  WRITE(6,'(//,3(A,/),I3,A)')
     1' INTERNAL COORDINATE DERIVATIVES DO NOT REFLECT',
     2' CARTESIAN COORDINATE DERIVATIVES',
     3' TO CORRECT ERROR, INCREASE DIHEDRAL OF ATOM',LOC(1,I),
     4' BY 90 DEGREES'
                  WRITE(6,'(//,A)')'     CURRENT GEOMETRY'
                  CALL GEOUT(6)
                  STOP
               ENDIF
  170       CONTINUE
         ENDIF
      ENDIF
C
C  THIS CODE IS ONLY USED IF THE KEYWORD NOANCI IS SPECIFIED
      IF(SLOW)THEN
         IF(DEBUG)WRITE(6,*) 'DOING FULL SCF DERIVATIVES'
         CALL DERITR(ERRFN,GEO)
C
C THE ARRAY ERRFN HOLDS THE EXACT DERIVATIVES MINUS THE APPROXIMATE
C DERIVATIVES
         DO 180 I=1,NVAR
  180    ERRFN(I)=ERRFN(I)-GRAD(I)
      ENDIF
      COSINE=DOT(GRAD,GOLD,NVAR)/
     1SQRT(DOT(GRAD,GRAD,NVAR)*DOT(GOLD,GOLD,NVAR)+1.D-20)
      DO 190 I=1,NVAR
  190 GRAD(I)=GRAD(I)+ERRFN(I)
      IF(AIC)THEN
         IF(AIFRST)THEN
            AIFRST=.FALSE.
            DO 200 I=1,NVAR
  200       AICORR(I)=-AIDREF(I)-GRAD(I)
         ENDIF
C#         WRITE(6,'('' GRADIENTS BEFORE AI CORRECTION'')')
C#         WRITE(6,'(10F8.3)')(GRAD(I),I=1,NVAR)
         DO 210 I=1,NVAR
  210    GRAD(I)=GRAD(I)+AICORR(I)
      ENDIF
  220 IF(DEBUG) THEN
         WRITE(6,'('' GRADIENTS'')')
         WRITE(6,'(10F8.3)')(GRAD(I),I=1,NVAR)
         IF(SLOW)THEN
            WRITE(6,'('' ERROR FUNCTION'')')
            WRITE(6,'(10F8.3)')(ERRFN(I),I=1,NVAR)
         ENDIF
      ENDIF
      IF(DEBUG)
     1WRITE(6,'('' COSINE OF SEARCH DIRECTION ='',F30.6)')COSINE
      RETURN
      END


*
*     --------------------------------------------------------------
*     R L S P 4 A
*     --------------------------------------------------------------
*                                                                  *
*
      SUBROUTINE RLSP4A(K,JA1,JA2,JA3,K1,K2,K3,IRE,IAT,REC)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
      COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS
      COMMON/MEDEFN/IHSH,NJ(16),LJ(16),NOSH1(16),NOSH2(16),J1QN1(31,3),
     :     J1QN2(31,3),IJFUL(16)
*
      REC=ONE/DSQRT(DBLE(J1QN1(JA1,K)*J1QN1(JA2,K)*J1QN1(JA3,K)))
      ISKR=JA3-JA2
      IF(ISKR.GT.1) THEN
        IAT=0
        CALL DLSA3(K,JA2,JA3,K3,IRE,IAT,RE)
        IF(IAT.EQ.0)RETURN
        REC=RE*REC
      ENDIF
*
      IAT=0
      CALL DLSA4(K,JA1,JA2,K1,K2,K3,IRE,IAT,RE)
      IF(IAT.EQ.0)RETURN
      REC=RE*REC
*
      IF(JA1.EQ.1.AND.JA2.EQ.2)RETURN
*
      IAT=0
      CALL DLSA1(K,JA1,K1,IRE,IAT,RE)
      IF(IAT.EQ.0)RETURN
      REC=RE*REC
*
      ISKR=JA2-JA1
      IF(JA1.EQ.1)ISKR=JA2-1-JA1
      IF(ISKR.LE.1)RETURN
      IAT=0
      CALL DLSA3(K,JA1,JA2,K1,IRE,IAT,RE)
      REC=RE*REC
      RETURN
      END


      subroutine forred(ia,ja,d,b,ist)
c     implicit double precision (a-h,o-z)                                    dp
c
c     reduce load vector block by block
c
      dimension ia(4),ja(4),d(*),b(*)
      common/fissn0/neq,mxw,no,n1,nfissl(3)
      common/fissn2/nwb,nblk,nwu,meb,mxc,mpr,mch,ia1,ia2
      common/fissl4/je,jc
      common/double/iprec,ncpw,unit
c
c     note- this routine has been vectorized for the cray-1. statements
c     flagged with "cray" in columns 74-77 apply to the cray only.
c     statements flagged with "ansi" in columns 74-77 are ansi standard
c     fortran equivalent to the cray coding.
c
      n1da=0
      nw=nwb*iprec
      n=1
      if((n.eq.nblk).and.(ist.lt.0)) go to 101
c.... retrieve block 1 from disk
      call rdabsf(n1,ia,nw,n1da,ioerr)
   20 continue
      call riosta (n1)
      if(n.eq.nblk) go to 101
c.... retrieve block n+1 from disk
      n1da=n1da+nw
      call rdabsf(n1,ja,nw,n1da,ioerr)
c.... reduce b using block n
  101 je=ia(2)
      jc=ia(3)
      call recol(-1,1,jc,ia(4),ia(4),b(je+1),d(je+1))
      if(n.eq.nblk) go to 201
      call riosta (n1)
      if((n+1).eq.nblk) go to 121
c.... retrieve block n+2 from disk
      n1da=n1da+nw
      call rdabsf(n1,ia,nw,n1da,ioerr)
c.... reduce b using block n+1
  121 je=ja(2)
      jc=ja(3)
      call recol(-1,1,jc,ja(4),ja(4),b(je+1),d(je+1))
      n=n+2
      if(n.le.nblk) go to 20
c.... divide reduced load vector by diagonal (inverses are stored)
  201 continue
      do 300 j=1,neq
c     b(j)=cvmgz(b(j),d(j)*b(j),d(j))                                   cray1
      if(d(j).ne.0)b(j)=d(j)*b(j)                                       vax75
  300 continue
      return
      end


version https://git-lfs.github.com/spec/v1
oid sha256:79e9d25ed00a66880c4bd3413653d370df2db0bae3163e8ef7a82bfa70aa86f7
size 2962