module create_model
    use NScool_def
    use constants_def, only: dp
    use constants_lib
    use nucchem_def
    use nucchem_lib
    use superfluid_lib
    use dStar_eos_lib
    use dStar_crust_def
    use dStar_crust_lib
    use dStar_atm_def
    use dStar_atm_lib
    use NScool_crust_tov

    integer, parameter :: number_table_pts = 128
    real(dp), parameter :: lgT_tab_min = 7.0
    real(dp), parameter :: lgT_tab_max = 10.0

contains

    subroutine do_create_crust_model(id, ierr)
        use exceptions_lib
        integer, intent(in) :: id
        integer, intent(out) :: ierr
        type(NScool_info), pointer :: s
        type(failure) :: zone_error=failure(scope='do_create_crust_model', &
        &   message='setting crust zones')
        type(failure) :: composition_error= &
        &   failure(scope='do_create_crust_model', &
        &   message='setting crust composition')
        type(failure) :: transport_error=failure( &
        &   scope='do_create_crust_model',message='setting crust transport')
        type(assertion) :: got_pointer=assertion(scope='do_create_crust_model')

        call get_NScool_info_ptr(id,s,ierr)
        call got_pointer% assert(ierr==0)

        call do_setup_crust_zones(s, ierr)
        if (zone_error% raised(ierr)) return

        call do_setup_crust_composition(s, ierr)
        if (composition_error% raised(ierr)) return

        call do_setup_crust_transport(s, ierr)
        if (transport_error% raised(ierr)) return
    end subroutine do_create_crust_model

    subroutine do_setup_crust_zones(s, ierr)
        use, intrinsic :: iso_fortran_env, only: error_unit, output_unit
        use exceptions_lib
        use constants_def
        use nucchem_lib
        use superfluid_lib
        use dStar_eos_lib
        use dStar_crust_def
        use dStar_crust_lib
        use NScool_private_def, only: dStar_data_dir
        use NScool_crust_tov
        use storage

        type(NScool_info), pointer :: s
        type(tov_model_type), pointer :: stov
        integer, intent(out) :: ierr
        real(dp), dimension(:), pointer :: y
        real(dp) :: Plight
        type(alert) :: status=alert(scope='do_setup_crust_zones')
        type(failure) :: nucchem_error=failure(scope='do_setup_crust_zones', &
        &   message='initializing nucchem module')
        type(failure) :: superfluid_error=failure(scope='do_setup_crust_zones', &
        &   message='starting superfluid module')
        type(failure) :: gap_error=failure(scope='do_setup_crust_zones', &
        &   message='loading gaps')
        type(failure) :: eos_error=failure(scope='do_setup_crust_zones', &
        &   message='starting eos module')
        type(failure) :: crust_error=failure(scope='do_setup_crust_zones', &
        &   message='starting crust module')
        type(failure) :: crust_table_error=failure(scope='do_setup_crust_zones', &
        &   message='setting crust zones')
        type(failure) :: atm_error=failure(scope='do_setup_crust_zones', &
        &   message='starting atmosphere module')
        type(failure) :: tov_error=failure(scope='do_setup_crust_zones', &
        &   message='integrating TOV eqns')
        type(failure) :: atm_load_error=failure(scope='do_setup_crust_zones', &
        &   message='loading atm table')

        call status% report('Initializing nuclides')
        call nucchem_init(trim(dStar_data_dir),ierr)
        if (nucchem_error% raised(ierr)) return

        call status% report('Loading superfluid gaps')
        call sf_startup(trim(dStar_data_dir),ierr)
        if (superfluid_error% raised(ierr)) return
        call sf_load_gaps(trim(s% which_proton_1S0_gap), trim(s% which_neutron_1S0_gap), &
            & trim(s% which_neutron_3P2_gap), ierr)
        if (gap_error% raised(ierr)) return
        sf_scale(1:max_number_sf_types) = s% scale_sf_critical_temperatures

        call status% report('Setting EOS options')
        call dStar_eos_startup(trim(dStar_data_dir))
        s% eos_handle = alloc_dStar_eos_handle(ierr)
        if (eos_error% raised(ierr)) return
        ! switch off the warnings about quantum effects
        call dStar_eos_set_controls(s% eos_handle,suppress_warnings=.TRUE.)
        if (s% eos_gamma_melt_pt > 0.0)  &
        & call dStar_eos_set_controls(s% eos_handle,gamma_melt_pt=s% eos_gamma_melt_pt)
        if (s% eos_rsi_melt_pt > 0.0)  &
        & call dStar_eos_set_controls(s% eos_handle,rsi_melt_pt=s% eos_rsi_melt_pt)
        if (s% eos_nuclide_abundance_threshold > 0.0)  &
        & call dStar_eos_set_controls(s% eos_handle,nuclide_abundance_threshold=s% eos_nuclide_abundance_threshold)
        if (s% eos_pasta_transition_in_fm3 > 0.0)  &
        & call dStar_eos_set_controls(s% eos_handle,pasta_transition_in_fm3=s% eos_pasta_transition_in_fm3)
        if (s% eos_cluster_transition_in_fm3 > 0.0)  &
        & call dStar_eos_set_controls(s% eos_handle,cluster_transition_in_fm3=s% eos_cluster_transition_in_fm3)

        call status% report('Loading crust model')
        call dStar_crust_startup(trim(dStar_data_dir),ierr)
        if (crust_error% raised(ierr)) return
        call dStar_crust_load_table('hz90',s% eos_handle, s% Tcore, ierr)
        if (crust_table_error% raised(ierr)) return

        call status% report('Loading atmosphere model')
        call dStar_atm_startup(trim(dStar_data_dir),ierr)
        if (atm_error% raised(ierr)) return

        call status% report('Integrating TOV equations')
        allocate(y(num_tov_variables))
        call tov_integrate(log10(s% Pcore), log10(s% Psurf), s% Mcore, s% Rcore, s% target_resolution_lnP, y, ierr)
        if (tov_error% raised(ierr)) return
        deallocate(y)

        ! allocate the info arrays
        stov => tov_model
        s% nz = stov% nzs - 1
        s% nisos = dStar_crust_get_composition_size()
        call allocate_NScool_info_arrays(s, ierr)

        call status% report('Computing facial quantities')
        s% P_bar(1:s% nz) = stov% pressure(stov% nzs:2:-1) * pressure_g
        s% ePhi_bar(1:s% nz) = exp(stov% potential(stov% nzs:2:-1))
        s% e2Phi_bar(1:s% nz) = s% ePhi_bar(1:s% nz)**2
        s% ePhicore = exp(stov% potential(1))
        s% m(1:s% nz) = stov% baryon(stov% nzs:2:-1) * mass_g
        s% area(1:s% nz) = fourpi*(stov% radius(stov% nzs:2:-1)*length_g + s% Rcore*1.0e5)**2
        s% eLambda_bar(1:s% nz) = 1.0/sqrt(1.0-2.0*(stov% mass(stov% nzs:2:-1)+s% Mcore)/ &
        &   (stov% radius(stov% nzs:2:-1) + s% Rcore*1.0e5/length_g))

        call status% report('Computing zonal quantities')
        s% dm(1:s% nz-1) = s% m(1:s% nz-1) - s% m(2:s% nz)
        s% dm(s% nz) = s% m(s% nz)
        ! mean density of a cell
        s% rho(1:s% nz) = s% dm(1:s% nz)/(stov% volume(stov% nzs:2:-1) - stov% volume(stov% nzs-1:1:-1))/length_g**3

        call status% report('Interpolating metric functions')
        s% eLambda(1:s% nz-1) = 0.5*(s% eLambda_bar(1:s% nz-1) + s% eLambda_bar(2:s% nz))
        s% eLambda(s% nz) = 0.5*(s% eLambda_bar(s% nz) +  &
        &   1.0/sqrt(1.0-2.0*s% Mcore/(s% Rcore*1.0e5/length_g)))
        s% ePhi(1:s% nz-1) = 0.5*(s% ePhi_bar(1:s% nz-1) + s% ePhi_bar(2:s% nz))
        s% ePhi(s% nz) = 0.5*(s% ePhi_bar(s% nz) + s% ePhicore)
        s% e2Phi(1:s% nz) = s% ePhi(1:s% nz)**2
        s% P(1:s% nz-1) = 0.5*(s% P_bar(1:s% nz-1)+s% P_bar(2:s% nz))

        ! temperatures: set to be isothermal (exp(Phi)*T = const)
        s% T(1:s% nz) = s% Tcore * s% ePhicore / s% ePhi(1:s% nz)
        s% T_bar(1:s% nz) = s% Tcore * s% ePhicore / s% ePhi_bar(1:s%nz)
        s% lnT(1:s% nz) = log(s% T(1:s% nz))
        s% lnT_bar(1:s% nz) = log(s% T_bar(1:s% nz))

        ! now interpolate dm and rho to the facial points
        s% dm_bar(1) = 0.5*s% dm(1)
        s% dm_bar(2:s% nz) = 0.5*(s% dm(1:s% nz-1) + s% dm(2:s% nz))

        ! this leaves rho_bar(1) undefined... we can use Taylor expansion
        s% rho_bar(2:s% nz) = 0.5*(s% rho(1:s% nz-1)*s% dm(2:s% nz) + s% rho(2:s% nz)*s% dm(1:s% nz-1)) / &
        &   s% dm_bar(2:s% nz)

        call status% report('Loading atmosphere')
        ! mass in Msun
        s% Mtotal = stov% mass(stov% nzs) + s% Mcore
        ! R in km
        s% Rtotal = stov% radius(stov% nzs)*length_g*1.0e-5 + s% Rcore
        s% grav = (s% Mtotal) * mass_g * Gnewton /  &
        &   (s% Rtotal*1.0e5)**2 * s% eLambda_bar(1)

        Plight = s% grav * 10.0_dp**s% lg_atm_light_element_column

        call dStar_atm_load_table(s% atm_model, s% grav, Plight, s% Psurf, ierr)
        if (atm_load_error% raised(ierr)) return
    end subroutine do_setup_crust_zones

    subroutine do_setup_crust_composition(s, ierr)
        use, intrinsic :: iso_fortran_env, only: error_unit
        use exceptions_lib
        use nucchem_def
        use nucchem_lib
        use storage

        type(NScool_info), pointer :: s
        integer, intent(out) :: ierr
        real(dp), allocatable, dimension(:) :: lgP_bar
        type(alert) :: qimp=alert(scope='do_setup_crust_composition')
        character(len=128) :: qimp_msg
        type(alert) :: status=alert(scope='do_setup_crust_composition')

        ! this routine assumes that we have already run do_setup_crust_zones
        ierr = 0
        allocate(lgP_bar(s% nz))
        lgP_bar = log10(s% P_bar)

        call status% report('Setting composition')
        call allocate_NScool_iso_arrays(s, ierr)
        call dStar_crust_get_composition(lgP_bar, s% ncharged, s% charged_ids, s% Yion_bar, s% Xneut_bar, s% ionic_bar, ierr)
        if (ierr /= 0) return

        ! can fix the impurity parameter to a specified value
        if (s% fix_Qimp) then
            write (qimp_msg,'(a,f7.2)') 'Setting Qimp = ',s% Qimp
            call qimp% report(qimp_msg)
            s% ionic_bar(1:s% nz)% Q = s% Qimp
        end if

        ! if there is a customized option, use that
        if (s% use_other_set_Qimp) then
            call qimp% report('Using user-defined Qimp')
            call s% other_set_Qimp(s% id, ierr)
        end if

        ! for the cells, *for now*, inherit composition of the top face
        s% Yion(1:s% ncharged, 1:s% nz) = s% Yion_bar(1:s% ncharged, 1:s% nz)
        s% ionic(1:s% nz) = s% ionic_bar(1:s% nz)
        s% Xneut(1:s% nz) = s% Xneut_bar(1:s% nz)

        deallocate(lgP_bar)
    end subroutine do_setup_crust_composition

    subroutine do_setup_crust_transport(s, ierr)
        use exceptions_lib
        use constants_def
        use nucchem_lib
        use superfluid_def
        use superfluid_lib
        use dStar_eos_def
        use dStar_eos_lib
        use conductivity_def
        use conductivity_lib
        use neutrino_def
        use neutrino_lib
        use interp_1d_def
        use interp_1d_lib
        use storage
        use utils_lib, only: is_bad_num

        type(NScool_info), pointer :: s
        integer, intent(out) :: ierr
        logical, dimension(num_crust_nu_channels) :: nu_channels
        logical, dimension(num_conductivity_channels) :: cond_channels
        type(crust_neutrino_emissivity_channels) :: eps_nu
        integer :: iz, itemp, ieos
        integer :: eos_phase
        real(dp), dimension(num_dStar_eos_results) :: eos_results
        type(conductivity_components) :: Kcomponents
        real(dp) :: chi, Ttab, enu_tab
        real(dp), dimension(:), pointer :: work=>null()
        real(dp), dimension(:,:), pointer :: lnEnu_val, lnKcond_val, lnCp_val, lnGamma_val
        real(dp), dimension(:), pointer :: lnEnu_interp, lnKcond_interp, lnCp_interp, lnGamma_interp
        real(dp) :: kn, kp, Tc(max_number_sf_types)
        type(crust_eos_component), dimension(num_crust_eos_components) :: components
        ! for error checking
        real(dp), dimension(:), allocatable :: delP
        type(alert) :: status=alert(scope='do_setup_crust_transport')

        ierr = 0
        s% n_tab = number_table_pts

        call allocate_NScool_work_arrays(s, ierr)
        if (ierr /= 0) return

        ! set up the conductivity and neutrino channels
        nu_channels = [ s% use_crust_nu_pair,  &
        &               s% use_crust_nu_photo,  &
        &               s% use_crust_nu_plasma, &
        &               s% use_crust_nu_bremsstrahlung,  &
        &               s% use_crust_nu_pbf ]

        cond_channels = [ s% use_ee_conductivity, &
        &                 s% use_ei_conductivity,  &
        &                 s% use_eQ_conductivity,  &
        &                 s% use_sf_conductivity,  &
        &                 s% use_nph_conductivity, &
        &                 s% use_nQ_conductivity, &
        &                 s% use_rad_opacity ]

        s% tab_lnT(1:s% n_tab) = [(lgT_tab_min*ln10 + (lgT_tab_max-lgT_tab_min)*ln10*real(itemp-1,dp)/real(s% n_tab-1,dp), &
        &   itemp = 1, s% n_tab)]

        call status% report('Computing specific heat, neutrino emissivity tables')
        do iz = 1, s% nz
            lnCp_val(1:4,1:s% n_tab) => s% tab_lnCp(1:4*s% n_tab, iz)
            lnGamma_val(1:4,1:s% n_tab) => s% tab_lnGamma(1:4*s% n_tab, iz)
            lnEnu_val(1:4,1:s% n_tab) => s% tab_lnEnu(1:4*s% n_tab, iz)
            chi = nuclear_volume_fraction(s% rho(iz),s% ionic(iz), &
            &   default_nuclear_radius)
            kn = neutron_wavenumber(s% rho(iz),s% ionic(iz),chi)
            kp = 0.0_dp
            if (.not. s% use_other_sf_critical_temperatures) then
                call sf_get_results(kp,kn,Tc)
            else
                call s% other_sf_get_results(s% id,kp,kn,Tc)
            end if
            do itemp = 1, s% n_tab
                Ttab = exp(s% tab_lnT(itemp))
                call eval_crust_eos( &
                &   s% eos_handle, s% rho(iz), Ttab, s% ionic(iz),  &
                &   s% ncharged, s% charged_ids, s% Yion(1:s% ncharged,iz), &
                &   Tc, eos_results, eos_phase, chi, components)
                lnCp_val(1,itemp) = log(eos_results(i_Cp))
                lnGamma_val(1,itemp) = log(eos_results(i_Gamma))
!                 if (is_bad_num(lnCp_val(1,itemp)) .and. itemp == 40) then
!                     print *,'bad CV'
!                     do ieos = 1, num_crust_eos_components
!                         print *, ieos
!                         print *,components(ieos)
!                     end do
!                     print *, s% ionic(iz), s% Yion(1:s% ncharged,iz)
!                 end if
!   Set the pressure based on the lowest temperature in the table.
!                 if (itemp == 1) s% P(iz) = exp(eos_results(i_lnP))

                ! perform interpolation of density to first cell face
                if (iz == 1 .and. itemp == 1) then
                    s% rho_bar(iz) = s% rho(iz)*(s% P_bar(iz)/s% P(iz))**(1.0/eos_results(i_chiRho))
                end if

                call get_crust_neutrino_emissivity(s% rho(iz), Ttab,  &
                &   s% ionic(iz), chi, Tc(neutron_1S0),  &
                &   eps_nu, nu_channels)
                lnEnu_val(1,itemp) = log(eps_nu% total/s% rho(iz))

            end do

            ! add in the shell Urca cooling: this should be a call to a (potentially user-defined) function
            if (s% turn_on_shell_Urca .and. iz < s% nz) then
                if (log10(s% P_bar(iz)) < s% lgP_shell_Urca .and. log10(s% P_bar(iz+1)) > s% lgP_shell_Urca) then
                    lnEnu_val(1,1:s% n_tab) = log(exp(lnEnu_val(1,1:s% n_tab))  &
                    &   + 1.0e36_dp*s% shell_Urca_luminosity_coeff * (exp(s% tab_lnT(1:s% n_tab))/5.0e8_dp)**5/s% dm(iz))
                end if
            end if

            allocate(work(s% n_tab*pm_work_size))
            lnEnu_interp(1:4*s% n_tab) => s% tab_lnEnu(1:4*s% n_tab,iz)
            call interp_pm(s% tab_lnT, s% n_tab, lnEnu_interp, pm_work_size, work, &
            &   'do_setup_crust_transport: lnEnu', ierr)
            lnCp_interp(1:4*s% n_tab) => s% tab_lnCp(1:4*s% n_tab,iz)
            call interp_pm(s% tab_lnT, s% n_tab, lnCp_interp, pm_work_size, work, &
            &   'do_setup_crust_transport: lnCp', ierr)
            lnGamma_interp(1:4*s% n_tab) => s% tab_lnGamma(1:4*s% n_tab, iz)
            call interp_pm(s% tab_lnT, s% n_tab, lnGamma_interp, pm_work_size, work,  &
            &   'do_setup_crust_transport: Gamma', ierr)
            deallocate(work)

        end do

        call status% report('Computing thermal conductivity tables')
        ! compute dp for error checking
        allocate(delP(s% nz))
        do iz = 1, s% nz
            lnKcond_val(1:4,1:s% n_tab) => s% tab_lnK(1:4*s% n_tab, iz)
            do itemp = 1, s% n_tab
                Ttab = exp(s% tab_lnT(itemp))
                chi = nuclear_volume_fraction(s% rho_bar(iz),s% ionic_bar(iz),&
                &   default_nuclear_radius)
                kn = neutron_wavenumber(s% rho_bar(iz), s% ionic_bar(iz),chi)
                kp = 0.0_dp
                if (.not. s% use_other_sf_critical_temperatures) then
                    call sf_get_results(kp,kn,Tc)
                else
                    call s% other_sf_get_results(s% id,kp,kn,Tc)
                end if
                call eval_crust_eos( &
                &   s% eos_handle, s% rho_bar(iz), Ttab, s% ionic_bar(iz),  &
                &   s% ncharged, s% charged_ids, &
                &   s% Yion_bar(1:s% ncharged,iz), Tc, eos_results,  &
                &   eos_phase, chi)
                if (itemp == 1)  &
                &   delP(iz) = abs(1.0 - exp(eos_results(i_lnP))/s% P_bar(iz))

                call get_thermal_conductivity(s% rho_bar(iz), Ttab, chi, &
                &   eos_results(i_Gamma), eos_results(i_Theta), &
                &   eos_results(i_mu_e), s% ionic_bar(iz), Tc(neutron_1S0), &
                &   Kcomponents, use_pcy=s% use_pcy_for_ee_scattering, &
                &   use_page=s% use_page_for_eQ_scattering, &
                &   which_components=cond_channels)
                lnKcond_val(1,itemp) = log(Kcomponents% total)

            end do
            allocate(work(s% n_tab*pm_work_size))
            lnKcond_interp(1:4*s% n_tab) => s% tab_lnK(1:4*s% n_tab,iz)
            call interp_pm(s% tab_lnT, s% n_tab, lnKcond_interp, pm_work_size, work, &
        &   'do_setup_crust_transport: lnK', ierr)
            deallocate(work)
        end do
!         write (*,'(a,es15.8,a,es15.8)') 'max dP = ',maxval(delP),' at ',s% P_bar(maxloc(delP))
        deallocate(delP)

    end subroutine do_setup_crust_transport

end module create_model


module type_domain_matrix
#include <messenger.h>
    use mod_kinds,              only: rk,ik
    use mod_constants,          only: DIAG, ZERO, XI_MIN, ETA_MIN, ZETA_MIN, XI_MAX, ETA_MAX, ZETA_MAX, &
                                      NFACES, CHIMERA, NO_INTERIOR_NEIGHBOR
    use type_mesh,              only: mesh_t
    use type_densematrix,       only: densematrix_t
    use type_densematrix_vector,only: densematrix_vector_t
    use type_face_info,         only: face_info_t
    use type_seed,              only: seed_t
    use type_ivector,           only: ivector_t
    use mod_chidg_mpi,          only: IRANK
    use DNAD_D
    implicit none

    !> Container for storing denseblock linearizations that make up a domain_matrix
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/1/2016
    !!
    !! localblocks (nelem x 7)
    !!
    !!            xi_min   xi_max   eta_min   eta_max   zeta_min    zeta_max    diag
    !!
    !!  elem #1:
    !!  elem #2:
    !!  elem #3:
    !!    .
    !!    .
    !-------------------------------------------------------------------------------------------
    type, public :: domain_matrix_t

        !
        ! Primary storage, (nelem,ntime)
        !
        type(densematrix_vector_t), allocatable :: lblks(:,:)
        type(densematrix_vector_t), allocatable :: chi_blks(:,:)
        type(densematrix_vector_t), allocatable :: bc_blks(:,:)

        !
        ! Supporting data
        !
        integer(ik),            allocatable :: ldata(:,:)               ! Block-local data, (nelem,3) nvars, nterms, ntime.
        !integer(ik),            allocatable :: local_transpose(:,:)    ! Block index of the transposed location (nelem,6)
        !type(ivector_t),        allocatable :: local_transpose(:)
        type(ivector_t),        allocatable :: local_lower_blocks(:,:)    ! For each element, which blocks (1-6) are lower blocks
        type(ivector_t),        allocatable :: local_upper_blocks(:,:)    ! For each element, which blocks (1-6) are upper blocks

    contains

        ! Initializers
        generic,   public  :: init => initialize_linearization          ! Initialize full linearization matrix
        procedure, private :: initialize_linearization

        ! Setters
        procedure :: store                                              ! Store linearization data for local blocks
        procedure :: store_chimera                                      ! Store linearization data for chimera blocks
        procedure :: store_bc                                           ! Store linearization data for boundary condition blocks
        procedure :: clear                                              ! Zero all data storage

        ! Processors
        procedure :: restrict

        final :: destructor

    end type domain_matrix_t
    !*******************************************************************************************

    private
contains

    !> Subroutine for initializing local linearization matrix
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/1/2016
    !!
    !!  @param[in]  mesh    mesh_t containing arrays of elements and faces
    !!  @param[in]  mtype   character string indicating the type of matrix to be initialized
    !!                      (ie. Full, Lower-Diagonal, Upper-Diagonal
    !!
    !!  @author Matteo Ugolotti + Mayank Sharma
    !!  @date   11/10/2016
    !!
    !-------------------------------------------------------------------------------------------
    subroutine initialize_linearization(self,mesh,idom,mtype)
        class(domain_matrix_t), intent(inout)   :: self
        class(mesh_t),          intent(in)      :: mesh
        integer(ik),            intent(in)      :: idom
        character(*),           intent(in)      :: mtype

        character(:),   allocatable :: user_msg
        integer(ik),    allocatable :: blocks(:)
        integer(ik)                 :: nelem, ierr, ielem, iblk, parent,                &
                                       block_index, neqns, nterms_s, ntime,             &
                                       nchimera_elements, maxdonors, idonor, iface,     &
                                       itime, dparent_g, dparent_l, eparent_g,          &
                                       eparent_l, parent_proc, eparent_l_trans,         &
                                       imat_trans, ChiID, ndonors, max_coupled_elems,   &
                                       ncoupled_elems, icoupled_elem, icoupled_elem_bc, &
                                       ielem_bc, ibc, imat, group_ID, patch_ID,         &
                                       face_ID, elem_ID, idomain_l, ielement_l
        logical                     :: new_elements, chimera_face, more_donors,         &
                                       already_added, contains_chimera_face,            &
                                       block_initialized, lower_block, upper_block,     &
                                       transposed_block, domain_has_face
        logical                     :: init_chimera = .false.
        logical                     :: init_bc      = .false.

        type(densematrix_t)         :: temp_blk, temp1
        !
        ! Select matrix blocks to initialize
        !
        select case (trim(mtype))
            case ('full','Full','FULL')
                blocks       = [XI_MIN,XI_MAX,ETA_MIN,ETA_MAX,ZETA_MIN,ZETA_MAX,DIAG]
                init_chimera = .true.
                init_bc      = .true.

            case ('L','l','Lower','lower')
                blocks       = [XI_MIN,ETA_MIN,ZETA_MIN]
                init_chimera = .false.
                init_bc      = .false.

            case ('U','u','Upper','upper')
                blocks       = [XI_MAX,ETA_MAX,ZETA_MAX]
                init_chimera = .false.
                init_bc      = .false.

            case ('LD','ld','LowerDiagonal','lowerdiagonal')
                blocks       = [XI_MIN,ETA_MIN,ZETA_MIN,DIAG]
                init_chimera = .false.
                init_bc      = .false.

            case ('UD','ud','UpperDiagonal','upperdiagonal')
                blocks       = [XI_MAX,ETA_MAX,ZETA_MAX,DIAG]
                init_chimera = .false.
                init_bc      = .false.

            case ('D', 'd', 'Diagonal', 'diagonal')
                blocks       = [DIAG]
                init_chimera = .false.
                init_bc      = .false.

            case default
                call chidg_signal(FATAL,'domain_matrix%init: unrecognized matrix type')

        end select

        ! Check to make sure the domain numerics were initialized
        user_msg = "domain_matrix%initialize_linearization: Incoming domain_t was not &
                    initialized. Make sure to call domain%init_sol"
        if (.not. mesh%domain(idom)%solInitialized) call chidg_signal(FATAL,user_msg)

        nelem = mesh%domain(idom)%nelem      ! Number of elements in the local block
        ntime = mesh%domain(idom)%ntime      ! Number of time levels
        !
        ! Allocation for 'local blocks'
        !
        if (allocated(self%lblks)) deallocate(self%lblks)
        allocate(self%lblks(nelem,ntime),           &
                 self%ldata(nelem,3),               &
                 self%local_lower_blocks(nelem,ntime),    &
                 self%local_upper_blocks(nelem,ntime), stat=ierr)
        if (ierr /= 0) call AllocationError

        !
        ! Allocation for 'chimera', 'bc' coupling
        !
        if (allocated(self%chi_blks)) deallocate(self%chi_blks)
        if (allocated(self%bc_blks))  deallocate(self%bc_blks)

        if (init_chimera) allocate(self%chi_blks(nelem,ntime), stat=ierr)
        if (ierr /= 0) call AllocationError
        if (init_bc) allocate(self%bc_blks(nelem,ntime), stat=ierr)
        if (ierr /= 0) call AllocationError

        !
        ! Loop through elements and call initialization for INTERIOR, CHIMERA, and
        ! denseblock matrices.
        !
        do ielem = 1,mesh%domain(idom)%nelem
            do itime = 1,mesh%domain(idom)%ntime
                imat = 1

                ! Set the element indices that the densematrix_vector is associated with.
                self%lblks(ielem,itime)%idomain_g  = mesh%domain(idom)%elems(ielem)%idomain_g
                self%lblks(ielem,itime)%idomain_l  = mesh%domain(idom)%elems(ielem)%idomain_l
                self%lblks(ielem,itime)%ielement_g = mesh%domain(idom)%elems(ielem)%ielement_g
                self%lblks(ielem,itime)%ielement_l = mesh%domain(idom)%elems(ielem)%ielement_l
                self%lblks(ielem,itime)%mass       = mesh%domain(idom)%elems(ielem)%mass

                !--------------------------------------------
                !
                ! Initialization  --  INTERIOR coupling
                !
                !--------------------------------------------
                do block_index = 1,size(blocks)
                    iblk = blocks(block_index)
                    nterms_s = mesh%domain(idom)%elems(ielem)%nterms_s
                    neqns    = mesh%domain(idom)%elems(ielem)%neqns
                    !size1d = mesh%domain(idom)%elems(ielem)%neqns  *  mesh%domain(idom)%elems(ielem)%nterms_s

                    !
                    ! Parent is the element with respect to which the linearization is computed
                    !
                    dparent_l = mesh%domain(idom)%idomain_l
                    if (iblk == DIAG) then
                        dparent_g   = mesh%domain(idom)%elems(ielem)%idomain_g
                        dparent_l   = mesh%domain(idom)%elems(ielem)%idomain_l
                        eparent_g   = mesh%domain(idom)%elems(ielem)%ielement_g
                        eparent_l   = mesh%domain(idom)%elems(ielem)%ielement_l
                        parent_proc = IRANK
                    else
                        dparent_g   = mesh%domain(idom)%faces(ielem,iblk)%ineighbor_domain_g
                        dparent_l   = mesh%domain(idom)%faces(ielem,iblk)%ineighbor_domain_l
                        eparent_g   = mesh%domain(idom)%faces(ielem,iblk)%ineighbor_element_g
                        eparent_l   = mesh%domain(idom)%faces(ielem,iblk)%ineighbor_element_l
                        parent_proc = mesh%domain(idom)%faces(ielem,iblk)%ineighbor_proc
                    end if

                    !
                    ! Call initialization procedure if parent is not 0 (0 meaning there is no parent, probably a boundary)
                    !
                    if (eparent_l /= NO_INTERIOR_NEIGHBOR) then

                        ! Initialize dense block
                        call temp_blk%init(nterms_s,neqns,dparent_g,dparent_l,eparent_g,eparent_l,parent_proc)
                        call self%lblks(ielem,itime)%push_back(temp_blk)

                        ! Store data about number of equations and number of terms in solution expansion
                        self%ldata(ielem,1) = mesh%domain(idom)%elems(ielem)%neqns
                        self%ldata(ielem,2) = mesh%domain(idom)%elems(ielem)%nterms_s
                        self%ldata(ielem,3) = mesh%domain(idom)%elems(ielem)%ntime

                        !
                        ! If off-diagonal, store block index as 'upper' or 'lower'
                        !
                        ! TODO: Add consideration for ntime and how that affects upper/lower status.
                        !

                        lower_block = ( (parent_proc == IRANK .and. eparent_l < ielem) .or. (parent_proc < IRANK) )
                        upper_block = ( (parent_proc == IRANK .and. eparent_l > ielem) .or. (parent_proc > IRANK) )

                        if ( lower_block ) then
                            call self%local_lower_blocks(ielem,itime)%push_back(imat)
                        else if ( upper_block ) then
                            call self%local_upper_blocks(ielem,itime)%push_back(imat)
                        end if

                        imat = imat + 1
                    end if

                end do ! init local
                !********************************************

                !--------------------------------------------
                !
                ! Initialization  --  CHIMERA coupling
                !
                !--------------------------------------------
                if (init_chimera) then
                    ! Set the element indices that the densematrix_vector is associated with.
                    self%chi_blks(ielem,itime)%idomain_g  = mesh%domain(idom)%elems(ielem)%idomain_g
                    self%chi_blks(ielem,itime)%idomain_l  = mesh%domain(idom)%elems(ielem)%idomain_l
                    self%chi_blks(ielem,itime)%ielement_g = mesh%domain(idom)%elems(ielem)%ielement_g
                    self%chi_blks(ielem,itime)%ielement_l = mesh%domain(idom)%elems(ielem)%ielement_l
                    self%chi_blks(ielem,itime)%mass       = mesh%domain(idom)%elems(ielem)%mass

                    do iface = 1,NFACES

                        !
                        ! If facetype is CHIMERA
                        !
                        chimera_face = ( mesh%domain(idom)%faces(ielem,iface)%ftype == CHIMERA )
                        if (chimera_face) then

                            !
                            ! Get ChiID and number of donor elements
                            !
                            ChiID   = mesh%domain(idom)%faces(ielem,iface)%ChiID
                            ndonors = mesh%domain(idom)%chimera%recv(ChiID)%ndonors()

                            !
                            ! Call block initialization for each Chimera donor
                            !
                            do idonor = 1,ndonors
                                !neqns       = mesh%domain(idom)%chimera%recv(ChiID)%donor_neqns%at(idonor)
                                !nterms_s    = mesh%domain(idom)%chimera%recv(ChiID)%donor_nterms_s%at(idonor)
                                !dparent_g   = mesh%domain(idom)%chimera%recv(ChiID)%donor_domain_g%at(idonor)
                                !dparent_l   = mesh%domain(idom)%chimera%recv(ChiID)%donor_domain_l%at(idonor)
                                !eparent_g   = mesh%domain(idom)%chimera%recv(ChiID)%donor_element_g%at(idonor)
                                !eparent_l   = mesh%domain(idom)%chimera%recv(ChiID)%donor_element_l%at(idonor)
                                !parent_proc = mesh%domain(idom)%chimera%recv(ChiID)%donor_proc%at(idonor)
                                dparent_g   = mesh%domain(idom)%chimera%recv(ChiID)%donor(idonor)%idomain_g
                                dparent_l   = mesh%domain(idom)%chimera%recv(ChiID)%donor(idonor)%idomain_l
                                eparent_g   = mesh%domain(idom)%chimera%recv(ChiID)%donor(idonor)%ielement_g
                                eparent_l   = mesh%domain(idom)%chimera%recv(ChiID)%donor(idonor)%ielement_l
                                parent_proc = mesh%domain(idom)%chimera%recv(ChiID)%donor(idonor)%iproc
                                neqns       = mesh%domain(idom)%chimera%recv(ChiID)%donor(idonor)%nfields
                                nterms_s    = mesh%domain(idom)%chimera%recv(ChiID)%donor(idonor)%nterms_s

                                !
                                ! Check if block initialization was already called for current donor
                                !
                                already_added = .false.
                                do imat = 1,self%chi_blks(ielem,itime)%size()

                                    ! dummy densematrix to get a specific densematrix inside the chi_blks
                                    ! densematrix_vector temporary variable to access densematrix routine
                                    temp1 = self%chi_blks(ielem,itime)%at(imat)

                                    already_added = ( dparent_g == temp1%dparent_g() .and. &
                                                      dparent_l == temp1%dparent_l() .and. &
                                                      eparent_g == temp1%eparent_g() .and. &
                                                      eparent_l == temp1%eparent_l() )
                                    if (already_added) exit
                                end do

                                !
                                ! If a block for the donor element hasn't yet been initialized, call initialization procedure
                                !
                                if (.not. already_added) then

                                    !
                                    ! Call block initialization, store
                                    !
                                    call temp_blk%init(nterms_s,neqns,dparent_g,dparent_l,eparent_g,eparent_l,parent_proc)
                                    call self%chi_blks(ielem,itime)%push_back(temp_blk)

                                end if

                            end do ! idonor

                        end if

                    end do ! iface

                end if  ! init_chimera
                !********************************************

            end do  ! itime

        end do ! ielem

        !--------------------------------------------
        !
        ! Initialization  --  BOUNDARY coupling
        !
        !--------------------------------------------
        if (init_bc) then
            do itime = 1,mesh%domain(idom)%ntime

                do group_ID = 1,mesh%nbc_patch_groups()
                    do patch_ID = 1,mesh%bc_patch_group(group_ID)%npatches()
                        do face_ID = 1,mesh%bc_patch_group(group_ID)%patch(patch_ID)%nfaces()

                            ! Get indices of the local element to determine if it is on 'idom'
                            idomain_l  = mesh%bc_patch_group(group_ID)%patch(patch_ID)%idomain_l()
                            ielement_l = mesh%bc_patch_group(group_ID)%patch(patch_ID)%ielement_l(face_ID)
                            domain_has_face = (idom == idomain_l)

                            !
                            ! If domain contains current face, add all coupling information.
                            !   ASSUMPTIONS:
                            !       - all coupled elements use the same number of equations
                            !       - all coupled elements run with the same nterms_s
                            !
                            if (domain_has_face) then
                                do elem_ID = 1,mesh%bc_patch_group(group_ID)%patch(patch_ID)%ncoupled_elements(face_ID)

                                    ! Set the element indices that the densematrix_vector is associated with.
                                    self%bc_blks(ielement_l,itime)%idomain_g  = mesh%domain(idomain_l)%elems(ielement_l)%idomain_g
                                    self%bc_blks(ielement_l,itime)%idomain_l  = mesh%domain(idomain_l)%elems(ielement_l)%idomain_l
                                    self%bc_blks(ielement_l,itime)%ielement_g = mesh%domain(idomain_l)%elems(ielement_l)%ielement_g
                                    self%bc_blks(ielement_l,itime)%ielement_l = mesh%domain(idomain_l)%elems(ielement_l)%ielement_l
                                    self%bc_blks(ielement_l,itime)%mass       = mesh%domain(idomain_l)%elems(ielement_l)%mass

                                    !
                                    ! Compute size of coupling matrix
                                    !
                                    neqns    = mesh%domain(idomain_l)%elems(ielement_l)%neqns
                                    nterms_s = mesh%domain(idomain_l)%elems(ielement_l)%nterms_s

                                    !
                                    ! Get indices for coupled element
                                    !
                                    dparent_g   = mesh%bc_patch_group(group_ID)%patch(patch_ID)%coupling(face_ID)%idomain_g(elem_ID)
                                    dparent_l   = mesh%bc_patch_group(group_ID)%patch(patch_ID)%coupling(face_ID)%idomain_l(elem_ID)
                                    eparent_g   = mesh%bc_patch_group(group_ID)%patch(patch_ID)%coupling(face_ID)%ielement_g(elem_ID)
                                    eparent_l   = mesh%bc_patch_group(group_ID)%patch(patch_ID)%coupling(face_ID)%ielement_l(elem_ID)
                                    parent_proc = mesh%bc_patch_group(group_ID)%patch(patch_ID)%coupling(face_ID)%proc(elem_ID)

                                    !
                                    ! We need to check that we dont try to add the local element more than once.
                                    ! For example, if an element had two different boundary conditions on different
                                    ! faces, they would both try to add the local element.
                                    !
                                    already_added = .false.
                                    do imat = 1,self%bc_blks(ielement_l,itime)%size()

                                        ! dummy densematrix to get a specific densematrix inside the bc_blks
                                        ! densematrix_vector temporary variable to access densematrix routine
                                        temp1 = self%bc_blks(ielement_l,itime)%at(imat)

                                        already_added = ( dparent_g == temp1%dparent_g() .and. &
                                                          dparent_l == temp1%dparent_l() .and. &
                                                          eparent_g == temp1%eparent_g() .and. &
                                                          eparent_l == temp1%eparent_l() )
                                        if (already_added) exit
                                    end do

                                    !
                                    ! Call initialization, store initialized matrix to bc_blks
                                    !
                                    if (.not. already_added) then
                                        call temp_blk%init(nterms_s,neqns,dparent_g,dparent_l,eparent_g,eparent_l,parent_proc)
                                        call self%bc_blks(ielement_l,itime)%push_back(temp_blk)
                                    end if

                                end do !elem_ID, coupling
                            end if

                        end do !face_ID
                    end do !patch_ID
                end do !group_ID
            end do !itime

        end if !init_bc

        !
        ! Initialize transpose data
        !
        select case (trim(mtype))
            case ('full','Full','FULL')

                do ielem = 1,mesh%domain(idom)%nelem
                    do itime = 1,mesh%domain(idom)%ntime
                        do imat = 1,self%lblks(ielem,itime)%size()

                            if ( self%lblks(ielem,itime)%parent_proc(imat) == IRANK ) then

                                    ! Get parent element of off-diagonal block
                                    eparent_l = self%lblks(ielem,itime)%eparent_l(imat)

                                    !
                                    ! Find block index of transposed location in parent lblks
                                    !
                                    do imat_trans = 1,self%lblks(eparent_l,itime)%size()
                                        ! Make sure the block we are seaching is on-proc
                                        if ( self%lblks(eparent_l,itime)%parent_proc(imat_trans) == IRANK ) then
                                            eparent_l_trans = self%lblks(eparent_l,itime)%eparent_l(imat_trans)

                                            transposed_block = ( eparent_l_trans == ielem )
                                            if ( transposed_block ) then
                                                call self%lblks(ielem,itime)%set_itranspose(imat,imat_trans)
                                                exit
                                            end if
                                        end if

                                        if ( (imat_trans == self%lblks(eparent_l,itime)%size() ) .and. &
                                             (transposed_block .eqv. .false.) ) call chidg_signal(FATAL,"domain_matrix%init: no transposed element found")
                                    end do !imat_trans

                            end if

                        end do !imat
                    end do !itime
                end do !ielem

        end select

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

    !>  Stores derivative data to the linearization matrix
    !!
    !!      -- Given the integral data computed from the spatial discretization,
    !!         store the derivative values from the AD data types
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/1/2016
    !!
    !!  @author Matteo Ugolotti
    !!  @date   11/10/2016
    !!
    !!  @param[in]  integral    Array of modes with embedded partial derivatives for the linearization
    !!  @param[in]  face        face_info_t containing indices for the location of the face being linearized.
    !!  @param[in]  seed        seed_t containing indices of element against which the linearization was computed.
    !!  @param[in]  ivar        Index of the variable
    !!  @param[in]  itime       Index of a time level for the linearization of the given element
    !!
    !-----------------------------------------------------------------------------------------
    subroutine store(self,integral,face_info,seed,ivar,itime)
        class(domain_matrix_t),   intent(inout)   :: self
        type(AD_D),             intent(in)      :: integral(:)
        type(face_info_t),      intent(in)      :: face_info
        type(seed_t),           intent(in)      :: seed
        integer(ik),            intent(in)      :: ivar
        integer(ik),            intent(in)      :: itime

        integer(ik) :: nterms, imat
        integer(ik) :: ielement_l, idonor_domain_g, idonor_element_g

        ielement_l = face_info%ielement_l

        idonor_domain_g  = seed%idomain_g
        idonor_element_g = seed%ielement_g

        ! Get stored information for the block
        nterms = self%ldata(ielement_l,2)

        ! Find donor densematrix location
        imat = self%lblks(ielement_l,itime)%loc(idonor_domain_g,idonor_element_g)

        ! Call subroutine on densematrix
        call self%lblks(ielement_l,itime)%store(imat,ivar,nterms,integral)

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

    !>  Stores derivative data from Chimera faces to the linearization matrix
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/1/2016
    !!
    !!  @author Matteo Ugolotti
    !!  @date   11/10/2015
    !!
    !!  @param[in]  integral    Array of modes with embedded partial derivatives for the linearization matrix
    !!  @param[in]  face        face_info_t containing indices for the location of the face being linearized.
    !!  @param[in]  seed        seed_t containing indices of the element against which the linearization was computed.
    !!  @param[in]  ivar        Index of the variable
    !!  @param[in]  itime       Index of a time level for the linearization of the given element
    !!
    !------------------------------------------------------------------------------------------
    subroutine store_chimera(self,integral,face_info,seed,ivar,itime)
        class(domain_matrix_t),       intent(inout)   :: self
        type(AD_D),                 intent(in)      :: integral(:)
        type(face_info_t),          intent(in)      :: face_info
        type(seed_t),               intent(in)      :: seed
        integer(ik),                intent(in)      :: ivar
        integer(ik),                intent(in)      :: itime

        integer(ik) :: nterms, imat
        integer(ik) :: ielement_l, idonor_domain_g, idonor_element_g

        ielement_l = face_info%ielement_l

        idonor_domain_g  = seed%idomain_g
        idonor_element_g = seed%ielement_g

        ! Get stored information for the block
        nterms = self%ldata(ielement_l,2)

        ! Find donor densematrix location
        imat = self%chi_blks(ielement_l,itime)%loc(idonor_domain_g,idonor_element_g)

        ! Store derivatives
        call self%chi_blks(ielement_l,itime)%store(imat,ivar,nterms,integral)

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

    !>  Stores derivative data from boundary condition coupling to the linearization matrix.
    !!
    !!  The linearization of a flux wrt the local element is stored in self%lblks in the DIAG location.
    !!  The linearization of a flux wrt other elements on the boundary is stored in self%bc_blks.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/1/2016
    !!
    !!  @author Matteo Ugolotti
    !!  @date   11/14/2016
    !!
    !!  @param[in]  integral    Array of modes with embedded partial derivatives
    !!  @param[in]  face        face_info_t containing indices for the location of the face being linearized.
    !!  @param[in]  seed        seed_t containing indices of the element against which the linearization was computed.
    !!  @param[in]  ivar        Index of the variable
    !!  @param[in]  itime       Index of a time level for the linearization of the given element
    !!
    !------------------------------------------------------------------------------------
    subroutine store_bc(self,integral,face,seed,ivar,itime)
        class(domain_matrix_t),       intent(inout)   :: self
        type(AD_D),                 intent(in)      :: integral(:)
        type(face_info_t),          intent(in)      :: face
        type(seed_t),               intent(in)      :: seed
        integer(ik),                intent(in)      :: ivar
        integer(ik),                intent(in)      :: itime

        integer(ik) :: ielement_l
        integer(ik) :: icoupled_domain_g, icoupled_element_g, icoupled_element_l, imat
        integer(ik) :: nterms, size_integral
        logical     :: local_coupling = .false.

        ielement_l = face%ielement_l

        icoupled_domain_g  = seed%idomain_g
        icoupled_element_g = seed%ielement_g
        icoupled_element_l = seed%ielement_l

        !
        ! If ielem = ielem_d then the linearization is with respect to the local element.
        ! So, this is stored in the self%lblks array in the DIAG location, instead of
        ! the self%bc_blks array. In general, the storage location is not important,
        ! but the ILU preconditioner expects the full diagonal contribution to be in
        ! lblks.
        !
        local_coupling = (ielement_l == icoupled_element_l)

        if ( local_coupling ) then

            call self%store(integral,face,seed,ivar,itime)

        else

            ! Get stored information for the block
            nterms = self%ldata(ielement_l,2)

            ! Find coupled bc densematrix location
            imat = self%bc_blks(ielement_l,itime)%loc(icoupled_domain_g,icoupled_element_g)

            ! Store derivatives
            call self%bc_blks(ielement_l,itime)%store(imat,ivar,nterms,integral)

        end if ! check local block.

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

    !>  Set all denseblock_t storage to zero
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/1/2016
    !!
    !!  @author Matteo Ugolotti + Mayank Sharma
    !!  @date   11/14/2016
    !!
    !--------------------------------------------------------------------------------
    subroutine clear(self)
        class(domain_matrix_t),   intent(inout)   :: self

        integer(ik)             :: ielem, itime

        !
        ! For each element
        !
        do ielem = 1,size(self%lblks,1)

            ! Clear local matrices
            do itime = 1,size(self%lblks,2)
                call self%lblks(ielem,itime)%setzero()
            end do  ! itime

            ! Clear chimera matrices
            if (allocated(self%chi_blks)) then
                do itime = 1,size(self%chi_blks,2)
                    call self%chi_blks(ielem,itime)%setzero()
                end do ! itime
            end if

            ! Clear bc matrices
            if (allocated(self%bc_blks)) then
                do itime = 1,size(self%bc_blks,2)
                    call self%bc_blks(ielem,itime)%setzero()
                end do ! itime
            end if

        end do ! ielem

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

    !>  Return a domain_matrix instance that is restricted to the specified
    !!  polynomial space.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   7/23/2017
    !!
    !!
    !------------------------------------------------------------------------------
    function restrict(self,nterms_r) result(restricted)
        class(domain_matrix_t), intent(in)  :: self
        integer(ik),            intent(in)  :: nterms_r

        type(domain_matrix_t)   :: restricted
        integer(ik)             :: ierr, ielem, itime

        !
        ! Copy auxiliary data
        !
        restricted%ldata = self%ldata
        restricted%local_lower_blocks = self%local_lower_blocks
        restricted%local_upper_blocks = self%local_upper_blocks

        !
        ! Allocate storage for primary data on restricted object
        !
        if (allocated(self%lblks)) then
            allocate(restricted%lblks(size(self%lblks,1),size(self%lblks,2)), stat=ierr)
            if (ierr /= 0) call AllocationError

            do ielem = 1,size(self%lblks,1)
                do itime = 1,size(self%lblks,2)
                    restricted%lblks(ielem,itime) = self%lblks(ielem,itime)%restrict(nterms_r)
                end do !itime
            end do !ielem
        end if

        if (allocated(self%chi_blks)) then
            allocate(restricted%chi_blks(size(self%chi_blks,1),size(self%chi_blks,2)), stat=ierr)
            if (ierr /= 0) call AllocationError

            do ielem = 1,size(self%chi_blks,1)
                do itime = 1,size(self%chi_blks,2)
                    restricted%chi_blks(ielem,itime) = self%chi_blks(ielem,itime)%restrict(nterms_r)
                end do !itime
            end do !ielem
        end if

        if (allocated(self%bc_blks)) then
            allocate(restricted%bc_blks(size(self%bc_blks,1),size(self%bc_blks,2)), stat=ierr)
            if (ierr /= 0) call AllocationError

            do ielem = 1,size(self%bc_blks,1)
                do itime = 1,size(self%bc_blks,2)
                    restricted%bc_blks(ielem,itime) = self%bc_blks(ielem,itime)%restrict(nterms_r)
                end do !itime
            end do !ielem
        end if

        !
        ! Update ldata with correct number of terms
        !
        do ielem = 1,size(self%ldata,1)
            restricted%ldata(ielem,2) = nterms_r
        end do !ielem

    end function restrict
    !******************************************************************************

    !>
    !!
    !!---------------------------------------------
    subroutine destructor(self)
        type(domain_matrix_t), intent(inout) :: self

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

end module type_domain_matrix


      SUBROUTINE PARSAV(MODE,N,M)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES'
**********************************************************************
*
*   PARSAV SAVES AND RESTORES DATA USED IN NLLSQ GRADIENT MINIMIZATION.
*
*    IF MODE IS 0 DATA ARE RESTORED, IF 1 THEN SAVED.
*
**********************************************************************
      COMMON /DENSTY/ P(MPACK), PA(MPACK), PB(MPACK)
      COMMON /ALPARM/ ALPARM(3,MAXPAR),X0, X1, X2, ILOOP
      COMMON /KEYWRD/ KEYWRD
      COMMON /ELEMTS/ ELEMNT(107)
      COMMON /ERRFN / ERRFN(MAXPAR), AICORR(MAXPAR)
      COMMON /GEOSYM/ NDEP,LOCPAR(MAXPAR),IDEPFN(MAXPAR),
     1                     LOCDEP(MAXPAR)
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM),
     1                NA(NUMATM),NB(NUMATM),NC(NUMATM)
      COMMON /GEOM  / GEO(3,NUMATM)
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM),
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA,
     2                NCLOSE,NOPEN,NDUMY,FRACT
      COMMON /NLLCOM/ Q(MAXPAR,MAXPAR),R(MAXPAR,MAXPAR*2)
      COMMON /NLLCO2/ DDDUM(6),EFSLST(MAXPAR),XLAST(MAXPAR),IIIUM(7)
      COMMON /GEOVAR/ NVAR,LOC(2,MAXPAR), JDUMY, DUMY(MAXPAR)
      COMMON /LOCVAR/ LOCVAR(2,MAXPAR)
      COMMON /VALVAR/ VALVAR(MAXPAR),NUMVAR
      DIMENSION COORD(3,NUMATM)
      CHARACTER ELEMNT*2, KEYWRD*241, GETNAM*80
      OPEN(UNIT=9,FILE=GETNAM('FOR009'),
     +     STATUS='UNKNOWN',FORM='UNFORMATTED')
      REWIND 9
      OPEN(UNIT=10,FILE=GETNAM('FOR010'),
     +     STATUS='UNKNOWN',FORM='UNFORMATTED')
      REWIND 10
      IF(MODE.NE.0) GOTO 10
*
*  MODE=0: RETRIEVE DATA FROM DISK.
*
      READ(9,END=30,ERR=30)IIIUM,DDDUM,EFSLST,N,(XLAST(I),I=1,N),M
      READ(9)((Q(J,I),J=1,M),I=1,M)
      READ(9)((R(J,I),J=1,N),I=1,N)
      READ(9)(VALVAR(I),I=1,N)
      IF(INDEX(KEYWRD,'AIDER').NE.0) READ(9)(AICORR(I),I=1,N)
      RETURN
   10 CONTINUE
      IF(MODE.EQ.1)THEN
         WRITE(6,'(//10X,'' **** TIME UP ****'')')
         WRITE(6,'(//10X,'' CURRENT VALUES OF GEOMETRIC VARIABLES'',//)'
     1)
         IF(NA(1) .EQ. 99) THEN
C
C  CONVERT FROM CARTESIAN COORDINATES TO INTERNAL
C
            DO 20 I=1,NATOMS
               DO 20 J=1,3
   20       COORD(J,I)=GEO(J,I)
            CALL XYZINT(COORD,NUMAT,NA,NB,NC,1.D0,GEO)
         ENDIF
         CALL GEOUT(6)
         WRITE(6,'(//10X,
     1''TO RESTART CALCULATION USE THE KEYWORD "RESTART".'')')
      ENDIF
      WRITE(9)IIIUM,DDDUM,EFSLST,N,(XLAST(I),I=1,N),M
      WRITE(9)((Q(J,I),J=1,M),I=1,M)
      WRITE(9)((R(J,I),J=1,N),I=1,N)
      WRITE(9)(VALVAR(I),I=1,N)
      IF(INDEX(KEYWRD,'AIDER').NE.0) WRITE(9)(AICORR(I),I=1,N)
C*****
C     The density matrix is required by ITER upon restart .
C
      LINEAR=(NORBS*(NORBS+1))/2
      WRITE(10)(PA(I),I=1,LINEAR)
      IF(NALPHA.NE.0)WRITE(10)(PB(I),I=1,LINEAR)
C*****
      CLOSE(9)
      CLOSE(10)
      RETURN
   30 WRITE(6,'(//10X,''NO RESTART FILE EXISTS!'')')
      STOP
      END


      subroutine irr_rch

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine performs the irrigation operation when the water
!!    source is a reach

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name            |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    aird(:)         |mm H2O        |amount of water applied to HRU on current
!!                                   |day
!!    auto_wstr(:)    |none or mm    |water stress factor which triggers auto
!!                                   |irrigation
!!    divmax(:)       |mm H2O or     |maximum daily irrigation diversion from
!!                    |  10^4 m^3 H2O|the reach (when IRR=1): when value is
!!                                   |positive the units are mm H2O; when the
!!                                   |value is negative, the units are (10**4
!!                                   |m^3 H2O
!!    flag                           |1 = manual 2 = auto
!!    flowfr(:)       |none          |fraction of available flow in reach that
!!                                   |is allowed to be applied to the HRU
!!    flowmin(:)      |m**3/s        |minimum instream flow for irrigation
!!                                   |diversions when IRR=1, irrigation water
!!                                   |will be diverted only when streamflow is
!!                                   |at or above FLOWMIN.
!!    iida            |julian date   |day being simulated (current julian date)
!!    wstrs_id(:)     |none          |water stress identifier:
!!                                   |1 plant water demand
!!                                   |2 soil water deficit
!!    inum1           |none          |reach number
!!    ipot(:)         |none          |number of HRU (in subbasin) that is ponding
!!                                   |water--the HRU that the surface runoff from
!!                                   |current HRU drains into. This variable is
!!                                   |used only for rice paddys or closed
!!                                   |depressional areas
!!    irramt(:)       |mm H2O        |depth of irrigation water applied to
!!                                   |HRU
!!    irrno(:)        |none          |irrigation source location
!!                                   |if IRR=1, IRRNO is the number of the
!!                                   |          reach
!!                                   |if IRR=2, IRRNO is the number of the
!!                                   |          reservoir
!!                                   |if IRR=3, IRRNO is the number of the
!!                                   |          subbasin
!!                                   |if IRR=4, IRRNO is the number of the
!!                                   |          subbasin
!!                                   |if IRR=5, not used
!!    irrsc(:)        |none          |irrigation source code:
!!                                   |1 divert water from reach
!!                                   |2 divert water from reservoir
!!                                   |3 divert water from shallow aquifer
!!                                   |4 divert water from deep aquifer
!!                                   |5 divert water from source outside
!!                                   |  watershed
!!    nair(:)         |none          |sequence number of auto-irrigation
!!                                   |application within the year
!!    nhru            |none          |number of HRUs in watershed
!!    nirr(:)         |none          |sequence number of irrigation application
!!                                   |within the year
!!    nro(:)          |none          |sequence number of year in rotation
!!    phuacc(:)       |none          |fraction of plant heat units accumulated
!!    pot_vol(:)      |m**3 H2O      |current volume of water stored in the
!!                                   |depression/impounded area
!!    rtwtr           |m^3 H2O       |water leaving reach on day
!!    sedrch          |metric tons   |sediment transported out of reach on day
!!    sol_sumfc(:)    |mm H2O        |amount of water held in the soil profile
!!                                   |at field capacity
!!    sol_sw(:)       |mm H2O        |amount of water stored in soil profile on any
!!                                   |given day
!!    strsw(:)        |none          |fraction of potential plant growth achieved
!!                                   |on the day where the reduction is caused by
!!                                   |water stress
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    nirr(:)     |none          |sequence number of irrigation application
!!                               |within the year
!!    pot_vol(:)  |mm            |current volume of water stored in the
!!                               |depression/impounded area
!!    rtwtr       |m^3 H2O       |water leaving reach on day
!!    sedrch      |metric tons   |sediment transported out of reach on day
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    cnv         |none          |conversion factor (mm => m^3)
!!    flag        |none          |irrigation flag:
!!                               |0 no irrigation operation on current day
!!                               |1 scheduled irrigation
!!                               |2 auto irrigation
!!    jrch        |none          |reach number
!!    k           |none          |HRU number
!!    vminmm      |mm H2O        |maximum amount of water available for
!!                               |irrigation from reach
!!    vmm         |mm H2O        |depth of irrigation water over HRU
!!    vmxi        |mm H2O        |amount of water specified in irrigation
!!                               |operation
!!    vol         |m^3 H2O       |volume of water applied in irrigation
!!                               |operation
!!    wtrin       |m^3 H2O       |water outflow from reach prior to subtracting
!!                               |irrigation diversions
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: abs, Min
!!    SWAT: irrigate

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm

      integer :: jrch, k, flag, ii
      real*8 :: cnv, vmm, vminmm, vol, wtrin

      jrch = 0
      jrch = inum1

      wtrin = 0.
      wtrin = rtwtr + rchstor(jrch)

      do k = 1, nhru
          !! check for timing of irrigation operation
          flag = 0
          flag = irr_flag(k)
          if (auto_wstr(k) > 0.) then
            if (wstrs_id(k) == 1 .and. strsw(k) < auto_wstr(k)) flag = 2
            if (wstrs_id(k) == 2 .and. sol_sumfc(k) - sol_sw(k) >
     &             auto_wstr(k)) flag = 2
          end if

            !! Set parameters based on manual or auto irrigation
			if (flag == 1) then
			  sq_rto = irrsq(k)
			  irrsc(k) = irr_sc(k)
			  irrno(k) = irr_no(k)
			else
			  sq_rto = irr_asq(k)
			  irrsc(k) = irr_sca(k)
			  irrno(k) = irr_noa(k)
			endif

        if (irrsc(k) == 1 .and. irrno(k) == jrch) then
          aird(k) = 0.

          if (flag > 0) then
            !!irrigate only if flow is greater than minimum flow
            if (rtwtr > flowmin(k) * 86400.) then
              cnv = 0.
              cnv = hru_ha(k) * 10.

              vmm = 0.
              vminmm = 0.
              !! compute maximum amount of water allowed in HRU
              if (divmax(k) < 0.) then
                !!divmax units are 10^4 m^3
                vmm = abs(divmax(k)) * 10000. / cnv
              else
                !! divmax units are mm H2O
                vmm = divmax(k)
              endif
              !! compute maximum amount of water available for irrigation
              !! from reach
              wtr_avail = rtwtr + rchstor(jrch)
              vminmm = (wtr_avail - flowmin(k) * 86400.) * flowfr(k)/cnv
              vmm = Min(vminmm, vmm)

              !! check available against set amount in scheduled operation
              if (flag == 1) then
                vmxi = 0.
                vmxi = irramt(k)
                if (vmxi < 1.e-6) vmxi = sol_sumfc(k)
                if (vmm > vmxi) vmm = vmxi
              end if
              if (flag == 2) then
                vmxi = 0.
                vmxi = irr_mx(k)
                if (vmm > vmxi) vmm = vmxi
              end if

              if (vmm > 0.) then
                vol = 0.
                vol = vmm * cnv

       !!         if (ipot(k) == k) then
                !if (pot_fr(k) > 1.e-6) then
                !  pot_vol(k) = pot_vol(k) + vol / (10. * potsa(k))
                !else
                  call irrigate(k,vmm)
                !end if

                !! subtract irrigation from reach outflow
           !!     if (ipot(k) /= k) then
                if (pot_fr(k) > 1.e-6) then
                  vol = 0.
                  vol = aird(k) * cnv
                end if
                if (ievent > 0) then
                  do ii = 1, nstep
                    hrtwtr(ii) = hrtwtr(ii) - vol * hrtwtr(ii) / rtwtr
                    if (hrtwtr(ii) < 0.) hrtwtr(ii) = 0.
                  end do
                end if
!!                xx = vol     							                           !! BN: replaced "wtrin" with "vol"
                vol = vol / irr_eff(k)   !! BN: inserted to account for irr. efficiency
                xx = (wtr_avail - flowmin(k) * 86400.) * flowfr(k)                 !! BN: inserted: xx = available/allowed amount in m3/s
                xx = Min(xx, vol)                                                  !! BN: inserted dabstracted water cannot be more than allowed/available amount
                if (xx > rchstor(jrch)) then
                  xx = vol - rchstor(jrch)                                         !! BN: replaced "wtrin" with "vol"
                  rchstor(jrch) = 0.
                else
                  rchstor(jrch) = rchstor(jrch) - xx
                  xx = 0.
                end if
                if (xx > 0.) then
                  rtwtr = rtwtr - xx
                  rtwtr = dmax1(0., rtwtr)
                end if

                !! advance irrigation operation number
                if (flag == 1) then
                  nirr(k) = nirr(k) + 1
                end if

            end if

            if (imgt == 1) then
             write (143, 1000) subnum(k), hruno(k), iyr, i_mo, iida,
     *       hru_km(k), "         ",  " AUTOIRR", phubase(k), phuacc(k),
     *      sol_sw(k), bio_ms(k), sol_rsd(1,k),sol_sumno3(k),
     *      sol_sumsolp(k), aird(k), irrsc(k), irrno(k)
1000        format (a5,1x,a4,3i6,1x,e10.5,1x,2a15,7f10.2,10x,f10.2,70x,
     *      i10,10x,i10)
            end if
            end if
          end if
          end if

      end do

      if (wtrin /= rtwtr .and. wtrin > 0.01) then
        sedrch = sedrch * rtwtr / wtrin

        rch_san = rch_san * rtwtr / wtrin
        rch_sil = rch_sil * rtwtr / wtrin
        rch_cla = rch_cla * rtwtr / wtrin
        rch_sag = rch_sag * rtwtr / wtrin
        rch_lag = rch_lag * rtwtr / wtrin
        rch_gra = rch_gra * rtwtr / wtrin

        if (sedrch  < 1.e-6) then
	    sedrch = 0.
	    rch_san = 0.
          rch_sil = 0.
          rch_cla = 0.
          rch_sag = 0.
          rch_lag = 0.
          rch_gra = 0.
	  end if

        if (ievent > 0) then
          do ii = 1, nstep
            hsedyld(ii) = hsedyld(ii) * rtwtr / wtrin
          end do
        end if
      end if

      return
      end