mod_mhd_phys.t

Go to the documentation of this file.

!> Magneto-hydrodynamics module
module mod_mhd_phys
 
#include "amrvac.h"
 
  use mod_global_parameters, only: std_len, const_c
  use mod_thermal_conduction, only: tc_fluid
  use mod_radiative_cooling, only: rc_fluid
  use mod_thermal_emission, only: te_fluid
  use mod_fld, only: fld_fluid
  use mod_physics
  use mod_eos
  use mod_comm_lib, only: mpistop
  use mod_functions_bfield, only: get_divb, mag
 
  implicit none
  private
 
  !> The adiabatic constant
  double precision, public                :: mhd_adiab = 1.0d0
  !> The MHD resistivity
  double precision, public                :: mhd_eta = 0.0d0
  !> The MHD hyper-resistivity
  double precision, public                :: mhd_eta_hyper = 0.0d0
  !> Hall resistivity
  double precision, public                :: mhd_etah = 0.0d0
  !> The MHD ambipolar coefficient
  double precision, public                :: mhd_eta_ambi = 0.0d0
  !> Height of the mask used in the TRAC method
  double precision, public, protected     :: mhd_trac_mask = 0.d0
  !> GLM-MHD parameter: ratio of the diffusive and advective time scales for div b
  !> taking values within [0, 1]
  double precision, public                :: mhd_glm_alpha = 0.5d0
  !> Reduced speed of light for semirelativistic MHD: 2% of light speed
  double precision, public, protected     :: mhd_reduced_c = 0.02d0*const_c
  !> The thermal conductivity kappa in hyperbolic thermal conduction
  double precision, public                :: mhd_hyperbolic_tc_kappa = 0.d0
  logical, public                         :: mhd_hyperbolic_tc_constant = .false.
  !> Coefficient of diffusive divB cleaning
  double precision, public                :: divbdiff     = 0.8d0
  !> Ionization fraction of H
  !> H_ion_fr = H+/(H+ + H)
  double precision, public, protected  :: h_ion_fr=1d0
  !> Ionization fraction of He
  !> He_ion_fr = (He2+ + He+)/(He2+ + He+ + He)
  double precision, public, protected  :: he_ion_fr=1d0
  !> Ratio of number He2+ / number He+ + He2+
  !> He_ion_fr2 = He2+/(He2+ + He+)
  double precision, public, protected  :: he_ion_fr2=1d0
  ! used for eq of state when it is not defined by units,
  ! the units do not contain terms related to ionization fraction
  ! and it is p = RR * rho * T
  double precision, public, protected  :: rr=1d0
  !> inverse of squared speed of light c0 and reduced speed of light c
  double precision :: inv_squared_c0=0.d0, inv_squared_c=0.d0
  !> equi vars indices in the state%equi_vars array
  integer, public :: equi_rho0_ = -1
  integer, public :: equi_pe0_ = -1
  !> Number of tracer species
  integer, public, protected              :: mhd_n_tracer = 0
  !> Index of the density (in the w array)
  integer, public, protected              :: rho_
  !> Indices of the momentum density
  integer, allocatable, public, protected :: mom(:)
  !> Indices of the momentum density for the form of better vectorization
  integer, public, protected              :: ^c&m^C_
  !> Index of the energy density (-1 if not present)
  integer, public, protected              :: e_
  !> Indices of the magnetic field for the form of better vectorization
  integer, public, protected              :: ^c&b^C_
  !> Index of the gas pressure (-1 if not present) should equal e_
  integer, public, protected              :: p_
  !> Index of the electron number density for LTE module
  integer, public, protected :: ne_
  !> Index of the field-aligned heat flux q_parallel
  integer, public, protected :: qpar_
  !> Index of the perpendicular heat flux q_perp
  integer, public, protected :: qperp_
  !> Indices of the GLM psi
  integer, public, protected :: psi_
  !> Index of the radiation energy
  integer, public, protected :: r_e
  !> Indices of temperature
  integer, public, protected :: te_
  !> Index of the FIP passive scalar rho*fip in conserved form, fip in primitive form
  integer, public, protected :: fip_ = -1
  !> Whether FIP passive scalar is enabled
  logical, public, protected :: mhd_fip = .false.
  !> Enable the Uniturbulence and Alfven Wave Solar Model extension
  logical, public, protected :: mhd_uawsom = .false.
  !> Enable conservative Alfvén reflection (one-dimensional or Cartesian gradient-vorticity)
  logical, public, protected :: mhd_uawsom_reflection = .false.
  !> Algebra used by the Alfven-wave reflection source.  one_dimensional_gradient
  !> retains the original one-dimensional source; cartesian_gradient_vorticity
  !> is the multidimensional gradient/vorticity closure.
  character(len=std_len), public, protected :: mhd_uawsom_reflection_mode = 'one_dimensional_gradient'
  !> Enable conservative kink-wave reflection from the kink-speed gradient
  logical, public, protected :: mhd_uawsom_kink_reflection = .false.
  !> Dimensionless multiplier in the one_dimensional_gradient source only
  double precision, public, protected :: mhd_uawsom_sigma = 0.d0
  !> Cartesian direction used for the prescribed density contrast and reflection gradient
  integer, public, protected :: mhd_uawsom_height_dim = -1
  !> Base transverse density contrast and filling factor
  double precision, public, protected :: mhd_uawsom_zeta0 = 5.d0
  double precision, public, protected :: mhd_uawsom_filling_factor = 0.1d0
  !> Physical input scales (lengths and magnetic field); converted to code units at init
  double precision, public, protected :: mhd_uawsom_zeta_scale = -1.d0
  double precision, public, protected :: mhd_uawsom_thread_radius0 = -1.d0
  double precision, public, protected :: mhd_uawsom_bref = -1.d0
  double precision, public, protected :: mhd_uawsom_alfven_corr_length0 = -1.d0
  !> Conserved wave-energy indices.  The plus variables propagate against B.
  integer, public, protected :: waplus_=-1, waminus_=-1, wkplus_=-1, wkminus_=-1
  !> Index of the cutoff temperature for the TRAC method
  integer, public, protected              :: tcoff_
  integer, public, protected              :: tweight_
  !> Indices of the tracers
  integer, allocatable, public, protected :: tracer(:)
  !> The number of waves
  integer :: nwwave=8
  !> Method type of divb in a integer for good performance
  integer :: type_divb
  !> To skip * layer of ghost cells during divB=0 fix for boundary
  integer, public, protected :: boundary_divbfix_skip(2*^nd)=0
  ! DivB cleaning methods
  integer, parameter :: divb_none          = 0
  integer, parameter :: divb_multigrid     = -1
  integer, parameter :: divb_glm           = 1
  integer, parameter :: divb_powel         = 2
  integer, parameter :: divb_janhunen      = 3
  integer, parameter :: divb_linde         = 4
  integer, parameter :: divb_lindejanhunen = 5
  integer, parameter :: divb_lindepowel    = 6
  integer, parameter :: divb_lindeglm      = 7
  integer, parameter :: divb_ct            = 8
  !> Whether an energy equation is used
  logical, public, protected              :: mhd_energy = .true.
  !> Whether thermal conduction is used
  logical, public, protected              :: mhd_thermal_conduction = .false.
  !> Whether radiative cooling is added
  logical, public, protected              :: mhd_radiative_cooling = .false.
  !> Whether thermal conduction is used
  logical, public, protected              :: mhd_hyperbolic_tc = .false.
  !> Whether saturation is considered for hyperbolic TC. When the perpendicular
  !> channel is active, the limiter uses sqrt(q_parallel^2+q_perp^2).
  logical, public, protected              :: mhd_hyperbolic_tc_sat = .false.
  !> Whether the perpendicular hyperbolic-TC channel is enabled
  logical, public, protected              :: mhd_hyperbolic_tc_use_perp = .false.
  !> Perpendicular hyperbolic-TC closure mode:
  !> 'off' = disabled
  !> 'fixed_reference' = fixed classical ratio at the reference normalisation
  !> 'weak_field_isotropization' = empirical transition using a prescribed Bmin
  !> 'electron_magnetization' = simplified ratio 1/(1+chi_e^2)
  character(len=std_len), public, protected :: mhd_hyperbolic_tc_perp_mode = 'off'
  !> Relative perpendicular hyperbolic-TC coefficient in fixed/strong-field limit:
  !> kappa_perp0 = mhd_hyperbolic_tc_kappa_perp_factor * kappa_parallel
  double precision, public, protected     :: mhd_hyperbolic_tc_kappa_perp_factor = 0.d0
  !> Field-strength transition scale for perpendicular closure
  double precision, public, protected     :: mhd_hyperbolic_tc_bmin = 0.d0
  !> Constant Coulomb logarithm used by the simplified electron-magnetization
  !> closure. It is a namelist parameter so changing it has no per-cell cost.
  double precision, public, protected     :: mhd_hyperbolic_tc_coulomb_log = 20.d0
  !> Whether viscosity is added
  logical, public, protected              :: mhd_viscosity = .false.
  !> Whether gravity is added
  logical, public, protected              :: mhd_gravity = .false.
  !> Whether rotating frame is activated
  logical, public, protected              :: mhd_rotating_frame = .false.
  !> Whether Hall-MHD is used
  logical, public, protected              :: mhd_hall = .false.
  !> Whether Ambipolar term is used
  logical, public, protected              :: mhd_ambipolar = .false.
  !> Whether Ambipolar term is implemented using supertimestepping
  logical, public, protected              :: mhd_ambipolar_sts = .false.
  !> Whether Ambipolar term is implemented explicitly
  logical, public, protected              :: mhd_ambipolar_exp = .false.
  !> Whether particles module is added
  logical, public, protected              :: mhd_particles = .false.
  !> Whether magnetofriction is added
  logical, public, protected              :: mhd_magnetofriction = .false.
  !> Whether GLM-MHD is used to control div B
  logical, public, protected              :: mhd_glm = .false.
  !> Whether extended GLM-MHD is used with additional sources
  logical, public, protected              :: mhd_glm_extended = .true.
  !> Whether TRAC method is used
  logical, public, protected              :: mhd_trac = .false.
  !> Which TRAC method is used
  integer, public, protected              :: mhd_trac_type=1
  !> Distance between two adjacent traced magnetic field lines (in finest cell size)
  integer, public, protected              :: mhd_trac_finegrid=4
  !> TRAC-7 (Johnston 2021, A&A 654 A2): target number of cells resolving the TR
  double precision, public, protected     :: mhd_trac_delta=0.5d0
  !> Whether internal energy is solved instead of total energy
  logical, public, protected              :: mhd_internal_e = .false.
  !> Whether hydrodynamic energy is solved instead of total energy
  logical, public, protected              :: mhd_hydrodynamic_e = .false.
  !> Whether divB cleaning sources are added splitting from fluid solver
  logical, public, protected              :: source_split_divb = .false.
  !> Whether semirelativistic MHD equations (Gombosi 2002 JCP) are solved
  logical, public, protected              :: mhd_semirelativistic = .false.
  !> Whether plasma is partially ionized
  !> Whether CAK radiation line force is activated
  logical, public, protected              :: mhd_cak_force = .false.
  !> Whether radiation-gas interaction is handled using flux limited diffusion
  logical, public, protected              :: mhd_radiation_fld = .false.
  logical, public, protected              :: mhd_fld_pradtensor= .true.
  !> Radiation fluid object (gas-EoS callbacks for FLD), wired in mhd_link_eos
  type(fld_fluid), allocatable, public    :: fld_fl
  !> whether split off equilibrium density and pressure
  logical, public :: has_equi_rho_and_p = .false.
  logical, public :: mhd_equi_thermal = .false.
  !> whether dump full variables (when splitting is used) in a separate dat file
  logical, public, protected              :: mhd_dump_full_vars = .false.
  !> Whether divB is computed with a fourth order approximation
  integer, public, protected :: mhd_divb_nth = 1
  !> Add divB wave in Roe solver
  logical, public :: divbwave     = .true.
  !> clean initial divB
  logical, public :: clean_initial_divb     = .false.
  !> To control divB=0 fix for boundary
  logical, public, protected :: boundary_divbfix(2*^nd)=.true.
  !> B0 field is force-free
  logical, public, protected :: b0field_forcefree=.true.
  !> Whether an total energy equation is used
  logical :: total_energy = .true.
  !> Whether numerical resistive heating is included when solving partial energy equation
  logical, public :: numerical_resistive_heating = .false.
  !> Whether gravity work is included in energy equation
  logical :: gravity_energy
  !> Method type to clean divergence of B
  character(len=std_len), public, protected :: typedivbfix  = 'linde'
  !> Method type of constrained transport
  character(len=std_len), public, protected :: type_ct  = 'uct_contact'
  !> Update all equations due to divB cleaning
  character(len=std_len) ::    typedivbdiff = 'all'
  !> type of fluid for thermal conduction
  type(tc_fluid), public, allocatable     :: tc_fl
  !> type of fluid for thermal emission synthesis
  type(te_fluid), public, allocatable     :: te_fl_mhd
  !> type of fluid for radiative cooling
  type(rc_fluid), public, allocatable     :: rc_fl
 
  !define the subroutine interface for the ambipolar mask
  abstract interface
 
    subroutine mask_subroutine(ixI^L,ixO^L,w,x,res)
      use mod_global_parameters
      integer, intent(in) :: ixi^l, ixo^l
      double precision, intent(in) :: x(ixi^s,1:ndim)
      double precision, intent(in) :: w(ixi^s,1:nw)
      double precision, intent(inout) :: res(ixi^s)
    end subroutine mask_subroutine
 
  end interface
 
  procedure(mask_subroutine), pointer  :: usr_mask_ambipolar => null()
  procedure(sub_small_values), pointer :: mhd_handle_small_values => null()
  ! Public methods
  public :: usr_mask_ambipolar
  public :: mhd_phys_init
  public :: mhd_get_v
  public :: mhd_get_rho
  public :: mhd_e_to_ei
  public :: mhd_ei_to_e
  public :: mhd_face_to_center
  public :: get_divb
  public :: get_current
  !> needed  public if we want to use the ambipolar coefficient in the user file
  public :: multiplyambicoef
  public :: get_normalized_divb
  public :: b_from_vector_potential
  public :: mhd_mag_en_all
  public :: mhd_uawsom_wave_energy_cell
  public :: mhd_uawsom_rho2_factor
  public :: mhd_uawsom_wave_pressure_cell
  public :: mhd_uawsom_rho2_factor_cell
  {^nooned
  public :: mhd_clean_divb_multigrid
  }
  ! Begin: following relevant for radiative MHD using FLD
  ! first four are local and only of interest for mod_usr applications
  ! where they can be used in diagnostics
  ! NOTE those with _prim expect primitives on entry
  public :: mhd_get_pthermal_plus_pradiation
  public :: mhd_get_csrad2
  public :: mhd_get_trad
  public :: mhd_get_pradiation_from_prim
  !    as pointer phys_get_csrad2
  public :: mhd_get_csrad2_prim
  ! End: following relevant for radiative MHD using FLD
  ! Removed orphan public declarations: mhd_get_Rfactor, mhd_get_temperature_from_prim,
  ! mhd_get_temperature_from_etot. These functions live in mod_mhd_eos.t and are
  ! reached via the eos% / phys_get_Rfactor / phys_get_tgas / phys_get_temperature
  ! procedure pointers bound by mod_mhd_eos:bind_eos_to_source.
 
contains
 
  !> Read this module"s parameters from a file
  subroutine mhd_read_params(files)
    use mod_global_parameters
    use mod_particles, only: particles_eta, particles_etah
    character(len=*), intent(in) :: files(:)
    integer                      :: n
 
    namelist /mhd_list/ mhd_energy, mhd_n_tracer, mhd_adiab,&
      mhd_eta, mhd_eta_hyper, mhd_etah, mhd_eta_ambi, mhd_glm_alpha, mhd_glm_extended, mhd_magnetofriction,&
      mhd_thermal_conduction, mhd_radiative_cooling, mhd_hall, mhd_ambipolar, mhd_ambipolar_sts, mhd_gravity,&
      mhd_rotating_frame,mhd_viscosity, typedivbfix, source_split_divb, divbdiff,&
      typedivbdiff, type_ct, divbwave, &
      h_ion_fr, he_ion_fr, he_ion_fr2, si_unit, b0field ,mhd_dump_full_vars,&
      b0field_forcefree, bdip, bquad, boct, busr, mhd_particles,&
      particles_eta, particles_etah,has_equi_rho_and_p,mhd_equi_thermal,&
      boundary_divbfix, boundary_divbfix_skip, mhd_divb_nth, mhd_semirelativistic,&
      mhd_reduced_c, clean_initial_divb, mhd_internal_e, numerical_resistive_heating,&
      mhd_hydrodynamic_e, mhd_trac, mhd_trac_type, mhd_trac_mask, mhd_trac_finegrid, &
      mhd_trac_delta, mhd_cak_force, &
      mhd_hyperbolic_tc, mhd_hyperbolic_tc_sat, mhd_hyperbolic_tc_kappa, &
      mhd_hyperbolic_tc_use_perp, mhd_hyperbolic_tc_perp_mode, &
      mhd_hyperbolic_tc_kappa_perp_factor, mhd_hyperbolic_tc_bmin, &
      mhd_hyperbolic_tc_coulomb_log, &
      mhd_radiation_fld,mhd_fld_pradtensor,mhd_fip, mhd_uawsom, mhd_uawsom_reflection, &
      mhd_uawsom_reflection_mode, mhd_uawsom_kink_reflection, &
      mhd_uawsom_sigma, mhd_uawsom_height_dim, mhd_uawsom_zeta0, &
      mhd_uawsom_filling_factor, mhd_uawsom_zeta_scale, &
      mhd_uawsom_thread_radius0, mhd_uawsom_bref, &
      mhd_uawsom_alfven_corr_length0
 
    do n = 1, size(files)
       open(unitpar, file=trim(files(n)), status="old")
       read(unitpar, mhd_list, end=111)
111    close(unitpar)
    end do
 
    ! He_abundance is set in eos_list and accessed via eos%He_abundance
 
  end subroutine mhd_read_params
 
  !> Write this module's parameters to a snapsoht
  subroutine mhd_write_info(fh)
    use mod_global_parameters
    integer, intent(in)                 :: fh
 
    integer                             :: er
    integer, parameter                  :: n_par = 1
    double precision                    :: values(n_par)
    integer, dimension(MPI_STATUS_SIZE) :: st
    character(len=name_len)             :: names(n_par)
 
    call mpi_file_write(fh, n_par, 1, mpi_integer, st, er)
 
    names(1) = "gamma"
    values(1) = eos%gamma
    call mpi_file_write(fh, values, n_par, mpi_double_precision, st, er)
    call mpi_file_write(fh, names, n_par * name_len, mpi_character, st, er)
  end subroutine mhd_write_info
 
  subroutine mhd_phys_init()
    use mod_global_parameters
    use mod_thermal_conduction
    use mod_radiative_cooling
    use mod_viscosity, only: viscosity_init
    use mod_gravity, only: gravity_init
    use mod_magnetofriction, only: magnetofriction_init
    use mod_rotating_frame, only: rotating_frame_init
    use mod_supertimestepping, only: sts_init, add_sts_method,&
            set_conversion_methods_to_head, set_error_handling_to_head
    use mod_cak_force, only: cak_init
    use mod_eos_pi_tables
    use mod_geometry
    use mod_usr_methods, only: usr_rfactor, usr_get_heating
    {^nooned
    use mod_multigrid_coupling
    }
    use mod_fld
 
    integer :: itr, idir
 
    call mhd_read_params(par_files)
    if(mhd_uawsom_height_dim < 0) mhd_uawsom_height_dim=ndim
 
    if(mhd_internal_e) then
      if(mhd_hydrodynamic_e) then
        mhd_hydrodynamic_e=.false.
        if(mype==0) write(*,*) 'WARNING: set mhd_hydrodynamic_e=F when mhd_internal_e=T'
      end if
      if(has_equi_rho_and_p) then
        has_equi_rho_and_p=.false.
        if(mype==0) write(*,*) 'WARNING: set has_equi_rho_and_p=F when mhd_internal_e=T'
      end if
    end if
 
    if(mhd_hydrodynamic_e) then
      if(mhd_internal_e) then
        mhd_internal_e=.false.
        if(mype==0) write(*,*) 'WARNING: set mhd_internal_e=F when mhd_hydrodynamic_e=T'
      end if
      if(b0field) then
        b0field=.false.
        if(mype==0) write(*,*) 'WARNING: set B0field=F when mhd_hydrodynamic_e=T'
      end if
      if(has_equi_rho_and_p) then
        has_equi_rho_and_p=.false.
        if(mype==0) write(*,*) 'WARNING: set has_equi_rho_and_p=F when mhd_hydrodynamic_e=T'
      end if
    end if
 
    if(mhd_semirelativistic) then
      if(b0field) then
        b0field=.false.
        if(mype==0) write(*,*) 'WARNING: set B0field=F when mhd_semirelativistic=T'
      endif
      if(has_equi_rho_and_p) then
        has_equi_rho_and_p=.false.
        if(mype==0) write(*,*) 'WARNING: set has_equi_rho_and_p=F when mhd_semirelativistic=T'
      end if
      if(mhd_hydrodynamic_e) then
        mhd_hydrodynamic_e=.false.
        if(mype==0) write(*,*) 'WARNING: set mhd_hydrodynamic_e=F when mhd_semirelativistic=T'
      end if
    end if
 
    if(.not. mhd_energy) then
      if(mhd_internal_e) then
        mhd_internal_e=.false.
        if(mype==0) write(*,*) 'WARNING: set mhd_internal_e=F when mhd_energy=F'
      end if
      if(mhd_hydrodynamic_e) then
        mhd_hydrodynamic_e=.false.
        if(mype==0) write(*,*) 'WARNING: set mhd_hydrodynamic_e=F when mhd_energy=F'
      end if
      if(mhd_thermal_conduction) then
        mhd_thermal_conduction=.false.
        if(mype==0) write(*,*) 'WARNING: set mhd_thermal_conduction=F when mhd_energy=F'
      end if
      if(mhd_hyperbolic_tc) then
        mhd_hyperbolic_tc=.false.
        if(mype==0) write(*,*) 'WARNING: set mhd_hyperbolic_tc=F when mhd_energy=F'
      end if
      if(mhd_radiative_cooling) then
        mhd_radiative_cooling=.false.
        if(mype==0) write(*,*) 'WARNING: set mhd_radiative_cooling=F when mhd_energy=F'
      end if
      if(mhd_trac) then
        mhd_trac=.false.
        if(mype==0) write(*,*) 'WARNING: set mhd_trac=F when mhd_energy=F'
      end if
      if(b0field) then
        b0field=.false.
        if(mype==0) write(*,*) 'WARNING: set B0field=F when mhd_energy=F'
      end if
      if(has_equi_rho_and_p) then
        has_equi_rho_and_p=.false.
        if(mype==0) write(*,*) 'WARNING: set has_equi_rho_and_p=F when mhd_energy=F'
      end if
    end if
 
    if(mhd_thermal_conduction .and. mhd_hyperbolic_tc) then
      mhd_thermal_conduction=.false.
      if(mype==0) write(*,*) 'WARNING: set either parabolic TC or hyperbolic TC to F'
      if(mype==0) write(*,*) 'WARNING: defaulting to only mhd_hyperbolic_tc=T'
    end if
    {^ifoned
    if (mhd_hyperbolic_tc .and. mhd_hyperbolic_tc_use_perp) then
      call mpistop("mhd_hyperbolic_tc_use_perp is not supported in 1D")
    end if
    }
 
    physics_type = "mhd"
    phys_energy=mhd_energy
    phys_internal_e=mhd_internal_e
    phys_trac=mhd_trac
    phys_trac_type=mhd_trac_type
 
    phys_gamma = eos%gamma
    phys_trac_finegrid=mhd_trac_finegrid
 
    if(mhd_energy) then
      if(mhd_internal_e.or.mhd_hydrodynamic_e) then
        total_energy=.false.
      else
        numerical_resistive_heating=.false.
        total_energy=.true.
      end if
    else
      total_energy=.false.
    end if
    phys_total_energy=total_energy
    if(mhd_energy) then
      if(mhd_internal_e) then
        gravity_energy=.false.
      else
        gravity_energy=.true.
      end if
    else
      gravity_energy=.false.
    end if
 
    {^ifoned
    if(mhd_trac .and. mhd_trac_type .gt. 2) then
      mhd_trac_type=1
      if(mype==0) write(*,*) 'WARNING: reset mhd_trac_type=1 for 1D simulation'
    end if
    }
    if(mhd_trac .and. mhd_trac_type .le. 4) then
      mhd_trac_mask=bigdouble
      if(mype==0) write(*,*) 'WARNING: set mhd_trac_mask==bigdouble for global TRAC method'
    end if
    if(mhd_trac .and. mhd_trac_type==7) then
      ! per-cell local TRAC (Johnston 2021) needs the background heating rate for the
      ! steady-state balance; it is field-aligned and per-cell, so no global trac_mask is used.
      if(.not. associated(usr_get_heating)) &
        call mpistop("mhd_trac_type=7 requires usr_get_heating to be set in mod_usr.t")
    end if
    phys_trac_mask=mhd_trac_mask
 
    use_particles=mhd_particles
    if(ndim==1) typedivbfix='none'
    select case (typedivbfix)
    case ('none')
       type_divb = divb_none
    {^nooned
    case ('multigrid')
       if(mhd_radiation_fld) call mpistop('To verify whether mg usage for FLD versus divB can be combined')
       type_divb = divb_multigrid
       use_multigrid = .true.
       mg%operator_type = mg_laplacian
       phys_global_source_after => mhd_clean_divb_multigrid
    }
    case ('glm')
      mhd_glm          = .true.
      need_global_cmax = .true.
      type_divb        = divb_glm
    case ('powel', 'powell')
      type_divb = divb_powel
    case ('janhunen')
      type_divb = divb_janhunen
    case ('linde')
      type_divb = divb_linde
    case ('lindejanhunen')
      type_divb = divb_lindejanhunen
    case ('lindepowel')
      type_divb = divb_lindepowel
    case ('lindeglm')
      mhd_glm          = .true.
      need_global_cmax = .true.
      type_divb        = divb_lindeglm
    case ('ct')
      type_divb = divb_ct
      stagger_grid = .true.
    case default
      call mpistop('Unknown divB fix')
    end select
 
    allocate(start_indices(number_species),stop_indices(number_species))
    ! set the index of the first flux variable for species 1
    start_indices(1)=1
    ! Determine flux variables
    rho_ = var_set_rho()
 
    allocate(mom(ndir))
    mom(:) = var_set_momentum(ndir)
    m^c_=mom(^c);
 
    ! Set index of energy variable
    if (mhd_energy) then
      nwwave = 8
      e_     = var_set_energy() ! energy density
      p_     = e_               ! gas pressure
    else
      nwwave = 7
      e_     = -1
      p_     = -1
    end if
 
    allocate(mag(ndir))
    mag(:) = var_set_bfield(ndir)
    b^c_=mag(^c);
 
    if (mhd_glm) then
      psi_ = var_set_fluxvar('psi', 'psi', need_bc=.false.)
    else
      psi_ = -1
    end if
 
    if(mhd_hyperbolic_tc) then
      qpar_ = var_set_fluxvar('q', 'q', need_bc=.false.)
      if(mhd_hyperbolic_tc_use_perp) then
        qperp_ = var_set_fluxvar('qperp', 'qperp', need_bc=.false.)
      else
        qperp_ = -1
      end if
      need_global_cmax=.true.
    else
      qpar_ = -1
      qperp_ = -1
    end if
 
    if (mhd_fip) then
      fip_ = var_set_fluxvar('rho_fip', 'fip', need_bc=.false.)
    else
      fip_ = -1
    end if
 
    if (mhd_uawsom) then
      waplus_  = var_set_fluxvar('wAplus',  'wAplus')
      waminus_ = var_set_fluxvar('wAminus', 'wAminus')
      wkplus_  = var_set_fluxvar('wkplus',  'wkplus')
      wkminus_ = var_set_fluxvar('wkminus', 'wkminus')
    else
      waplus_=-1; waminus_=-1; wkplus_=-1; wkminus_=-1
    end if
 
    allocate(tracer(mhd_n_tracer))
    ! Set starting index of tracers
    do itr = 1, mhd_n_tracer
      tracer(itr) = var_set_fluxvar("trc", "trp", itr, need_bc=.false.)
    end do
 
    if(mhd_radiation_fld)then
       if(mhd_cak_force)then
          if(mype==0) then
            write(*,*)'Warning: CAK force addition together with FLD radiation'
          endif
       endif
       if(mhd_radiative_cooling)then
          if(mype==0) then
            write(*,*)'Warning: Optically thin cooling together with FLD radiation'
          endif
       endif
       if(.not.mhd_energy)then
          call mpistop('using FLD implies the use of an energy equation, set mhd_energy=T')
       else
          if(mhd_semirelativistic)then
            call mpistop('using FLD not yet with semirelativistic energy formalism')
          endif
          if(mhd_hydrodynamic_e.or.mhd_internal_e)then
            call mpistop('using FLD not yet with hydrodynamic or internal energy formalism')
          endif
          if(has_equi_rho_and_p)then
            call mpistop('using FLD not yet with split off rho and p')
          endif
          ! Note: so far ok with total energy equation but allow both split or unsplit B0
          !> set added variable and equation for radiation energy
          r_e = var_set_radiation_energy()
          phys_get_csrad2          => mhd_get_csrad2_prim
          !> Radiation fluid object: its EoS callbacks are wired in mhd_link_eos
          allocate(fld_fl)
          !> Initiate radiation-closure module
          call fld_init()
          !> The implicit (MG diffusion) hooks need the fld_fl object, so they
          !> are wired here to physics-module wrappers that inject it.
          if(use_multigrid)then
             phys_implicit_update   => mhd_fld_implicit_update
             phys_evaluate_implicit => mhd_fld_evaluate_implicit
          endif
       endif
    else
      r_e=-1
    endif
 
    ! LTE/PI electron-density and temperature aux variables. These must be registered
    ! after every flux variable (including the FLD radiation energy r_e and any tracers):
    ! var_set_radiation_energy indexes by nwflux, so if r_e is registered after these
    ! nw-indexed aux vars its nwflux slot collides with Ne_ (iw_r_e==iw_ne) and overwrites
    ! its name. Registering them here keeps the flux block contiguous.
    if (eos%eos_type == 'LTE') then
      ne_ = var_set_ne()
      te_ = var_set_te()
    else if (eos%eos_type == 'PI') then
      ne_ = -1
      te_ = var_set_te()
    else
      ne_ = -1
      te_ = -1
    end if
 
    ! set number of variables which need update ghostcells
    ! set number of variables which need update ghostcells.
    ! The EoS-derived slots Ne/Te are derived state that must stay consistent with (rho,e)
    ! wherever the conserved state is valid, so they have to travel with it. var_set_ne /
    ! var_set_te bump nw but neither nwflux nor nwaux, so the historic nwflux+nwaux silently
    ! excluded them: they were never communicated, only derived, and every ghost cell held
    ! zero until something derived it. Extend the window to whichever of them exist (they are
    ! registered contiguously just above); FI leaves both at -1 and the window is unchanged.
    ! bc_phys is unaffected -- it iterates nwflux+nwaux independently.
    nwgc=nwflux+nwaux
    if (iw_ne > 0) nwgc = max(nwgc, iw_ne)
    if (iw_te > 0) nwgc = max(nwgc, iw_te)
 
    ! set the index of the last flux variable for species 1
    stop_indices(1)=nwflux
 
    ! set cutoff temperature when using the TRAC method, as well as an auxiliary weight
    tweight_ = -1
    if(mhd_trac) then
      tcoff_ = var_set_wextra()
      iw_tcoff=tcoff_
      if(mhd_trac_type .ge. 3) then
        tweight_ = var_set_wextra()
      endif
    else
      tcoff_ = -1
    end if
 
    ! set indices of equi vars and update number_equi_vars
    number_equi_vars = 0
    if(has_equi_rho_and_p) then
      number_equi_vars = number_equi_vars + 1
      equi_rho0_ = number_equi_vars
      iw_equi_rho = equi_rho0_
      number_equi_vars = number_equi_vars + 1
      equi_pe0_ = number_equi_vars
      iw_equi_p = equi_pe0_
    endif
    ! determine number of stagger variables
    nws=ndim
 
    nvector      = 2 ! No. vector vars
    allocate(iw_vector(nvector))
    iw_vector(1) = mom(1) - 1
    iw_vector(2) = mag(1) - 1
 
    ! Check whether custom flux types have been defined
    if (.not. allocated(flux_type)) then
       allocate(flux_type(ndir, nwflux))
       flux_type = flux_default
    else if (any(shape(flux_type) /= [ndir, nwflux])) then
       call mpistop("phys_check error: flux_type has wrong shape")
    end if
 
    if(nwflux>mag(ndir)) then
      ! for flux of tracers, using hll flux
      flux_type(:,mag(ndir)+1:nwflux)=flux_hll
    end if
 
    if(ndim>1) then
      if(mhd_glm) then
        flux_type(:,psi_)=flux_special
        do idir=1,ndir
          flux_type(idir,mag(idir))=flux_special
        end do
      else
        do idir=1,ndir
          flux_type(idir,mag(idir))=flux_tvdlf
        end do
      end if
    end if
 
    phys_get_rho             => mhd_get_rho
    phys_get_dt              => mhd_get_dt
    if(mhd_semirelativistic) then
      if(mhd_energy) then
        phys_get_cmax            => mhd_get_cmax_semirelati
      else
        phys_get_cmax            => mhd_get_cmax_semirelati_noe
      end if
    else
      if(mhd_energy) then
        phys_get_cmax            => mhd_get_cmax_origin
      else
        phys_get_cmax            => mhd_get_cmax_origin_noe
      end if
    end if
    phys_get_tcutoff         => mhd_get_tcutoff
    phys_get_h_speed         => mhd_get_h_speed
    if(has_equi_rho_and_p) then
      phys_get_cbounds         => mhd_get_cbounds_split_rho
    else if(mhd_semirelativistic) then
      phys_get_cbounds         => mhd_get_cbounds_semirelati
    else
      phys_get_cbounds         => mhd_get_cbounds
    end if
 
    !> EOS module: phys_to_primitive / phys_to_conserved are bound by
    !> mod_mhd_eos:bind_eos_to_source to route through the EoS layer;
    !> mhd_to_primitive / mhd_to_conserved pointers are NOT used - every
    !> call to convert state goes through eos%to_primitive / eos%to_conserved.
    !> eos%inv_squared_c{0,} are set in mhd_physical_units (called below)
    !> after inv_squared_c{0,} are computed.
    if(mhd_hydrodynamic_e) then
      phys_get_flux            => mhd_get_flux_hde
    else if(mhd_semirelativistic) then
      if(mhd_energy) then
        phys_get_flux            => mhd_get_flux_semirelati
      else
        phys_get_flux            => mhd_get_flux_semirelati_noe
      end if
    else
      if(b0field.or.has_equi_rho_and_p) then
        phys_get_flux            => mhd_get_flux_split
      else if(mhd_energy) then
        phys_get_flux            => mhd_get_flux
      else
        phys_get_flux            => mhd_get_flux_noe
      end if
    end if
    phys_get_v                 => mhd_get_v
    if(mhd_semirelativistic) then
      phys_add_source_geom     => mhd_add_source_geom_semirelati
    else if(b0field.or.has_equi_rho_and_p) then
      phys_add_source_geom     => mhd_add_source_geom_split
    else
      phys_add_source_geom     => mhd_add_source_geom
    end if
    phys_add_source          => mhd_add_source
    phys_check_params        => mhd_check_params
    phys_write_info          => mhd_write_info
 
    if(mhd_internal_e) then
      phys_handle_small_values => mhd_handle_small_values_inte
      mhd_handle_small_values  => mhd_handle_small_values_inte
      phys_check_w             => mhd_check_w_inte
    else if(mhd_hydrodynamic_e) then
      phys_handle_small_values => mhd_handle_small_values_hde
      mhd_handle_small_values  => mhd_handle_small_values_hde
      phys_check_w             => mhd_check_w_hde
    else if(mhd_semirelativistic) then
      phys_handle_small_values => mhd_handle_small_values_semirelati
      mhd_handle_small_values  => mhd_handle_small_values_semirelati
      phys_check_w             => mhd_check_w_semirelati
    else if(has_equi_rho_and_p) then
      phys_handle_small_values => mhd_handle_small_values_split
      mhd_handle_small_values  => mhd_handle_small_values_split
      phys_check_w             => mhd_check_w_split
    else if(mhd_energy) then
      phys_handle_small_values => mhd_handle_small_values_origin
      mhd_handle_small_values  => mhd_handle_small_values_origin
      phys_check_w             => mhd_check_w_origin
    else
      phys_handle_small_values => mhd_handle_small_values_noe
      mhd_handle_small_values  => mhd_handle_small_values_noe
      phys_check_w             => mhd_check_w_noe
    end if
 
    ! phys_get_pthermal is set by mhd_link_eos
 
    if(number_equi_vars>0) then
      phys_set_equi_vars => set_equi_vars_grid
    endif
 
    if(type_divb==divb_glm) then
      phys_modify_wlr => mhd_modify_wlr
    end if
 
    ! Rfactor / temperature / pthermal pointers are bound by
    ! mod_mhd_eos:bind_eos_to_source (called by mhd_link_eos immediately
    ! after mhd_phys_init). No EoS machinery in mod_mhd_phys.t.
 
    ! if using ct stagger grid, boundary divb=0 is not done here
    if(stagger_grid) then
      select case(type_ct)
      case('average')
        transverse_ghost_cells = 1
        phys_get_ct_velocity => mhd_get_ct_velocity_average
        phys_update_faces => mhd_update_faces_average
      case('uct_contact')
        transverse_ghost_cells = 1
        phys_get_ct_velocity => mhd_get_ct_velocity_contact
        phys_update_faces => mhd_update_faces_contact
      case('uct_hll')
        transverse_ghost_cells = 2
        phys_get_ct_velocity => mhd_get_ct_velocity_hll
        phys_update_faces => mhd_update_faces_hll
      case default
        call mpistop('choose average, uct_contact,or uct_hll for type_ct!')
      end select
      phys_face_to_center => mhd_face_to_center
      phys_modify_wlr => mhd_modify_wlr
    else if(ndim>1) then
      phys_boundary_adjust => mhd_boundary_adjust
    end if
 
    {^nooned
    ! clean initial divb
    if(clean_initial_divb.and.mhd_radiation_fld) &
       call mpistop('To verify whether mg usage for FLD versus divB can be combined')
    if(clean_initial_divb) phys_clean_divb => mhd_clean_divb_multigrid
    }
 
    ! derive units from basic units
    call mhd_physical_units()
 
    if(mhd_uawsom) then
      ! Namelist inputs are physical quantities, following the normal AMRVAC
      ! convention for this module (cm/G in cgs, m/T in SI).
      if(mhd_uawsom_zeta_scale == -one) &
        mhd_uawsom_zeta_scale=merge(3.4805d9,3.4805d11,si_unit)
      if(mhd_uawsom_thread_radius0 == -one) &
        mhd_uawsom_thread_radius0=merge(1.d5,1.d7,si_unit)
      if(mhd_uawsom_bref == -one) &
        mhd_uawsom_bref=merge(1.d-3,10.d0,si_unit)
      if(mhd_uawsom_alfven_corr_length0 == -one) &
        mhd_uawsom_alfven_corr_length0=merge(1.5d7,1.5d9,si_unit)
      mhd_uawsom_zeta_scale = mhd_uawsom_zeta_scale/unit_length
      mhd_uawsom_thread_radius0 = mhd_uawsom_thread_radius0/unit_length
      mhd_uawsom_bref = mhd_uawsom_bref/unit_magneticfield
      mhd_uawsom_alfven_corr_length0 = &
           mhd_uawsom_alfven_corr_length0/unit_length
    end if
 
    if(mhd_hyperbolic_tc) then
      if(mhd_hyperbolic_tc_kappa==0.d0) then
        if(si_unit) then
          mhd_hyperbolic_tc_kappa=8.d-12*unit_temperature**3.5d0/unit_length/unit_density/unit_velocity**3
        else
          mhd_hyperbolic_tc_kappa=8.d-7*unit_temperature**3.5d0/unit_length/unit_density/unit_velocity**3
        end if
      else
        mhd_hyperbolic_tc_constant=.true.
      end if
    
      if(mhd_hyperbolic_tc_use_perp) then
        select case(trim(mhd_hyperbolic_tc_perp_mode))
        case('fixed_reference')
          if(mhd_hyperbolic_tc_kappa_perp_factor==0.d0) then
            if(si_unit) then
              mhd_hyperbolic_tc_kappa_perp_factor = 4.d-30 * &
                unit_numberdensity**2 / unit_magneticfield**2 / unit_temperature**3
            else
              mhd_hyperbolic_tc_kappa_perp_factor = 4.d-10 * &
                unit_numberdensity**2 / unit_magneticfield**2 / unit_temperature**3
            end if
          end if
        case('weak_field_isotropization')
          if(mhd_hyperbolic_tc_bmin==0.d0) then
            mhd_hyperbolic_tc_bmin=0.1d0/unit_magneticfield
          end if
        case('electron_magnetization')
          if(mhd_hyperbolic_tc_coulomb_log<=zero) then
            call mpistop("mhd_hyperbolic_tc_coulomb_log must be positive")
          end if
        case default
          call mpistop("invalid mhd_hyperbolic_tc_perp_mode: "// &
               trim(mhd_hyperbolic_tc_perp_mode))
        end select
      end if
    end if
    if(.not. mhd_energy .and. mhd_thermal_conduction) then
      call mpistop("thermal conduction needs mhd_energy=T")
    end if
    if(.not. mhd_energy .and. mhd_hyperbolic_tc) then
      call mpistop("hyperbolic thermal conduction needs mhd_energy=T")
    end if
    if(.not. mhd_energy .and. mhd_radiative_cooling) then
      call mpistop("radiative cooling needs mhd_energy=T")
    end if
 
    !> Cache log10(nH) in wextra for LTE+IonE TC (density invariant during STS)
    if (eos%eos_type == 'LTE' .and. eos%ionE .and. mhd_thermal_conduction) then
        iw_log_nh = var_set_wextra()
    end if
 
    if(mhd_equi_thermal)then
       if((.not.has_equi_rho_and_p).or.(.not.total_energy))then
          mhd_equi_thermal=.false.
          if(mype==0) write(*,*) 'WARNING: turning mhd_equi_thermal=F as no splitting or total e in use'
       else
          if(mhd_thermal_conduction.or.mhd_radiative_cooling)then
            if(mype==0) write(*,*) 'Will subtract thermal balance in TC or RC with mhd_equi_thermal=T'
          else
            mhd_equi_thermal=.false.
            if(mype==0) write(*,*) 'WARNING: turning mhd_equi_thermal=F as no TC or RC in use'
          endif
       endif
    endif
 
    ! initialize thermal conduction module
    if (mhd_thermal_conduction) then
      call sts_init()
      call tc_init_params(eos%gamma)
 
      allocate(tc_fl)
      call tc_get_mhd_params(tc_fl,tc_params_read_mhd)
      if(ndim==1) then
        call add_sts_method(mhd_get_tc_dt_hd,mhd_sts_set_source_tc_hd,e_,1,e_,1,.false.)
      else
        call add_sts_method(mhd_get_tc_dt_mhd,mhd_sts_set_source_tc_mhd,e_,1,e_,1,.false.)
      endif
      ! TC function pointers (get_temperature_from_conserved/eint, get_rho,
      ! get_temperature_equi, get_rho_equi, subtract_equi) are bound by
      ! bind_eos_to_source in mod_mhd_eos.t to the correct EoS-aware
      ! implementations. No EoS machinery in mod_mhd_phys.t.
      if(.not.mhd_internal_e) then
        if(mhd_hydrodynamic_e) then
          call set_conversion_methods_to_head(mhd_e_to_ei_hde, mhd_ei_to_e_hde)
          phys_e_to_ei => mhd_e_to_ei_hde
          phys_ei_to_e => mhd_ei_to_e_hde
        else if(mhd_semirelativistic) then
          call set_conversion_methods_to_head(mhd_e_to_ei_semirelati, mhd_ei_to_e_semirelati)
          phys_e_to_ei => mhd_e_to_ei_semirelati
          phys_ei_to_e => mhd_ei_to_e_semirelati
        else
          if (iw_log_nh > 0) then
            call set_conversion_methods_to_head(mhd_e_to_ei_and_cache_log_nh, mhd_ei_to_e)
          else
            call set_conversion_methods_to_head(mhd_e_to_ei, mhd_ei_to_e)
          end if
          phys_e_to_ei => mhd_e_to_ei
          phys_ei_to_e => mhd_ei_to_e
        end if
      end if
      call set_error_handling_to_head(mhd_tc_handle_small_e)
      tc_fl%e_ = e_
      tc_fl%Tcoff_ = tcoff_
    end if
 
    ! Energy conversion pointers needed by EOS module regardless of TC method
    if(.not.mhd_internal_e .and. .not.associated(phys_e_to_ei)) then
      if(mhd_hydrodynamic_e) then
        phys_e_to_ei => mhd_e_to_ei_hde
        phys_ei_to_e => mhd_ei_to_e_hde
      else if(mhd_semirelativistic) then
        phys_e_to_ei => mhd_e_to_ei_semirelati
        phys_ei_to_e => mhd_ei_to_e_semirelati
      else
        phys_e_to_ei => mhd_e_to_ei
        phys_ei_to_e => mhd_ei_to_e
      end if
    end if
 
    ! Initialize radiative cooling module
    if (mhd_radiative_cooling) then
      call radiative_cooling_init_params(eos%gamma,eos%He_abundance)
      allocate(rc_fl)
      rc_fl%fip_ = fip_
      call radiative_cooling_init(rc_fl,rc_params_read)
      rc_fl%e_ = e_
      rc_fl%Tcoff_ = tcoff_
      rc_fl%subtract_equi = has_equi_rho_and_p
      ! rc_fl EoS pointers (get_rho, get_pthermal, get_var_Rfactor,
      ! equi accessors, subtract_equi) are bound by bind_eos_to_source
      ! in mod_mhd_eos.t. No EoS machinery in mod_mhd_phys.t.
    end if
    allocate(te_fl_mhd)
    ! te_fl_mhd EoS pointers are bound by bind_eos_to_source in mod_mhd_eos.t
{^ifthreed
    phys_te_images => mhd_te_images
}
 
    ! consistency check for hyperresistivity implementation
    if (mhd_eta_hyper>0.0d0) then
      if(mype==0) then
         write(*,*) '*****Using hyperresistivity:  with mhd_eta_hyper :', mhd_eta_hyper
      endif
       if(b0field) then
        ! hyperresistivity not ok yet with splitting
        call mpistop("Must have B0field=F when using hyperresistivity")
      end if
    endif
    if (mhd_eta_hyper<0.0d0) then
        call mpistop("Must have mhd_eta_hyper positive when using hyperresistivity")
    endif
 
    ! Initialize viscosity module
    if (mhd_viscosity) then
       call viscosity_init(phys_wider_stencil)
    end if
 
    ! Initialize gravity module
    if(mhd_gravity) then
      call gravity_init()
    end if
 
    ! Initialize rotating frame module
    if(mhd_rotating_frame) then
      if(has_equi_rho_and_p) then
        ! mod_rotating_frame does not handle splitting of density
        call mpistop("Must have has_equi_rho_and_p=F when mhd_rotating_frame=T")
      end if
      call rotating_frame_init()
    endif
 
 
    ! initialize magnetofriction module
    if(mhd_magnetofriction) then
      call magnetofriction_init()
    end if
 
    if(mhd_hall) then
      if(mhd_semirelativistic) then
        ! semirelativistic does not incorporate hall terms
        call mpistop("Must have mhd_hall=F when mhd_semirelativistic=T")
      end if
      if(coordinate>1)then
        ! normal unsplit case or split cases do not have geometric sources for Hall included
        call mpistop("Must have Cartesian coordinates for Hall")
      endif
      ! For Hall, we need one more reconstructed layer since currents are computed
      ! in mhd_get_flux: assuming one additional ghost layer added in nghostcells.
      phys_wider_stencil = 1
    end if
 
    ! The perpendicular HTC geometry evaluates a fourth-order centred
    ! temperature gradient inside the reconstructed flux layer. It therefore
    ! needs one layer beyond the default two ghost cells.
    if(mhd_hyperbolic_tc .and. mhd_hyperbolic_tc_use_perp) then
      phys_wider_stencil=max(phys_wider_stencil,1)
    end if
 
    if(mhd_ambipolar) then
      if(mhd_ambipolar_sts) then
        call sts_init()
        if(mhd_internal_e.or.mhd_hydrodynamic_e) then
          call add_sts_method(get_ambipolar_dt,sts_set_source_ambipolar,mag(1),&
               ndir,mag(1),ndir,.true.)
        else
          ! any total energy or no energy at all case is handled here
          call add_sts_method(get_ambipolar_dt,sts_set_source_ambipolar,mom(ndir)+1,&
               mag(ndir)-mom(ndir),mag(1),ndir,.true.)
        end if
      else
        mhd_ambipolar_exp=.true.
        ! For flux ambipolar term, we need one more reconstructed layer since currents are computed
        ! in mhd_get_flux: assuming one additional ghost layer added in nghostcells.
        phys_wider_stencil = 1
      end if
    end if
 
    ! ionization-degree table init now lives in eos_finalise (eos% owns
    ! thermodynamic-backend init, parallel to LTE tables); see mod_eos_PI.
 
    ! Initialize CAK radiation force module
    if (mhd_cak_force) then
       if(mhd_internal_e.or.mhd_semirelativistic) then
          call mpistop("CAK implementation not available in internal or semirelativistic variants")
       endif
       if(has_equi_rho_and_p) then
          call mpistop("CAK force implementation not available for split off pressure and density")
       endif
       call cak_init(eos%gamma)
    endif
 
  end subroutine mhd_phys_init
 
{^ifthreed
  subroutine mhd_te_images
    use mod_global_parameters
    use mod_thermal_emission
 
    select case(convert_type)
      case('EIvtiCCmpi','EIvtuCCmpi')
        call get_euv_image(unitconvert,te_fl_mhd)
      case('ESvtiCCmpi','ESvtuCCmpi')
        call get_euv_spectrum(unitconvert,te_fl_mhd)
      case('SIvtiCCmpi','SIvtuCCmpi')
        call get_sxr_image(unitconvert,te_fl_mhd)
      case('WIvtiCCmpi','WIvtuCCmpi')
        call get_whitelight_image(unitconvert,te_fl_mhd)
      case default
        call mpistop("Error in synthesize emission: Unknown convert_type")
      end select
  end subroutine mhd_te_images
}
 
!!start th cond
  ! wrappers for STS functions in thermal_conductivity module
  ! which take as argument the tc_fluid (defined in the physics module)
  subroutine  mhd_sts_set_source_tc_mhd(ixI^L,ixO^L,w,x,wres,fix_conserve_at_step,my_dt,igrid,nflux)
    use mod_global_parameters
    use mod_fix_conserve
    use mod_thermal_conduction, only: sts_set_source_tc_mhd
    integer, intent(in) :: ixi^l, ixo^l, igrid, nflux
    double precision, intent(in) ::  x(ixi^s,1:ndim)
    double precision, intent(inout) ::  wres(ixi^s,1:nw), w(ixi^s,1:nw)
    double precision, intent(in) :: my_dt
    logical, intent(in) :: fix_conserve_at_step
    call sts_set_source_tc_mhd(ixi^l,ixo^l,w,x,wres,fix_conserve_at_step,my_dt,igrid,nflux,tc_fl)
  end subroutine mhd_sts_set_source_tc_mhd
 
  subroutine  mhd_sts_set_source_tc_hd(ixI^L,ixO^L,w,x,wres,fix_conserve_at_step,my_dt,igrid,nflux)
    use mod_global_parameters
    use mod_fix_conserve
    use mod_thermal_conduction, only: sts_set_source_tc_hd
    integer, intent(in) :: ixi^l, ixo^l, igrid, nflux
    double precision, intent(in) ::  x(ixi^s,1:ndim)
    double precision, intent(inout) ::  wres(ixi^s,1:nw), w(ixi^s,1:nw)
    double precision, intent(in) :: my_dt
    logical, intent(in) :: fix_conserve_at_step
    call sts_set_source_tc_hd(ixi^l,ixo^l,w,x,wres,fix_conserve_at_step,my_dt,igrid,nflux,tc_fl)
  end subroutine mhd_sts_set_source_tc_hd
 
  function mhd_get_tc_dt_mhd(w,ixI^L,ixO^L,dx^D,x) result(dtnew)
    !Check diffusion time limit dt < dx_i**2/((gamma-1)*tc_k_para_i/rho)
    !where                      tc_k_para_i=tc_k_para*B_i**2/B**2
    !and                        T=p/rho
    use mod_global_parameters
    use mod_thermal_conduction, only: get_tc_dt_mhd
 
    integer, intent(in) :: ixi^l, ixo^l
    double precision, intent(in) :: dx^d, x(ixi^s,1:ndim)
    double precision, intent(in) :: w(ixi^s,1:nw)
    double precision :: dtnew
 
    dtnew=get_tc_dt_mhd(w,ixi^l,ixo^l,dx^d,x,tc_fl)
  end function mhd_get_tc_dt_mhd
 
  function mhd_get_tc_dt_hd(w,ixI^L,ixO^L,dx^D,x) result(dtnew)
    !Check diffusion time limit dt < dx_i**2/((gamma-1)*tc_k_para_i/rho)
    !where                      tc_k_para_i=tc_k_para*B_i**2/B**2
    !and                        T=p/rho
    use mod_global_parameters
    use mod_thermal_conduction, only: get_tc_dt_hd
 
    integer, intent(in) :: ixi^l, ixo^l
    double precision, intent(in) :: dx^d, x(ixi^s,1:ndim)
    double precision, intent(in) :: w(ixi^s,1:nw)
    double precision :: dtnew
 
    dtnew=get_tc_dt_hd(w,ixi^l,ixo^l,dx^d,x,tc_fl)
  end function mhd_get_tc_dt_hd
 
  subroutine mhd_tc_handle_small_e(w, x, ixI^L, ixO^L, step)
    use mod_global_parameters
 
    integer, intent(in)             :: ixi^l,ixo^l
    double precision, intent(inout) :: w(ixi^s,1:nw)
    double precision, intent(in)    :: x(ixi^s,1:ndim)
    integer, intent(in)    :: step
    character(len=140) :: error_msg
 
    ! tc_patch_eint repairs w(:, e_) in place during the source-term call,
    ! but the Chebyshev recurrence can still produce residual negative
    ! e_int in the updated state.  Run mhd_handle_small_ei every substep
    ! (patch on or off) so STS does not propagate negative e through.
    write(error_msg,"(a,i3)") "Thermal conduction step ", step
    call mhd_handle_small_ei(w,x,ixi^l,ixo^l,e_,error_msg)
  end subroutine mhd_tc_handle_small_e
 
  ! fill in tc_fluid fields from namelist
  subroutine tc_params_read_mhd(fl)
    use mod_global_parameters, only: unitpar,par_files,unit_temperature
    type(tc_fluid), intent(inout) :: fl
 
    double precision :: tc_k_para=0d0
    double precision :: tc_k_perp=0d0
    integer                      :: n
    ! list parameters
    logical :: tc_perpendicular=.false.
    logical :: tc_saturate=.false.
    logical :: tc_patch_eint=.false.
    double precision :: trac_t_floor=0.d0
    character(len=std_len)  :: tc_slope_limiter="MC"
 
    namelist /tc_list/ tc_perpendicular, tc_saturate, tc_slope_limiter, tc_k_para, tc_k_perp, tc_patch_eint, trac_t_floor
 
    do n = 1, size(par_files)
      open(unitpar, file=trim(par_files(n)), status="old")
      read(unitpar, tc_list, end=111)
111     close(unitpar)
    end do
 
    fl%tc_perpendicular = tc_perpendicular
    fl%tc_saturate = tc_saturate
    fl%tc_patch_eint = tc_patch_eint
    fl%tc_k_para = tc_k_para
    fl%tc_k_perp = tc_k_perp
    fl%trac_T_floor = trac_t_floor / unit_temperature
    select case(tc_slope_limiter)
     case ('no','none')
       fl%tc_slope_limiter = 0
     case ('MC')
       ! monotonized central limiter Woodward and Collela limiter (eq.3.51h)
       fl%tc_slope_limiter = 1
     case('minmod')
       ! minmod limiter
       fl%tc_slope_limiter = 2
     case ('superbee')
       ! Roes superbee limiter (eq.3.51i)
       fl%tc_slope_limiter = 3
     case ('koren')
       ! Barry Koren Right variant
       fl%tc_slope_limiter = 4
     case ('vanleer')
       ! van Leer limiter
       fl%tc_slope_limiter = 5
     case default
       call mpistop("Unknown tc_slope_limiter, choose MC, minmod, superbee, koren, vanleer")
    end select
  end subroutine tc_params_read_mhd
!!end th cond
 
!!rad cool
  subroutine rc_params_read(fl)
    use mod_global_parameters, only: unitpar,par_files
    use mod_constants, only: bigdouble
    type(rc_fluid), intent(inout) :: fl
 
    !> Lower limit of temperature
    double precision :: tlow=bigdouble
    double precision :: rad_damp_height=0.5d0
    double precision :: rad_damp_scale=0.15d0
    integer :: n
    ! list parameters
    integer :: ncool = 4000
    !> Fixed temperature not lower than tlow
    logical :: tfix=.false.
    !> Add cooling source in a split way (.true.) or un-split way (.false.)
    logical :: rc_split=.false.
    logical :: rad_damp=.false.
    !> Name of cooling curve
    character(len=std_len)  :: coolcurve='JCcorona'
    logical :: rad_newton = .false.
    double precision :: rad_newton_trad = 0.006d0
    double precision :: rad_newton_rhosurf = 1.d4
    double precision :: rad_newton_pthick = 25.d0
    !> HEAD-side cooling parameters (missing from common content after merge)
    double precision :: cfrac=0.1d0
    double precision :: rad_cut_hgt=0.5d0
    double precision :: rad_cut_dey=0.15d0
    !> Variable-c_V Townsend extension (Y_mod): quadrature and sub-intervals
    character(len=8) :: rc_y_mod_quadrature='boole'
    integer :: rc_y_mod_n_sub=16
    !> Smooth SC<->thin blend (mirrors hd): thin cooling *= 0.5(1+tanh((T-T0)/dT))*0.5(1+tanh((y-y0)/dy))
 
    namelist /rc_list/ coolcurve, ncool, cfrac, tlow, tfix, rc_split, &
                       rad_cut_hgt, rad_cut_dey, &
                       rc_y_mod_quadrature, rc_y_mod_n_sub, &
                       rad_newton, rad_newton_trad, rad_newton_rhosurf, &
                       rad_newton_pthick, rad_damp, rad_damp_height, rad_damp_scale
 
    do n = 1, size(par_files)
      open(unitpar, file=trim(par_files(n)), status="old")
      read(unitpar, rc_list, end=111)
111     close(unitpar)
    end do
 
    fl%ncool=ncool
    fl%coolcurve=coolcurve
    fl%tlow=tlow
    fl%Tfix=tfix
    fl%rc_split=rc_split
    fl%cfrac=cfrac
    fl%rad_cut_hgt=rad_cut_hgt
    fl%rad_cut_dey=rad_cut_dey
    fl%Y_mod_quadrature=rc_y_mod_quadrature
    fl%Y_mod_N_sub=rc_y_mod_n_sub
    fl%rad_damp=rad_damp
    fl%rad_damp_height=rad_damp_height
    fl%rad_damp_scale=rad_damp_scale
    fl%rad_newton=rad_newton
    fl%rad_newton_trad=rad_newton_trad
    fl%rad_newton_rhosurf=rad_newton_rhosurf
    fl%rad_newton_pthick=rad_newton_pthick
  end subroutine rc_params_read
 
  !> sets the equilibrium variables
  subroutine set_equi_vars_grid_faces(igrid,x,ixI^L,ixO^L)
    use mod_global_parameters
    use mod_usr_methods
    integer, intent(in) :: igrid, ixi^l, ixo^l
    double precision, intent(in) :: x(ixi^s,1:ndim)
 
    double precision :: delx(ixi^s,1:ndim)
    double precision :: xc(ixi^s,1:ndim),xshift^d
    integer :: idims, ixc^l, hxo^l, ix, idims2
 
    if(slab_uniform)then
      ^d&delx(ixi^s,^d)=rnode(rpdx^d_,igrid)\
    else
      ! for all non-cartesian and stretched cartesian coordinates
      delx(ixi^s,1:ndim)=ps(igrid)%dx(ixi^s,1:ndim)
    endif
 
    do idims=1,ndim
      hxo^l=ixo^l-kr(idims,^d);
      if(stagger_grid) then
        ! ct needs all transverse cells
        ixcmax^d=ixomax^d+nghostcells-nghostcells*kr(idims,^d); ixcmin^d=hxomin^d-nghostcells+nghostcells*kr(idims,^d);
      else
        ! ixC is centered index in the idims direction from ixOmin-1/2 to ixOmax+1/2
        ixcmax^d=ixomax^d; ixcmin^d=hxomin^d;
      end if
      ! always xshift=0 or 1/2
      xshift^d=half*(one-kr(^d,idims));
      do idims2=1,ndim
        select case(idims2)
        {case(^d)
          do ix = ixc^lim^d
            ! xshift=half: this is the cell center coordinate
            ! xshift=0: this is the cell edge i+1/2 coordinate
            xc(ix^d%ixC^s,^d)=x(ix^d%ixC^s,^d)+(half-xshift^d)*delx(ix^d%ixC^s,^d)
          end do\}
        end select
      end do
      call usr_set_equi_vars(ixi^l,ixc^l,xc,ps(igrid)%equi_vars(ixi^s,1:number_equi_vars,idims))
    end do
  end subroutine set_equi_vars_grid_faces
 
  !> sets the equilibrium variables
  subroutine set_equi_vars_grid(igrid)
    use mod_global_parameters
    use mod_usr_methods
  
    integer, intent(in) :: igrid
 
    !values at the center
    call usr_set_equi_vars(ixg^ll,ixg^ll,ps(igrid)%x,ps(igrid)%equi_vars(ixg^t,1:number_equi_vars,0))
 
    !values at the interfaces
    call set_equi_vars_grid_faces(igrid,ps(igrid)%x,ixg^ll,ixm^ll)
 
  end subroutine set_equi_vars_grid
 
  ! w, wnew conserved, add splitted variables back to wnew
  function convert_vars_splitting(ixI^L,ixO^L, w, x, nwc) result(wnew)
    use mod_global_parameters
    integer, intent(in)             :: ixi^l,ixo^l, nwc
    double precision, intent(in)    :: w(ixi^s, 1:nw)
    double precision, intent(in)    :: x(ixi^s,1:ndim)
    double precision   :: wnew(ixo^s, 1:nwc)
 
    if(has_equi_rho_and_p) then
      wnew(ixo^s,rho_)=w(ixo^s,rho_)+block%equi_vars(ixo^s,equi_rho0_,0)
    else
      wnew(ixo^s,rho_)=w(ixo^s,rho_)
    endif
    wnew(ixo^s,mom(:))=w(ixo^s,mom(:))
 
    if (b0field) then
      ! add background magnetic field B0 to B
      wnew(ixo^s,mag(1:ndir))=w(ixo^s,mag(1:ndir))+block%B0(ixo^s,1:ndir,0)
    else
      wnew(ixo^s,mag(1:ndir))=w(ixo^s,mag(1:ndir))
    end if
 
    if(mhd_energy) then
      wnew(ixo^s,e_)=w(ixo^s,e_)
      if(has_equi_rho_and_p) then
        wnew(ixo^s,e_)=wnew(ixo^s,e_)+block%equi_vars(ixo^s,equi_pe0_,0)*eos%inv_gamma_minus_1
      end if
      if(b0field .and. total_energy) then
        wnew(ixo^s,e_)=wnew(ixo^s,e_)+0.5d0*sum(block%B0(ixo^s,:,0)**2,dim=ndim+1) &
            + sum(w(ixo^s,mag(:))*block%B0(ixo^s,:,0),dim=ndim+1)
      end if
    end if
 
  end function convert_vars_splitting
 
  subroutine mhd_check_params
    use mod_global_parameters
    use mod_usr_methods
    use mod_geometry, only: coordinate, cartesian
    use mod_convert, only: add_convert_method
    use mod_particles, only: particles_init, particles_eta, particles_etah
    use mod_particles, only: npayload,nusrpayload, &
                ngridvars,num_particles,physics_type_particles
    use mod_fld
 
    double precision :: a,b,xfrac,yfrac
 
    if(mhd_uawsom) then
      if(coordinate /= cartesian .or. .not.slab_uniform) &
        call mpistop('mhd_uawsom currently requires a uniform Cartesian grid')
      if(.not.mhd_energy .or. .not.total_energy) &
        call mpistop('mhd_uawsom requires the standard total-energy MHD formulation')
      if(mhd_internal_e .or. mhd_hydrodynamic_e .or. mhd_semirelativistic .or. &
         has_equi_rho_and_p .or. mhd_radiation_fld) &
        call mpistop('mhd_uawsom: unsupported MHD option')
      if(trim(eos%eos_type) /= 'FI') &
        call mpistop("mhd_uawsom currently supports eos_type='FI' only")
      if(mhd_uawsom_height_dim < 1 .or. mhd_uawsom_height_dim > ndim) &
        call mpistop('mhd_uawsom_height_dim must be between 1 and ndim')
      if(mhd_uawsom_zeta0 <= one .or. mhd_uawsom_filling_factor <= zero .or. &
         mhd_uawsom_filling_factor >= one) &
        call mpistop('mhd_uawsom requires zeta0>1 and 0<filling_factor<1')
      if(mhd_uawsom_zeta_scale <= zero .or. &
         mhd_uawsom_thread_radius0 <= zero .or. &
         mhd_uawsom_alfven_corr_length0 <= zero .or. mhd_uawsom_bref <= zero) &
        call mpistop('mhd_uawsom: scales must be positive')
      if(mhd_uawsom_sigma < zero) &
        call mpistop('mhd_uawsom_sigma must be non-negative')
      select case(trim(mhd_uawsom_reflection_mode))
      case('one_dimensional_gradient','cartesian_gradient_vorticity')
        continue
      case default
        call mpistop('invalid mhd_uawsom_reflection_mode')
      end select
    end if
 
    ! Initialize particles module here, so all extra and user vars are sample
    if(mhd_particles) then
      call particles_init()
      if (particles_eta  < zero) particles_eta = mhd_eta
      if (particles_etah < zero) particles_eta = mhd_etah
    end if
 
    ! gamma, gamma_minus_1, inv_gamma_minus_1 are set by eos_init
    if (.not. mhd_energy) then
       if (eos%gamma <= 0.0d0) call mpistop ("Error: gamma <= 0")
       if (mhd_adiab < 0.0d0) call mpistop ("Error: mhd_adiab < 0")
       small_pressure = mhd_adiab*small_density**eos%gamma
    else
       if (eos%gamma <= 0.0d0 .or. eos%gamma == 1.0d0) &
            call mpistop ("Error: gamma <= 0 or gamma == 1")
       small_e = small_pressure * eos%inv_gamma_minus_1
       small_r_e = small_pressure * eos%inv_gamma_minus_1
    end if
 
    if (number_equi_vars > 0 .and. .not. associated(usr_set_equi_vars)) then
      call mpistop("usr_set_equi_vars has to be implemented in the user file")
    endif
 
    if(has_equi_rho_and_p) then
      ! The Roe and HLLC solvers read the rho slot as a physical density, which
      ! under splitting holds only the perturbation. Neither has a split variant,
      ! so refuse the combination rather than return a quietly wrong wave speed.
      if(any(flux_method(:)==fs_tvdmu) .or. any(flux_method(:)==fs_hllc) &
         .or. any(flux_method(:)==fs_hllcd)) then
        call mpistop("Must have has_equi_rho_and_p=F with the roe/hllc/hllcd flux schemes")
      end if
      ! mhd_get_tcutoff forms Te from the perturbation pressure and density.
      if(mhd_trac) then
        call mpistop("Must have has_equi_rho_and_p=F when mhd_trac=T")
      end if
    end if
    if(convert .or. autoconvert) then
      if(convert_type .eq. 'dat_generic_mpi') then
        if(mhd_dump_full_vars) then
          if(mype .eq. 0) print*, " add conversion method: split -> full "
          call add_convert_method(convert_vars_splitting, nw, cons_wnames, "new")
        endif
      endif
    endif
 
    if(mhd_radiation_fld) then 
        if(.not.use_imex_scheme)then
           call mpistop('select IMEX scheme for FLD radiation use')
        endif
        if(use_multigrid)then
           call phys_set_mg_bounds()
        else
           if(.not.fld_no_mg)call mpistop('multigrid must have BCs for IMEX and FLD radiation use')
        endif
        if(mype==0)then
           write(*,*)'==FLD SETUP======================'
           write(*,*)'Using FLD with settings:'
           write(*,*)'Using FLD with settings: mhd_radiation_fld=',mhd_radiation_fld
           write(*,*)'Using FLD with settings: mhd_fld_pradtensor=',mhd_fld_pradtensor
           write(*,*)'Using FLD with settings: fld_fluxlimiter=',fld_fluxlimiter
           write(*,*)'Using FLD with settings: fld_bound_diff=',fld_bound_diff
           write(*,*)'Using FLD with settings: fld_interaction_method=',fld_interaction_method
           write(*,*)'Using FLD with settings: fld_opacity_law=',fld_opacity_law
           write(*,*)'Using FLD with settings: fld_kappa0=',fld_kappa0
           write(*,*)'Using FLD with settings: fld_opal_table=',fld_opal_table
           write(*,*)'Using FLD with settings: fld_Radforce_split=',fld_radforce_split
           write(*,*)'Using FLD with settings: fld_bisect_tol=',fld_bisect_tol
           write(*,*)'Using FLD with settings: fld_diff_tol=',fld_diff_tol
           write(*,*)'Using FLD with settings: nth_for_diff_mg=',nth_for_diff_mg
           write(*,*)'      FLD has use_imex_scheme and use_multigrid=',use_imex_scheme,use_multigrid
           write(*,*)'      FLD has fld_no_mg=',fld_no_mg
           if(fld_no_mg)then
              print *,'WARNING: cheating with FLD diffusion ***********************'
              print *,'WARNING: No MG-diffusion for radiative energy at all!!!!!!!'
              print *,'WARNING: cheating with FLD diffusion ***********************'
           endif
           print *,'const_rad_a   =',const_rad_a
           print *,'NORMALIZED arad_norm=',arad_norm
           print *,'NORMALIZED c_norm=',c_norm
           if(fld_cnorm>0.0d0)then
              print *,'WARNING: cheating with c_norm ***********************'
              print *,'WARNING: c_norm reset to=',fld_cnorm
              c_norm=fld_cnorm
              print *,'WARNING: cheating with c_norm ***********************'
           endif
           print *,'const_kappae  =',const_kappae 
           if(trim(fld_opacity_law).eq.'const_norm')then
               print *,'NORMALIZED fld_kappa0          =',fld_kappa0
               print *,'physical value (in cgs or SI)  =',fld_kappa0*unit_opacity
           endif
           if(trim(fld_opacity_law).eq.'const')then
               print *,'physical fld_kappa (in cgs or SI) =',fld_kappa0
               print *,'NORMALIZED value                  =',fld_kappa0/unit_opacity
           endif
           write(*,*)'===FLD SETUP====================='
        endif
    endif
 
    if(mype==0)then
           write(*,*)'====MHD run with settings===================='
           write(*,*)'Using mod_mhd_phys with settings:'
           write(*,*)'SI_unit=',si_unit
           write(*,*)'Dimensionality   :',ndim
           write(*,*)'vector components:',ndir
           write(*,*)'coordinate set to type,slab:',coordinate,slab
           write(*,*)'number of variables          nw=',nw
           write(*,*)'    start index         iwstart=',iwstart
           write(*,*)'number of      vector variables=',nvector
           write(*,*)'number of stagger variables nws=',nws
           write(*,*)'number of    variables with BCs=',nwgc
           write(*,*)'number of      vars with fluxes=',nwflux
           write(*,*)'number of   vars with flux + BC=',nwfluxbc
           write(*,*)'number of   auxiliary variables=',nwaux
           write(*,*)'number of extra vars without flux=',nwextra
           write(*,*)'number of extra vars   for wextra=',nw_extra
           write(*,*)'number of auxiliary I/O variables=',nwauxio
           write(*,*)'number of            mhd_n_tracer=',mhd_n_tracer
           write(*,*)'    mhd_energy=',mhd_energy,' with total_energy=',total_energy
           write(*,*)'    mhd_semirelativistic=',mhd_semirelativistic
           write(*,*)'    mhd_internal_e=',mhd_internal_e
           write(*,*)'    mhd_hydrodynamic_e=',mhd_hydrodynamic_e
           write(*,*)'    mhd_gravity=',mhd_gravity
           write(*,*)'    mhd_eta=',mhd_eta,' nonzero implies resistivity'
           write(*,*)'    mhd_viscosity=',mhd_viscosity
           write(*,*)'    mhd_radiative_cooling=',mhd_radiative_cooling
           write(*,*)'    mhd_cak_force=',mhd_cak_force
           write(*,*)'    mhd_radiation_fld=',mhd_radiation_fld
           write(*,*)'    mhd_thermal_conduction=',mhd_thermal_conduction
           write(*,*)'    mhd_hyperbolic_tc=',mhd_hyperbolic_tc
           write(*,*)'    mhd_trac=',mhd_trac
           write(*,*)'    mhd_hall=',mhd_hall
           write(*,*)'    mhd_ambipolar=',mhd_ambipolar
           write(*,*)'    mhd_eta_hyper=',mhd_eta_hyper
           write(*,*)'    mhd_rotating_frame=',mhd_rotating_frame
           write(*,*)'    mhd_particles=',mhd_particles
           if(mhd_particles) then
              write(*,*) '*****Using particles:        with mhd_eta, mhd_etah :', mhd_eta, mhd_etah
              write(*,*) '*****Using particles: particles_eta, particles_etah :', particles_eta, particles_etah
              write(*,*) '*****Using particles: npayload,ngridvars :', npayload,ngridvars
              write(*,*) '*****Using particles:        nusrpayload :', nusrpayload
              write(*,*) '*****Using particles:      num_particles :', num_particles
              write(*,*) '*****Using particles: physics_type_particles=',physics_type_particles
           end if
           write(*,*)'number of             ghostcells=',nghostcells
           write(*,*)'number due to phys_wider_stencil=',phys_wider_stencil
           write(*,*)'==========================================='
           print *,'========EOS and UNITS==========='
           print *,'SI_unit       =',si_unit
           print *,'gamma=',eos%gamma
           print *,'He_abundance  =',eos%He_abundance
           print *,'RR            =',rr
           print *,'========EOS and UNITS==========='
           print *,'unit_time          =',unit_time
           print *,'unit_length        =',unit_length
           print *,'unit_velocity      =',unit_velocity
           print *,'unit_pressure      =',unit_pressure
           print *,'unit_numberdensity =',unit_numberdensity
           print *,'unit_density       =',unit_density
           print *,'unit_temperature   =',unit_temperature
           print *,'unit_mass          =',unit_mass
           print *,'unit_Erad          =',unit_erad
           print *,'unit_radflux       =',unit_radflux
           print *,'unit_magneticfield =',unit_magneticfield
           if(si_unit)then
              print *,'CHECK that p_u',unit_pressure,' equals ',unit_magneticfield**2/miu0_si
           else
              print *,'CHECK that p_u',unit_pressure,' equals ',unit_magneticfield**2/(4.0d0*dpi)
           endif
           print *, 'CHECK that p_u ',unit_pressure,' equals ',unit_density*unit_velocity**2
           print *, 'CHECK that L_u ',unit_length,' equals ',unit_velocity*unit_time
           print *, 'CHECK that M_u',unit_mass,' equals ',unit_density*unit_length**3
           print *, 'density to numberdensity has factor   ',unit_density/unit_numberdensity
           if(si_unit)then
                print *, '                     compare  this to ',mp_si*(1.d0+4.d0*eos%He_abundance)
           else
                print *, '                     compare  this to ',mp_cgs*(1.d0+4.d0*eos%He_abundance)
           endif
           print *, 'pressure to n T has factor            ',unit_pressure/(unit_numberdensity*unit_temperature)
           if(si_unit)then
                print *, '                     compare  this to ',kb_si*(2.d0+3.d0*eos%He_abundance)
                a=unit_density/unit_numberdensity/mp_si
                b=unit_pressure/(unit_numberdensity*unit_temperature*kb_si)
           else
                print *, '                     compare  this to ',kb_cgs*(2.d0+3.d0*eos%He_abundance)
                a=unit_density/unit_numberdensity/mp_cgs
                b=unit_pressure/(unit_numberdensity*unit_temperature*kb_cgs)
           endif
           if(eos%eos_type /= 'LTE')then
              print *, 'mean molecular weight mu is =',a/b,' = ', (1.d0+4.d0*eos%He_abundance)/(2.d0+3.d0*eos%He_abundance)
              xfrac=1.d0/a
              yfrac=4.d0*eos%He_abundance/(1.d0+4.d0*eos%He_abundance)
              print *, 'mass fraction hydrogen X is =',1/a,' and this equals ', 1.d0/(1.d0+4.d0*eos%He_abundance)
              print *, 'mass fraction helium   Y is =',yfrac
              print *, ' check that 1/mu', b/a,' is equal to 2X+3Y/4=',2.d0*xfrac+3.d0*yfrac/4.d0
              print *, ' ratio n_e/n_p=',1.d0+2.0d0*eos%He_abundance
           endif
           print *,'========UNITS==========='
    endif
 
  end subroutine mhd_check_params
 
  subroutine mhd_physical_units()
    use mod_global_parameters
    double precision :: mp,kb,miu0,c_lightspeed,xfrac,sigma_telectron
    double precision :: a,b
    ! Derive scaling units
    if(si_unit) then
      mp=mp_si
      kb=kb_si
      miu0=miu0_si
      const_sigmasb=sigma_sb_si
      c_lightspeed=c_si
      sigma_telectron=sigma_te_si
    else
      mp=mp_cgs
      kb=kb_cgs
      miu0=4.d0*dpi ! G^2 cm^2 dyne^-1
      const_sigmasb=sigma_sb_cgs
      c_lightspeed=const_c
      sigma_telectron=sigma_te_cgs
    end if
    ! Normalisation dispatch keyed solely on eos%eos_type (FI is the default, so
    ! legacy parfiles land in the FI/PI absorbed-(a,b), RR=1 branch -- the former
    ! eq_state_units=.true. result).
    if (eos%eos_type == 'LTE') then
      !> Remove the assumed FI normalisation from the units and handle in EoS
      a=1d0
      b=1d0
      eos%nH2rhoFactor = 1d0+4d0*eos%He_abundance
      rr=(2d0+3d0*eos%He_abundance) / (1d0+4d0*eos%He_abundance)
      xfrac=1.d0/(1.d0+4.d0*eos%He_abundance)
    else
      !> FI / PI: absorbed-(a,b), RR=1 (a=b=1 with RR=1 would be wrong physics
      !> for He>0). PI shares FI's normalisation exactly; the partial b lives here.
      a=1d0+4d0*eos%He_abundance
      if(eos%eos_type=='PI') then
        b=1d0+h_ion_fr+eos%He_abundance*(he_ion_fr*(he_ion_fr2+1d0)+1d0)
      else
        b=2d0+3d0*eos%He_abundance
      end if
      rr=1d0
      xfrac=1.d0/a
    end if
    if(unit_density/=1.d0 .or. unit_numberdensity/=1.d0) then
      if(unit_density/=1.d0) then
        unit_numberdensity=unit_density/(a*mp)
      else if(unit_numberdensity/=1.d0) then
        unit_density=a*mp*unit_numberdensity
      end if
      if(unit_temperature/=1.d0) then
        unit_pressure=b*unit_numberdensity*kb*unit_temperature
        unit_velocity=sqrt(unit_pressure/unit_density)
        unit_magneticfield=sqrt(miu0*unit_pressure)
        if(unit_length/=1.d0) then
          unit_time=unit_length/unit_velocity
        else if(unit_time/=1.d0) then
          unit_length=unit_velocity*unit_time
        end if
      else if(unit_magneticfield/=1.d0) then
        unit_pressure=unit_magneticfield**2/miu0
        unit_temperature=unit_pressure/(b*unit_numberdensity*kb)
        unit_velocity=sqrt(unit_pressure/unit_density)
        if(unit_length/=1.d0) then
          unit_time=unit_length/unit_velocity
        else if(unit_time/=1.d0) then
          unit_length=unit_velocity*unit_time
        end if
      else if(unit_pressure/=1.d0) then
        unit_temperature=unit_pressure/(b*unit_numberdensity*kb)
        unit_velocity=sqrt(unit_pressure/unit_density)
        unit_magneticfield=sqrt(miu0*unit_pressure)
        if(unit_length/=1.d0) then
          unit_time=unit_length/unit_velocity
        else if(unit_time/=1.d0) then
          unit_length=unit_velocity*unit_time
        end if
      else if(unit_velocity/=1.d0) then
        unit_pressure=unit_density*unit_velocity**2
        unit_temperature=unit_pressure/(b*unit_numberdensity*kb)
        unit_magneticfield=sqrt(miu0*unit_pressure)
        if(unit_length/=1.d0) then
          unit_time=unit_length/unit_velocity
        else if(unit_time/=1.d0) then
          unit_length=unit_velocity*unit_time
        end if
      else if(unit_time/=1.d0) then
        unit_velocity=unit_length/unit_time
        unit_pressure=unit_density*unit_velocity**2
        unit_magneticfield=sqrt(miu0*unit_pressure)
        unit_temperature=unit_pressure/(b*unit_numberdensity*kb)
      end if
    else if(unit_temperature/=1.d0) then
      ! units of temperature and velocity are dependent
      if(unit_magneticfield/=1.d0) then
        unit_pressure=unit_magneticfield**2/miu0
        unit_numberdensity=unit_pressure/(b*unit_temperature*kb)
        unit_density=a*mp*unit_numberdensity
        unit_velocity=sqrt(unit_pressure/unit_density)
        if(unit_length/=1.d0) then
          unit_time=unit_length/unit_velocity
        else if(unit_time/=1.d0) then
          unit_length=unit_velocity*unit_time
        end if
      else if(unit_pressure/=1.d0) then
        unit_magneticfield=sqrt(miu0*unit_pressure)
        unit_numberdensity=unit_pressure/(b*unit_temperature*kb)
        unit_density=a*mp*unit_numberdensity
        unit_velocity=sqrt(unit_pressure/unit_density)
        if(unit_length/=1.d0) then
          unit_time=unit_length/unit_velocity
        else if(unit_time/=1.d0) then
          unit_length=unit_velocity*unit_time
        end if
      end if
    else if(unit_magneticfield/=1.d0) then
      ! units of magnetic field and pressure are dependent
      if(unit_velocity/=1.d0) then
        unit_pressure=unit_magneticfield**2/miu0
        unit_numberdensity=unit_pressure/(b*unit_temperature*kb)
        unit_density=a*mp*unit_numberdensity
        unit_temperature=unit_pressure/(b*unit_numberdensity*kb)
        if(unit_length/=1.d0) then
          unit_time=unit_length/unit_velocity
        else if(unit_time/=1.d0) then
          unit_length=unit_velocity*unit_time
        end if
      else if(unit_time/=0.d0) then
        unit_pressure=unit_magneticfield**2/miu0
        unit_velocity=unit_length/unit_time
        unit_density=unit_pressure/unit_velocity**2
        unit_numberdensity=unit_density/(a*mp)
        unit_temperature=unit_pressure/(b*unit_numberdensity*kb)
      end if
    else if(unit_pressure/=1.d0) then
      if(unit_velocity/=1.d0) then
        unit_magneticfield=sqrt(miu0*unit_pressure)
        unit_density=unit_pressure/unit_velocity**2
        unit_numberdensity=unit_density/(a*mp)
        unit_temperature=unit_pressure/(b*unit_numberdensity*kb)
        if(unit_length/=1.d0) then
          unit_time=unit_length/unit_velocity
        else if(unit_time/=1.d0) then
          unit_length=unit_velocity*unit_time
        end if
      else if(unit_time/=0.d0) then
        unit_magneticfield=sqrt(miu0*unit_pressure)
        unit_velocity=unit_length/unit_time
        unit_density=unit_pressure/unit_velocity**2
        unit_numberdensity=unit_density/(a*mp)
        unit_temperature=unit_pressure/(b*unit_numberdensity*kb)
      end if
    end if
    ! Additional units needed for the particles
    c_norm=c_lightspeed/unit_velocity
    unit_charge=unit_magneticfield*unit_length**2/unit_velocity/miu0
    if (.not. si_unit) unit_charge = unit_charge*const_c
    unit_mass=unit_density*unit_length**3
 
    if(mhd_semirelativistic) then
      if(mhd_reduced_c<1.d0) then
        ! dimensionless speed
        inv_squared_c0=1.d0
        inv_squared_c=1.d0/mhd_reduced_c**2
      else
        inv_squared_c0=(unit_velocity/c_lightspeed)**2
        inv_squared_c=(unit_velocity/mhd_reduced_c)**2
      end if
      ! Propagate to the EoS container. Must happen AFTER inv_squared_c{0,}
      ! are set above; the assignment earlier in mhd_phys_init runs before
      ! mhd_physical_units and would store uninitialised values.
      eos%inv_squared_c0 = inv_squared_c0
      eos%inv_squared_c  = inv_squared_c
    end if
 
    !> Units for radiative flux and opacity as used in FLD
    ! this is the radiation constant in either cgs or SI units
    const_rad_a=4.d0*const_sigmasb/c_lightspeed
    ! this is the dimensionless conversion factor for Erad to Trad
    arad_norm=const_rad_a*unit_temperature**4/unit_pressure
    ! This is the Thomson scattering opacity in the correct units
    ! note that the hydrogen mass fraction X=1/a in eq_state_units
    const_kappae=sigma_telectron*(1.d0+xfrac)/(2.0d0*mp)
    ! these are the units
    unit_erad = unit_pressure
    unit_radflux = unit_velocity*unit_erad
    unit_opacity = one/(unit_density*unit_length)
 
  end subroutine mhd_physical_units
 
  subroutine mhd_check_w_semirelati(primitive,ixI^L,ixO^L,w,flag)
    use mod_global_parameters
 
    logical, intent(in) :: primitive
    logical, intent(inout) :: flag(ixi^s,1:nw)
    integer, intent(in) :: ixi^l, ixo^l
    double precision, intent(in) :: w(ixi^s,nw)
 
    double precision :: tmp,b(1:ndir),v(1:ndir),factor
    integer :: ix^d
 
    flag=.false.
    where(w(ixo^s,rho_) < small_density) flag(ixo^s,rho_) = .true.
 
    if(mhd_energy) then
      if(primitive) then
        where(w(ixo^s,p_) < small_pressure) flag(ixo^s,e_) = .true.
      else
        if(mhd_internal_e) then
         {do ix^db=ixomin^db,ixomax^db \}
            if(w(ix^d,e_) < small_e) flag(ix^d,e_) = .true.
         {end do\}
        else
         {do ix^db=ixomin^db,ixomax^db \}
            ! Convert momentum to velocity
            tmp=(^c&w(ix^d,b^c_)*w(ix^d,m^c_)+)*inv_squared_c
            factor=1.0d0/(w(ix^d,rho_)*(w(ix^d,rho_)+(^c&w(ix^d,b^c_)**2+)*inv_squared_c))
            ^c&v(^c)=factor*(w(ix^d,m^c_)*w(ix^d,rho_)+w(ix^d,b^c_)*tmp)\
            ! E=Bxv
            {^ifthreec
            b(1)=w(ix^d,b2_)*v(3)-w(ix^d,b3_)*v(2)
            b(2)=w(ix^d,b3_)*v(1)-w(ix^d,b1_)*v(3)
            b(3)=w(ix^d,b1_)*v(2)-w(ix^d,b2_)*v(1)
            }
            {^iftwoc
            b(1)=zero
            ! switch 3 with 2 to allow ^C from 1 to 2
            b(2)=w(ix^d,b1_)*v(2)-w(ix^d,b2_)*v(1)
            }
            {^ifonec
            b(1)=zero
            }
            ! Calculate internal e = e-eK-eB-eE
            tmp=w(ix^d,e_)-half*((^c&v(^c)**2+)*w(ix^d,rho_)&
               +(^c&w(ix^d,b^c_)**2+)+(^c&b(^c)**2+)*inv_squared_c)
            if(tmp<small_e) flag(ix^d,e_)=.true.
         {end do\}
        end if
      end if
    end if
 
  end subroutine mhd_check_w_semirelati
 
  subroutine mhd_check_w_origin(primitive,ixI^L,ixO^L,w,flag)
    use mod_global_parameters
 
    logical, intent(in) :: primitive
    integer, intent(in) :: ixi^l, ixo^l
    double precision, intent(in) :: w(ixi^s,nw)
    logical, intent(inout) :: flag(ixi^s,1:nw)
 
    integer :: ix^d, igrp
 
    flag=.false.
   {do ix^db=ixomin^db,ixomax^db\}
      if(w(ix^d,rho_)<small_density) flag(ix^d,rho_) = .true.
      if(primitive) then
        if(w(ix^d,p_)<small_pressure) flag(ix^d,e_) = .true.
      else
        if(w(ix^d,e_)-half*((^c&w(ix^d,m^c_)**2+)/w(ix^d,rho_)+&
          (^c&w(ix^d,b^c_)**2+))-mhd_uawsom_wave_energy_cell(w(ix^d,:))&
          <small_e) flag(ix^d,e_) = .true.
        if(mhd_uawsom) then
          if(w(ix^d,waplus_)<zero) flag(ix^d,waplus_)=.true.
          if(w(ix^d,waminus_)<zero) flag(ix^d,waminus_)=.true.
          if(w(ix^d,wkplus_)<zero) flag(ix^d,wkplus_)=.true.
          if(w(ix^d,wkminus_)<zero) flag(ix^d,wkminus_)=.true.
        end if
      end if
      if(mhd_radiation_fld)then
         if(w(ix^d,r_e)<small_r_e) flag(ix^d,r_e) = .true.
      endif
   {end do\}
 
  end subroutine mhd_check_w_origin
 
  subroutine mhd_check_w_split(primitive,ixI^L,ixO^L,w,flag)
    use mod_global_parameters
 
    logical, intent(in) :: primitive
    integer, intent(in) :: ixi^l, ixo^l
    double precision, intent(in) :: w(ixi^s,nw)
    logical, intent(inout) :: flag(ixi^s,1:nw)
 
    double precision :: tmp
    integer :: ix^d
 
    flag=.false.
   {do ix^db=ixomin^db,ixomax^db\}
      tmp=w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,0)
      if(tmp<small_density) flag(ix^d,rho_) = .true.
      if(primitive) then
        if(w(ix^d,p_)+block%equi_vars(ix^d,equi_pe0_,0)<small_pressure) flag(ix^d,e_) = .true.
      else
        tmp=w(ix^d,e_)-half*((^c&w(ix^d,m^c_)**2+)/tmp+(^c&w(ix^d,b^c_)**2+))
        if(tmp+block%equi_vars(ix^d,equi_pe0_,0)*eos%inv_gamma_minus_1<small_e) flag(ix^d,e_) = .true.
      end if
   {end do\}
 
  end subroutine mhd_check_w_split
 
  subroutine mhd_check_w_noe(primitive,ixI^L,ixO^L,w,flag)
    use mod_global_parameters
 
    logical, intent(in) :: primitive
    integer, intent(in) :: ixi^l, ixo^l
    double precision, intent(in) :: w(ixi^s,nw)
    logical, intent(inout) :: flag(ixi^s,1:nw)
 
    integer :: ix^d
 
    flag=.false.
   {do ix^db=ixomin^db,ixomax^db\}
      if(w(ix^d,rho_)<small_density) flag(ix^d,rho_) = .true.
   {end do\}
 
  end subroutine mhd_check_w_noe
 
  subroutine mhd_check_w_inte(primitive,ixI^L,ixO^L,w,flag)
    use mod_global_parameters
 
    logical, intent(in) :: primitive
    integer, intent(in) :: ixi^l, ixo^l
    double precision, intent(in) :: w(ixi^s,nw)
    logical, intent(inout) :: flag(ixi^s,1:nw)
 
    integer :: ix^d
 
    flag=.false.
   {do ix^db=ixomin^db,ixomax^db\}
      if(w(ix^d,rho_)<small_density) flag(ix^d,rho_) = .true.
      if(primitive) then
        if(w(ix^d,p_) < small_pressure) flag(ix^d,e_) = .true.
      else
        if(w(ix^d,e_)<small_e) flag(ix^d,e_) = .true.
      end if
   {end do\}
 
  end subroutine mhd_check_w_inte
 
  subroutine mhd_check_w_hde(primitive,ixI^L,ixO^L,w,flag)
    use mod_global_parameters
 
    logical, intent(in) :: primitive
    integer, intent(in) :: ixi^l, ixo^l
    double precision, intent(in) :: w(ixi^s,nw)
    logical, intent(inout) :: flag(ixi^s,1:nw)
 
    integer :: ix^d
 
    flag=.false.
   {do ix^db=ixomin^db,ixomax^db\}
      if(w(ix^d,rho_)<small_density) flag(ix^d,rho_) = .true.
      if(primitive) then
        if(w(ix^d,p_)<small_pressure) flag(ix^d,e_) = .true.
      else
        if(w(ix^d,e_)-half*(^c&w(ix^d,m^c_)**2+)/w(ix^d,rho_)<small_e) flag(ix^d,e_) = .true.
      end if
   {end do\}
 
  end subroutine mhd_check_w_hde
 
  subroutine mhd_bound_fip(primitive, ixI^L, ixO^L, w)
    use mod_global_parameters
    logical, intent(in)             :: primitive
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(inout) :: w(ixi^s,1:nw)
 
    double precision :: rho_safe(ixi^s), fip_prim(ixi^s)
 
    if (.not. mhd_fip) return
 
    if (primitive) then
      w(ixo^s,fip_) = min(maxfip, max(minfip, w(ixo^s,fip_)))
    else
      if (has_equi_rho_and_p) then
        rho_safe(ixo^s) = max(w(ixo^s,rho_) + block%equi_vars(ixo^s,equi_rho0_,b0i), small_density)
      else
        rho_safe(ixo^s) = max(w(ixo^s,rho_), small_density)
      end if
      fip_prim(ixo^s) = w(ixo^s,fip_) / rho_safe(ixo^s)
      fip_prim(ixo^s) = min(maxfip, max(minfip, fip_prim(ixo^s)))
      w(ixo^s,fip_) = rho_safe(ixo^s) * fip_prim(ixo^s)
    end if
  end subroutine mhd_bound_fip
 
  !> Return local UAWSoM closure coefficients in code units.  User cases may
  !> replace all three profiles through usr_uawsom_coefficients.
  subroutine mhd_uawsom_get_coefficients(w,x,ixI^L,ixO^L,primitive,zeta,radius,lperp_A)
    use mod_global_parameters
    use mod_usr_methods, only: usr_uawsom_coefficients
    integer, intent(in) :: ixi^l, ixo^l
    double precision, intent(in) :: w(ixi^s,1:nw), x(ixi^s,1:ndim)
    logical, intent(in) :: primitive
    double precision, intent(out) :: zeta(ixi^s), radius(ixi^s), lperp_a(ixi^s)
    double precision :: bmag(ixi^s), btotal(ixi^s,1:ndir), height_base
    integer :: idir
 
    if(associated(usr_uawsom_coefficients)) then
      call usr_uawsom_coefficients(w,x,ixi^l,ixo^l,primitive,zeta,radius,lperp_a)
    else
      do idir=1,ndir
        if(b0field) then
          btotal(ixo^s,idir)=w(ixo^s,mag(idir))+block%B0(ixo^s,idir,b0i)
        else
          btotal(ixo^s,idir)=w(ixo^s,mag(idir))
        end if
      end do
      bmag(ixo^s)=dsqrt(sum(btotal(ixo^s,1:ndir)**2,dim=ndim+1))
      select case(mhd_uawsom_height_dim)
      case(1)
        height_base=xprobmin1
      {^nooned
      case(2)
        height_base=xprobmin2
      }
      {^ifthreed
      case(3)
        height_base=xprobmin3
      }
      end select
      zeta(ixo^s)=one+(mhd_uawsom_zeta0-one)*dexp(&
           -max(x(ixo^s,mhd_uawsom_height_dim)-height_base,zero)/&
           mhd_uawsom_zeta_scale)
      radius(ixo^s)=mhd_uawsom_thread_radius0*dsqrt(&
           mhd_uawsom_bref/max(bmag(ixo^s),smalldouble))
      lperp_a(ixo^s)=mhd_uawsom_alfven_corr_length0*dsqrt(&
           mhd_uawsom_bref/max(bmag(ixo^s),smalldouble))
    end if
    if(any(zeta(ixo^s)<=one) .or. any(radius(ixo^s)<=zero) .or. &
       any(lperp_a(ixo^s)<=zero)) &
      call mpistop('mhd_uawsom coefficients require zeta>1 and positive lengths')
  end subroutine mhd_uawsom_get_coefficients
 
  subroutine mhd_uawsom_rho2_factor(ixI^L,ixO^L,w,x,factor)
    use mod_global_parameters
    integer, intent(in) :: ixi^l, ixo^l
    double precision, intent(in) :: w(ixi^s,1:nw), x(ixi^s,1:ndim)
    double precision, intent(out) :: factor(ixi^s)
    double precision :: zeta(ixi^s), radius(ixi^s), lperp_a(ixi^s)
    call mhd_uawsom_get_coefficients(w,x,ixi^l,ixo^l,.false.,zeta,radius,lperp_a)
    factor(ixo^s)=mhd_uawsom_rho2_factor_cell(zeta(ixo^s))
  end subroutine mhd_uawsom_rho2_factor
 
  elemental pure double precision function mhd_uawsom_rho2_factor_cell(zeta)
    double precision, intent(in) :: zeta
    double precision :: f
    f=mhd_uawsom_filling_factor
    mhd_uawsom_rho2_factor_cell=1.d0+f*(1.d0-f)*(zeta-1.d0)**2/&
         (1.d0+f*zeta-f)**2
  end function mhd_uawsom_rho2_factor_cell
 
  pure double precision function mhd_uawsom_wave_pressure_cell(wcell,zeta)
    double precision, intent(in) :: wcell(:),zeta
    mhd_uawsom_wave_pressure_cell=0.5d0*(wcell(waplus_)+wcell(waminus_))+&
         0.25d0*(zeta+1.d0)*(wcell(wkplus_)+wcell(wkminus_))
  end function mhd_uawsom_wave_pressure_cell
 
  pure double precision function mhd_uawsom_wave_energy_cell(wcell)
    use mod_constants, only: zero
    double precision, intent(in) :: wcell(:)
    if(mhd_uawsom) then
      mhd_uawsom_wave_energy_cell=wcell(waplus_)+wcell(waminus_)+&
           wcell(wkplus_)+wcell(wkminus_)
    else
      mhd_uawsom_wave_energy_cell=zero
    end if
  end function mhd_uawsom_wave_energy_cell
 
  !> Signed population imbalance used by the Cartesian gradient-vorticity reflection model.
  !> A positive value transfers W_A^+ (or W_k^+) to the minus population;
  !> a negative value transfers the minus population to the plus population.
  !> The factor is zero for a balanced state and remains bounded in [-1,1]
  !> for an arbitrarily imbalanced state.
  elemental pure double precision function mhd_uawsom_imbalance_factor(wplus,wminus)
    double precision, intent(in) :: wplus,wminus
 
    if(wplus<=0.d0 .or. wminus<=0.d0) then
      mhd_uawsom_imbalance_factor=0.d0
    else if(4.d0*wminus<=wplus) then
      mhd_uawsom_imbalance_factor=1.d0-2.d0*dsqrt(wminus/wplus)
    else if(4.d0*wplus<=wminus) then
      mhd_uawsom_imbalance_factor=-(1.d0-2.d0*dsqrt(wplus/wminus))
    else
      mhd_uawsom_imbalance_factor=0.d0
    end if
  end function mhd_uawsom_imbalance_factor
 
  !> UAWSoM compression, nonlinear damping, and optional Alfven reflection.
  !> Total energy is intentionally unchanged by damping: because it contains
  !> the four W variables, their loss is recovered as gas internal energy.
  subroutine mhd_add_source_uawsom(qdt,ixI^L,ixO^L,wCT,wCTprim,w,x)
    use mod_global_parameters
    use mod_geometry, only: divvector, gradient, curlvector
    integer, intent(in) :: ixi^l, ixo^l
    double precision, intent(in) :: qdt, wct(ixi^s,1:nw), &
         wctprim(ixi^s,1:nw), x(ixi^s,1:ndim)
    double precision, intent(inout) :: w(ixi^s,1:nw)
    double precision :: v(ixi^s,1:ndir), divv(ixi^s)
    double precision :: zeta(ixi^s), radius(ixi^s), lperp_a(ixi^s)
    double precision :: lperp_k(ixi^s), rho_e(ixi^s)
    double precision :: gamma_plus(ixi^s), gamma_minus(ixi^s)
    double precision :: gamma_kplus(ixi^s), gamma_kminus(ixi^s)
    double precision :: dampap(ixi^s), dampam(ixi^s), dampkp(ixi^s), dampkm(ixi^s)
    double precision :: btotal(ixi^s,1:ndir), bunit(ixi^s,1:ndir), bmag(ixi^s)
    double precision :: va(ixi^s), vk(ixi^s), lnva(ixi^s), lnvk(ixi^s)
    double precision :: grad_component(ixi^s), grad_a(ixi^s), grad_k(ixi^s)
    double precision :: curlv(ixi^s,1:3), vorticity(ixi^s)
    double precision :: rimb_a(ixi^s), rlim_a(ixi^s), rlim_k(ixi^s)
    double precision :: refl_rate(ixi^s), donor_reflection(ixi^s)
    double precision :: transfer_a(ixi^s), transfer_k(ixi^s), donor(ixi^s)
    double precision :: imbalance_a(ixi^s), imbalance_k(ixi^s)
    double precision :: wave_plus(ixi^s), wave_minus(ixi^s)
    double precision :: wave_kplus(ixi^s), wave_kminus(ixi^s)
    double precision :: f, kink_pressure(ixi^s)
    integer :: idir, idirmin
    logical :: have_reflection, have_alfven_reflection, have_kink_reflection
 
    call mhd_get_v(wct,x,ixi^l,ixi^l,v)
    call divvector(v,ixi^l,ixo^l,divv)
    ! Reflection gradients need one-cell ghost values, so obtain the closure
    ! profiles on ixI rather than only on the source update region.
    call mhd_uawsom_get_coefficients(wct,x,ixi^l,ixi^l,.false.,zeta,radius,lperp_a)
    f=mhd_uawsom_filling_factor
    rho_e(ixi^s)=max(wct(ixi^s,rho_),small_density)/&
         max(one+f*zeta(ixi^s)-f,smalldouble)
    lperp_k(ixi^s)=dsqrt(10.d0)*dsqrt(f*dpi)*radius(ixi^s)*&
         (zeta(ixi^s)+one-f)**1.5d0/&
         ((zeta(ixi^s)-one)*(one-f**2.5d0))
    gamma_plus(ixo^s)=two/lperp_a(ixo^s)*dsqrt(&
         max(wct(ixo^s,waminus_),zero)/max(wct(ixo^s,rho_),small_density))
    gamma_minus(ixo^s)=two/lperp_a(ixo^s)*dsqrt(&
         max(wct(ixo^s,waplus_),zero)/max(wct(ixo^s,rho_),small_density))
    dampap(ixo^s)=gamma_plus(ixo^s)*max(wct(ixo^s,waplus_),zero)
    dampam(ixo^s)=gamma_minus(ixo^s)*max(wct(ixo^s,waminus_),zero)
    dampkp(ixo^s)=max(wct(ixo^s,wkplus_),zero)**1.5d0/&
         (dsqrt(rho_e(ixo^s))*lperp_k(ixo^s))
    dampkm(ixo^s)=max(wct(ixo^s,wkminus_),zero)**1.5d0/&
         (dsqrt(rho_e(ixo^s))*lperp_k(ixo^s))
    gamma_kplus(ixo^s)=dsqrt(max(wct(ixo^s,wkplus_),zero)/&
         max(rho_e(ixo^s),small_density))/max(lperp_k(ixo^s),smalldouble)
    gamma_kminus(ixo^s)=dsqrt(max(wct(ixo^s,wkminus_),zero)/&
         max(rho_e(ixo^s),small_density))/max(lperp_k(ixo^s),smalldouble)
 
    w(ixo^s,waplus_)=w(ixo^s,waplus_)-qdt*(&
         half*divv(ixo^s)*wct(ixo^s,waplus_)+dampap(ixo^s))
    w(ixo^s,waminus_)=w(ixo^s,waminus_)-qdt*(&
         half*divv(ixo^s)*wct(ixo^s,waminus_)+dampam(ixo^s))
    w(ixo^s,wkplus_)=w(ixo^s,wkplus_)-qdt*(&
         half*divv(ixo^s)*wct(ixo^s,wkplus_)+dampkp(ixo^s))
    w(ixo^s,wkminus_)=w(ixo^s,wkminus_)-qdt*(&
         half*divv(ixo^s)*wct(ixo^s,wkminus_)+dampkm(ixo^s))
 
    kink_pressure(ixo^s)=quarter*(zeta(ixo^s)+one)*&
         (wct(ixo^s,wkplus_)+wct(ixo^s,wkminus_))
    w(ixo^s,e_)=w(ixo^s,e_)+qdt*(zeta(ixo^s)-one)/&
         (zeta(ixo^s)+one)*kink_pressure(ixo^s)*divv(ixo^s)
 
    have_alfven_reflection=.false.
    if(mhd_uawsom_reflection) then
      select case(trim(mhd_uawsom_reflection_mode))
      case('one_dimensional_gradient')
        have_alfven_reflection=(mhd_uawsom_sigma>zero)
      case('cartesian_gradient_vorticity')
        have_alfven_reflection=.true.
      end select
    end if
    have_kink_reflection=mhd_uawsom_kink_reflection
    have_reflection=have_alfven_reflection .or. have_kink_reflection
    if(have_reflection) then
      do idir=1,ndir
        if(b0field) then
          btotal(ixi^s,idir)=wct(ixi^s,mag(idir))+block%B0(ixi^s,idir,b0i)
        else
          btotal(ixi^s,idir)=wct(ixi^s,mag(idir))
        end if
      end do
      bmag(ixi^s)=dsqrt(sum(btotal(ixi^s,1:ndir)**2,dim=ndim+1))
      do idir=1,ndir
        bunit(ixi^s,idir)=btotal(ixi^s,idir)/max(bmag(ixi^s),smalldouble)
      end do
      va(ixi^s)=bmag(ixi^s)/dsqrt(max(wct(ixi^s,rho_),small_density))
      vk(ixi^s)=bmag(ixi^s)/dsqrt(max(rho_e(ixi^s)*&
           (zeta(ixi^s)+one)/two,smalldouble))
      lnva(ixi^s)=dlog(max(va(ixi^s),smalldouble))
      lnvk(ixi^s)=dlog(max(vk(ixi^s),smalldouble))
 
      ! Apply exchange after the ordinary source update.  The donor cap below
      ! uses that actual post-damping state; it does not silently repair a
      ! negative state produced by compression or damping.  The standard
      ! small-value handling remains responsible for such a state.
      if(have_alfven_reflection) then
        wave_plus(ixo^s)=max(wct(ixo^s,waplus_),zero)
        wave_minus(ixo^s)=max(wct(ixo^s,waminus_),zero)
 
        select case(trim(mhd_uawsom_reflection_mode))
        case('one_dimensional_gradient')
          ! Retain the original one-dimensional source and sign convention:
          ! a positive transfer removes W_A^+ and adds W_A^-.
          call gradient(va,ixi^l,ixo^l,mhd_uawsom_height_dim,grad_component)
          refl_rate(ixo^s)=mhd_uawsom_sigma*&
               (wctprim(ixo^s,mom(mhd_uawsom_height_dim))+va(ixo^s))/&
               max(va(ixo^s),smalldouble)*grad_component(ixo^s)
          donor_reflection(ixo^s)=merge(max(wct(ixo^s,waplus_),zero),&
               max(wct(ixo^s,waminus_),zero),refl_rate(ixo^s)>=zero)
          transfer_a(ixo^s)=refl_rate(ixo^s)*donor_reflection(ixo^s)
        case('cartesian_gradient_vorticity')
          grad_a(ixo^s)=zero
          do idir=1,ndim
            call gradient(lnva,ixi^l,ixo^l,idir,grad_component)
            grad_a(ixo^s)=grad_a(ixo^s)+va(ixo^s)*bunit(ixo^s,idir)*&
                 grad_component(ixo^s)
          end do
          call curlvector(v,ixi^l,ixo^l,curlv,idirmin,1,ndir)
          vorticity(ixo^s)=zero
          do idir=1,ndir
            vorticity(ixo^s)=vorticity(ixo^s)+bunit(ixo^s,idir)*&
                 curlv(ixo^s,idir)
          end do
          ! Sigma belongs to the one-dimensional gradient source only; it is
          ! absent from the Cartesian gradient-vorticity R_imb/R_lim closure.
          rimb_a(ixo^s)=dsqrt(grad_a(ixo^s)**2+vorticity(ixo^s)**2)
          rlim_a(ixo^s)=min(rimb_a(ixo^s),&
               max(gamma_plus(ixo^s),gamma_minus(ixo^s)))
          imbalance_a(ixo^s)=mhd_uawsom_imbalance_factor(&
               wave_plus(ixo^s),wave_minus(ixo^s))
          transfer_a(ixo^s)=rlim_a(ixo^s)*imbalance_a(ixo^s)*&
               dsqrt(wave_plus(ixo^s)*wave_minus(ixo^s))
        end select
 
        if(qdt>zero) then
          donor(ixo^s)=merge(max(w(ixo^s,waplus_),zero),&
               max(w(ixo^s,waminus_),zero),transfer_a(ixo^s)>=zero)
          transfer_a(ixo^s)=sign(min(abs(transfer_a(ixo^s)),&
               donor(ixo^s)/qdt),transfer_a(ixo^s))
        else
          transfer_a(ixo^s)=zero
        end if
        w(ixo^s,waplus_)=w(ixo^s,waplus_)-qdt*transfer_a(ixo^s)
        w(ixo^s,waminus_)=w(ixo^s,waminus_)+qdt*transfer_a(ixo^s)
      end if
 
      if(have_kink_reflection) then
        wave_kplus(ixo^s)=max(wct(ixo^s,wkplus_),zero)
        wave_kminus(ixo^s)=max(wct(ixo^s,wkminus_),zero)
        grad_k(ixo^s)=zero
        do idir=1,ndim
          call gradient(lnvk,ixi^l,ixo^l,idir,grad_component)
          grad_k(ixo^s)=grad_k(ixo^s)+vk(ixo^s)*bunit(ixo^s,idir)*&
               grad_component(ixo^s)
        end do
        ! Kink reflection deliberately uses only the kink-speed gradient;
        ! the field-aligned velocity-vorticity term belongs to Alfvén waves,
        ! and sigma is not part of this limiter.
        rlim_k(ixo^s)=min(abs(grad_k(ixo^s)),&
             max(gamma_kplus(ixo^s),gamma_kminus(ixo^s)))
        imbalance_k(ixo^s)=mhd_uawsom_imbalance_factor(&
             wave_kplus(ixo^s),wave_kminus(ixo^s))
        transfer_k(ixo^s)=rlim_k(ixo^s)*imbalance_k(ixo^s)*&
             dsqrt(wave_kplus(ixo^s)*wave_kminus(ixo^s))
        if(qdt>zero) then
          donor(ixo^s)=merge(max(w(ixo^s,wkplus_),zero),&
               max(w(ixo^s,wkminus_),zero),transfer_k(ixo^s)>=zero)
          transfer_k(ixo^s)=sign(min(abs(transfer_k(ixo^s)),&
               donor(ixo^s)/qdt),transfer_k(ixo^s))
        else
          transfer_k(ixo^s)=zero
        end if
        w(ixo^s,wkplus_)=w(ixo^s,wkplus_)-qdt*transfer_k(ixo^s)
        w(ixo^s,wkminus_)=w(ixo^s,wkminus_)+qdt*transfer_k(ixo^s)
      end if
    end if
  end subroutine mhd_add_source_uawsom
 
  !> Transform internal energy to total energy
  subroutine mhd_ei_to_e(ixI^L,ixO^L,w,x)
    use mod_global_parameters
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(inout) :: w(ixi^s, nw)
    double precision, intent(in)    :: x(ixi^s, 1:ndim)
 
    integer :: ix^d
 
    if(has_equi_rho_and_p) then
     {do ix^db=ixomin^db,ixomax^db\}
        ! Calculate e = ei + ek + eb
        w(ix^d,e_)=w(ix^d,e_)&
                  +half*((^c&w(ix^d,m^c_)**2+)/&
         (w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,0))&
                  +(^c&w(ix^d,b^c_)**2+))
     {end do\}
    else
     {do ix^db=ixomin^db,ixomax^db\}
        ! Calculate e = ei + ek + eb
        w(ix^d,e_)=w(ix^d,e_)&
                  +half*((^c&w(ix^d,m^c_)**2+)/w(ix^d,rho_)&
                        +(^c&w(ix^d,b^c_)**2+))&
                  +mhd_uawsom_wave_energy_cell(w(ix^d,:))
     {end do\}
    end if
  end subroutine mhd_ei_to_e
 
  !> Transform internal energy to hydrodynamic energy
  subroutine mhd_ei_to_e_hde(ixI^L,ixO^L,w,x)
    use mod_global_parameters
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(inout) :: w(ixi^s, nw)
    double precision, intent(in)    :: x(ixi^s, 1:ndim)
 
    integer :: ix^d
 
   {do ix^db=ixomin^db,ixomax^db\}
      ! Calculate e = ei + ek
      w(ix^d,e_)=w(ix^d,e_)&
                +half*(^c&w(ix^d,m^c_)**2+)/w(ix^d,rho_)
   {end do\}
 
  end subroutine mhd_ei_to_e_hde
 
  !> Transform internal energy to total energy and velocity to momentum
  subroutine mhd_ei_to_e_semirelati(ixI^L,ixO^L,w,x)
    use mod_global_parameters
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(inout) :: w(ixi^s, nw)
    double precision, intent(in)    :: x(ixi^s, 1:ndim)
 
    w(ixo^s,p_)=w(ixo^s,e_)*eos%gamma_minus_1
    ! call eos%to_conserved(ixI^L,ixO^L,w,x)
    call eos%to_conserved(ixi^l,ixo^l,w,x)
 
  end subroutine mhd_ei_to_e_semirelati
 
  !> Transform total energy to internal energy
  subroutine mhd_e_to_ei(ixI^L,ixO^L,w,x)
    use mod_global_parameters
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(inout) :: w(ixi^s, nw)
    double precision, intent(in)    :: x(ixi^s, 1:ndim)
 
    integer :: ix^d
 
    if(has_equi_rho_and_p) then
     {do ix^db=ixomin^db,ixomax^db\}
        ! Calculate ei = e - ek - eb
        w(ix^d,e_)=w(ix^d,e_)&
                  -half*((^c&w(ix^d,m^c_)**2+)/&
         (w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,0))&
                        +(^c&w(ix^d,b^c_)**2+))
     {end do\}
    else
     {do ix^db=ixomin^db,ixomax^db\}
        ! Calculate ei = e - ek - eb
        w(ix^d,e_)=w(ix^d,e_)&
                  -half*((^c&w(ix^d,m^c_)**2+)/w(ix^d,rho_)&
                        +(^c&w(ix^d,b^c_)**2+))&
                  -mhd_uawsom_wave_energy_cell(w(ix^d,:))
     {end do\}
    end if
 
    if(fix_small_values) then
      call mhd_handle_small_ei(w,x,ixi^l,ixi^l,e_,'mhd_e_to_ei')
    end if
 
  end subroutine mhd_e_to_ei
 
  !> Wrapper: e_to_ei + cache log10(nH) in wextra for LTE TC fast path.
  !> During STS substeps density is invariant, so log10(nH) is computed once
  !> per STS cycle (in sts_before_first_cycle hook) and reused across all substeps.
  subroutine mhd_e_to_ei_and_cache_log_nh(ixI^L,ixO^L,w,x)
    use mod_global_parameters
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(inout) :: w(ixi^s, nw)
    double precision, intent(in)    :: x(ixi^s, 1:ndim)
 
    call mhd_e_to_ei(ixi^l,ixo^l,w,x)
    block%wextra(ixo^s, iw_log_nh) = dlog10(w(ixo^s, rho_) / eos%nH2rhoFactor)
  end subroutine mhd_e_to_ei_and_cache_log_nh
 
  !> Transform hydrodynamic energy to internal energy
  subroutine mhd_e_to_ei_hde(ixI^L,ixO^L,w,x)
    use mod_global_parameters
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(inout) :: w(ixi^s, nw)
    double precision, intent(in)    :: x(ixi^s, 1:ndim)
 
    integer :: ix^d
 
   {do ix^db=ixomin^db,ixomax^db\}
      ! Calculate ei = e - ek
      w(ix^d,e_)=w(ix^d,e_)&
                -half*(^c&w(ix^d,m^c_)**2+)/w(ix^d,rho_)
   {end do\}
 
    if(fix_small_values) then
      call mhd_handle_small_ei(w,x,ixi^l,ixi^l,e_,'mhd_e_to_ei_hde')
    end if
 
  end subroutine mhd_e_to_ei_hde
 
  !> Transform total energy to internal energy and momentum to velocity
  subroutine mhd_e_to_ei_semirelati(ixI^L,ixO^L,w,x)
    use mod_global_parameters
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(inout) :: w(ixi^s, nw)
    double precision, intent(in)    :: x(ixi^s, 1:ndim)
 
    call eos%to_primitive(ixi^l,ixo^l,w,x)
    w(ixo^s,e_)=w(ixo^s,p_)*eos%inv_gamma_minus_1
 
  end subroutine mhd_e_to_ei_semirelati
 
  subroutine mhd_handle_small_values_semirelati(primitive, w, x, ixI^L, ixO^L, subname)
    use mod_global_parameters
    use mod_small_values
    logical, intent(in)             :: primitive
    integer, intent(in)             :: ixi^l,ixo^l
    double precision, intent(inout) :: w(ixi^s,1:nw)
    double precision, intent(in)    :: x(ixi^s,1:ndim)
    character(len=*), intent(in)    :: subname
 
    double precision :: e(ixi^s,1:ndir), pressure(ixi^s), v(ixi^s,1:ndir)
    double precision :: tmp, factor
    integer :: ix^d
    logical :: flag(ixi^s,1:nw)
 
    flag=.false.
    where(w(ixo^s,rho_) < small_density) flag(ixo^s,rho_) = .true.
 
    if(mhd_energy) then
      if(primitive) then
        where(w(ixo^s,p_) < small_pressure) flag(ixo^s,e_) = .true.
      else
       {do ix^db=ixomin^db,ixomax^db\}
          ! Convert momentum to velocity
          tmp=(^c&w(ix^d,b^c_)*w(ix^d,m^c_)+)*inv_squared_c
          factor=1.0d0/(w(ix^d,rho_)*(w(ix^d,rho_)+(^c&w(ix^d,b^c_)**2+)*inv_squared_c))
          ^c&v(ix^d,^c)=factor*(w(ix^d,m^c_)*w(ix^d,rho_)+w(ix^d,b^c_)*tmp)\
          ! E=Bxv
          {^ifthreec
          e(ix^d,1)=w(ix^d,b2_)*v(ix^d,3)-w(ix^d,b3_)*v(ix^d,2)
          e(ix^d,2)=w(ix^d,b3_)*v(ix^d,1)-w(ix^d,b1_)*v(ix^d,3)
          e(ix^d,3)=w(ix^d,b1_)*v(ix^d,2)-w(ix^d,b2_)*v(ix^d,1)
          }
          {^iftwoc
          e(ix^d,1)=zero
          e(ix^d,2)=w(ix^d,b1_)*v(ix^d,2)-w(ix^d,b2_)*v(ix^d,1)
          }
          {^ifonec
          e(ix^d,1)=zero
          }
          ! Calculate pressure = (gamma-1) * (e-eK-eB-eE)
          pressure(ix^d)=eos%gamma_minus_1*(w(ix^d,e_)&
                     -half*((^c&v(ix^d,^c)**2+)*w(ix^d,rho_)&
                     +(^c&w(ix^d,b^c_)**2+)+(^c&e(ix^d,^c)**2+)*inv_squared_c))
          if(pressure(ix^d) < small_pressure) flag(ix^d,p_) = .true.
       {end do\}
      end if
    end if
 
    if(any(flag)) then
      select case (small_values_method)
      case ("replace")
       {do ix^db=ixomin^db,ixomax^db\}
          if(flag(ix^d,rho_)) then
            w(ix^d,rho_) = small_density
         ^c&w(ix^d,m^c_)=0.d0\
          end if
          if(mhd_energy) then
            if(primitive) then
              if(flag(ix^d,e_)) w(ix^d,p_) = small_pressure
            else
              if(flag(ix^d,e_)) then
                w(ix^d,e_)=small_pressure*eos%inv_gamma_minus_1+half*((^c&v(ix^d,^c)**2+)*w(ix^d,rho_)&
                           +(^c&w(ix^d,b^c_)**2+)+(^c&e(ix^d,^c)**2+)*inv_squared_c)
              end if
            end if
          end if
       {end do\}
      case ("average")
        ! do averaging of density
        call small_values_average(ixi^l, ixo^l, w, x, flag, rho_)
        if(mhd_energy) then
          if(primitive) then
            call small_values_average(ixi^l, ixo^l, w, x, flag, p_)
          else
            w(ixo^s,e_)=pressure(ixo^s)
            call small_values_average(ixi^l, ixo^l, w, x, flag, p_)
            {do ix^db=ixomin^db,ixomax^db\}
               w(ix^d,e_)=w(ix^d,p_)*eos%inv_gamma_minus_1+half*((^c&v(ix^d,^c)**2+)*w(ix^d,rho_)&
                          +(^c&w(ix^d,b^c_)**2+)+(^c&e(ix^d,^c)**2+)*inv_squared_c)
            {end do\}
          end if
        end if
      case default
        if(.not.primitive) then
          ! change to primitive variables
          w(ixo^s,mom(1:ndir))=v(ixo^s,1:ndir)
          if(mhd_energy) w(ixo^s,e_)=pressure(ixo^s)
        end if
        call small_values_error(w, x, ixi^l, ixo^l, flag, subname)
      end select
    end if
    if (mhd_fip) call mhd_bound_fip(primitive, ixi^l, ixo^l, w)
  end subroutine mhd_handle_small_values_semirelati
 
  subroutine mhd_handle_small_values_origin(primitive, w, x, ixI^L, ixO^L, subname)
    use mod_global_parameters
    use mod_small_values
    logical, intent(in)             :: primitive
    integer, intent(in)             :: ixi^l,ixo^l
    double precision, intent(inout) :: w(ixi^s,1:nw)
    double precision, intent(in)    :: x(ixi^s,1:ndim)
    character(len=*), intent(in)    :: subname
 
    integer :: ix^d, igrp
    logical :: flag(ixi^s,1:nw)
 
    call phys_check_w(primitive, ixi^l, ixo^l, w, flag)
 
    if(any(flag)) then
      select case (small_values_method)
      case ("replace")
       {do ix^db=ixomin^db,ixomax^db\}
          if(flag(ix^d,rho_)) w(ix^d,rho_)=small_density
         {
          if(small_values_fix_iw(m^c_)) then
            if(flag({ix^d},rho_)) w({ix^d},m^c_)=0.0d0
          end if
          \}
          if(primitive) then
            if(flag(ix^d,e_)) w(ix^d,p_)=small_pressure
          else
            if(mhd_uawsom) then
              if(flag(ix^d,waplus_)) w(ix^d,waplus_)=zero
              if(flag(ix^d,waminus_)) w(ix^d,waminus_)=zero
              if(flag(ix^d,wkplus_)) w(ix^d,wkplus_)=zero
              if(flag(ix^d,wkminus_)) w(ix^d,wkminus_)=zero
            end if
            if(flag(ix^d,e_)) &
              w(ix^d,e_)=small_e+half*((^c&w(ix^d,m^c_)**2+)/w(ix^d,rho_)+(^c&w(ix^d,b^c_)**2+))&
                   +mhd_uawsom_wave_energy_cell(w(ix^d,:))
          end if
          if(mhd_radiation_fld)then
            if(small_values_fix_iw(r_e)) then
             if(flag(ix^d,r_e)) w(ix^d,r_e)=small_r_e
            endif
          endif
       {end do\}
      case ("average")
        ! do averaging of density
        call small_values_average(ixi^l, ixo^l, w, x, flag, rho_)
        if(primitive)then
          call small_values_average(ixi^l, ixo^l, w, x, flag, p_)
        else
          if(mhd_uawsom) then
            call small_values_average(ixi^l,ixo^l,w,x,flag,waplus_)
            call small_values_average(ixi^l,ixo^l,w,x,flag,waminus_)
            call small_values_average(ixi^l,ixo^l,w,x,flag,wkplus_)
            call small_values_average(ixi^l,ixo^l,w,x,flag,wkminus_)
          end if
          ! do averaging of internal energy
         {do ix^db=iximin^db,iximax^db\}
            w(ix^d,e_)=w(ix^d,e_)&
                -half*((^c&w(ix^d,m^c_)**2+)/w(ix^d,rho_)+(^c&w(ix^d,b^c_)**2+))&
                -mhd_uawsom_wave_energy_cell(w(ix^d,:))
         {end do\}
          call small_values_average(ixi^l, ixo^l, w, x, flag, e_)
          ! convert back
         {do ix^db=iximin^db,iximax^db\}
            w(ix^d,e_)=w(ix^d,e_)&
                +half*((^c&w(ix^d,m^c_)**2+)/w(ix^d,rho_)+(^c&w(ix^d,b^c_)**2+))&
                +mhd_uawsom_wave_energy_cell(w(ix^d,:))
         {end do\}
        end if
        if(mhd_radiation_fld) then
           call small_values_average(ixi^l, ixo^l, w, x, flag, r_e)
        endif
      case default
        if(.not.primitive) then
          !convert w to primitive
         {do ix^db=ixomin^db,ixomax^db\}
            ^c&w(ix^d,m^c_)=w(ix^d,m^c_)/w(ix^d,rho_)\
            w(ix^d,p_)=eos%gamma_minus_1*(w(ix^d,e_)&
                -half*((^c&w(ix^d,m^c_)**2+)*w(ix^d,rho_)+(^c&w(ix^d,b^c_)**2+))&
                -mhd_uawsom_wave_energy_cell(w(ix^d,:)))
         {end do\}
        end if
        call small_values_error(w, x, ixi^l, ixo^l, flag, subname)
      end select
    end if
    if (mhd_fip) call mhd_bound_fip(primitive, ixi^l, ixo^l, w)
  end subroutine mhd_handle_small_values_origin
 
  subroutine mhd_handle_small_values_split(primitive, w, x, ixI^L, ixO^L, subname)
    use mod_global_parameters
    use mod_small_values
    logical, intent(in)             :: primitive
    integer, intent(in)             :: ixi^l,ixo^l
    double precision, intent(inout) :: w(ixi^s,1:nw)
    double precision, intent(in)    :: x(ixi^s,1:ndim)
    character(len=*), intent(in)    :: subname
 
    double precision :: rho
    integer :: ix^d, igrp
    logical :: flag(ixi^s,1:nw)
 
    call phys_check_w(primitive, ixi^l, ixo^l, w, flag)
 
    if(any(flag)) then
      select case (small_values_method)
      case ("replace")
       {do ix^db=ixomin^db,ixomax^db\}
          rho=w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,0)
          if(flag(ix^d,rho_)) w(ix^d,rho_)=small_density-block%equi_vars(ix^d,equi_rho0_,0)
         {
          if(small_values_fix_iw(m^c_)) then
            if(flag({ix^d},rho_)) w({ix^d},m^c_)=0.0d0
          end if
          \}
          if(primitive) then
            if(flag(ix^d,e_)) w(ix^d,p_)=small_pressure-block%equi_vars(ix^d,equi_pe0_,0)
          else
            if(flag(ix^d,e_)) &
              w(ix^d,e_)=small_e+half*((^c&w(ix^d,m^c_)**2+)/rho+(^c&w(ix^d,b^c_)**2+))&
              -block%equi_vars(ix^d,equi_pe0_,0)*eos%inv_gamma_minus_1
          end if
       {end do\}
      case ("average")
        ! do averaging of density
        call small_values_average(ixi^l, ixo^l, w, x, flag, rho_)
        if(primitive)then
          call small_values_average(ixi^l, ixo^l, w, x, flag, p_)
        else
          ! do averaging of internal energy
         {do ix^db=iximin^db,iximax^db\}
            rho=w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,0)
            w(ix^d,e_)=w(ix^d,e_)&
                -half*((^c&w(ix^d,m^c_)**2+)/rho+(^c&w(ix^d,b^c_)**2+))
         {end do\}
          call small_values_average(ixi^l, ixo^l, w, x, flag, e_)
          ! convert back
         {do ix^db=iximin^db,iximax^db\}
            rho=w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,0)
            w(ix^d,e_)=w(ix^d,e_)&
                +half*((^c&w(ix^d,m^c_)**2+)/rho+(^c&w(ix^d,b^c_)**2+))
         {end do\}
        end if
      case default
        if(.not.primitive) then
          !convert w to primitive
         {do ix^db=ixomin^db,ixomax^db\}
            rho=w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,0)
         ^c&w(ix^d,m^c_)=w(ix^d,m^c_)/rho\
            w(ix^d,p_)=eos%gamma_minus_1*(w(ix^d,e_)&
                -half*((^c&w(ix^d,m^c_)**2+)*rho+(^c&w(ix^d,b^c_)**2+)))
         {end do\}
        end if
        call small_values_error(w, x, ixi^l, ixo^l, flag, subname)
      end select
    end if
    if (mhd_fip) call mhd_bound_fip(primitive, ixi^l, ixo^l, w)
  end subroutine mhd_handle_small_values_split
 
  subroutine mhd_handle_small_values_inte(primitive, w, x, ixI^L, ixO^L, subname)
    use mod_global_parameters
    use mod_small_values
    logical, intent(in)             :: primitive
    integer, intent(in)             :: ixi^l,ixo^l
    double precision, intent(inout) :: w(ixi^s,1:nw)
    double precision, intent(in)    :: x(ixi^s,1:ndim)
    character(len=*), intent(in)    :: subname
 
    integer :: ix^d, igrp
    logical :: flag(ixi^s,1:nw)
 
    call phys_check_w(primitive, ixi^l, ixo^l, w, flag)
 
    if(any(flag)) then
      select case (small_values_method)
      case ("replace")
       {do ix^db=ixomin^db,ixomax^db\}
          if(flag(ix^d,rho_)) then
            w(ix^d,rho_)=small_density
            ^c&w(ix^d,m^c_)=0.d0\
          end if
          if(primitive) then
            if(flag(ix^d,e_)) w(ix^d,p_)=small_pressure
          else
            if(flag(ix^d,e_)) w(ix^d,e_)=small_e
          end if
       {end do\}
      case ("average")
        ! do averaging of density
        call small_values_average(ixi^l, ixo^l, w, x, flag, rho_)
        ! do averaging of internal energy
        call small_values_average(ixi^l, ixo^l, w, x, flag, p_)
      case default
        if(.not.primitive) then
          !convert w to primitive
         {do ix^db=ixomin^db,ixomax^db\}
            ^c&w(ix^d,m^c_)=w(ix^d,m^c_)/w(ix^d,rho_)\
            w(ix^d,p_)=eos%gamma_minus_1*w(ix^d,e_)
         {end do\}
        end if
        call small_values_error(w, x, ixi^l, ixo^l, flag, subname)
      end select
    end if
    if (mhd_fip) call mhd_bound_fip(primitive, ixi^l, ixo^l, w)
  end subroutine mhd_handle_small_values_inte
 
  subroutine mhd_handle_small_values_noe(primitive, w, x, ixI^L, ixO^L, subname)
    use mod_global_parameters
    use mod_small_values
    logical, intent(in)             :: primitive
    integer, intent(in)             :: ixi^l,ixo^l
    double precision, intent(inout) :: w(ixi^s,1:nw)
    double precision, intent(in)    :: x(ixi^s,1:ndim)
    character(len=*), intent(in)    :: subname
 
    integer :: ix^d, igrp
    logical :: flag(ixi^s,1:nw)
 
    call phys_check_w(primitive, ixi^l, ixo^l, w, flag)
 
    if(any(flag)) then
      select case (small_values_method)
      case ("replace")
       {do ix^db=ixomin^db,ixomax^db\}
          if(flag(ix^d,rho_)) w(ix^d,rho_)=small_density
         {
          if(small_values_fix_iw(m^c_)) then
            if(flag({ix^d},rho_)) w({ix^d},m^c_)=0.0d0
          end if
          \}
       {end do\}
      case ("average")
        ! do averaging of density
        call small_values_average(ixi^l, ixo^l, w, x, flag, rho_)
      case default
        if(.not.primitive) then
          !convert w to primitive
         {do ix^db=ixomin^db,ixomax^db\}
            ^c&w(ix^d,m^c_)=w(ix^d,m^c_)/w(ix^d,rho_)\
         {end do\}
        end if
        call small_values_error(w, x, ixi^l, ixo^l, flag, subname)
      end select
    end if
    if (mhd_fip) call mhd_bound_fip(primitive, ixi^l, ixo^l, w)
  end subroutine mhd_handle_small_values_noe
 
  subroutine mhd_handle_small_values_hde(primitive, w, x, ixI^L, ixO^L, subname)
    use mod_global_parameters
    use mod_small_values
    logical, intent(in)             :: primitive
    integer, intent(in)             :: ixi^l,ixo^l
    double precision, intent(inout) :: w(ixi^s,1:nw)
    double precision, intent(in)    :: x(ixi^s,1:ndim)
    character(len=*), intent(in)    :: subname
 
    integer :: ix^d, igrp
    logical :: flag(ixi^s,1:nw)
 
    call phys_check_w(primitive, ixi^l, ixo^l, w, flag)
 
    if(any(flag)) then
      select case (small_values_method)
      case ("replace")
       {do ix^db=ixomin^db,ixomax^db\}
          if(flag(ix^d,rho_)) then
            w(ix^d,rho_)=small_density
         ^c&w(ix^d,m^c_)=0.d0\
          end if
          if(primitive) then
            if(flag(ix^d,e_)) w(ix^d,p_)=small_pressure
          else
            if(flag(ix^d,e_)) w(ix^d,e_)=small_e+half*(^c&w(ix^d,m^c_)**2+)/w(ix^d,rho_)
          end if
       {end do\}
      case ("average")
        ! do averaging of density
        call small_values_average(ixi^l, ixo^l, w, x, flag, rho_)
        ! do averaging of energy
        call small_values_average(ixi^l, ixo^l, w, x, flag, e_)
      case default
        if(.not.primitive) then
          !convert w to primitive
         {do ix^db=ixomin^db,ixomax^db\}
         ^c&w(ix^d,m^c_)=w(ix^d,m^c_)/w(ix^d,rho_)\
            w(ix^d,p_)=eos%gamma_minus_1*(w(ix^d,e_)-half*(^c&w(ix^d,m^c_)**2+)*w(ix^d,rho_))
         {end do\}
        end if
        call small_values_error(w, x, ixi^l, ixo^l, flag, subname)
      end select
    end if
    if (mhd_fip) call mhd_bound_fip(primitive, ixi^l, ixo^l, w)
  end subroutine mhd_handle_small_values_hde
 
  !> Calculate v vector
  subroutine mhd_get_v(w,x,ixI^L,ixO^L,v)
    use mod_global_parameters
 
    integer, intent(in)           :: ixi^l, ixo^l
    double precision, intent(in)  :: w(ixi^s,nw), x(ixi^s,1:ndim)
    double precision, intent(out) :: v(ixi^s,ndir)
 
    double precision :: rho(ixi^s)
    integer :: idir
 
    call mhd_get_rho(w,x,ixi^l,ixo^l,rho)
 
    rho(ixo^s)=1.d0/rho(ixo^s)
    ! Convert momentum to velocity
    do idir = 1, ndir
       v(ixo^s, idir) = w(ixo^s, mom(idir))*rho(ixo^s)
    end do
 
  end subroutine mhd_get_v
 
  !> Calculate csound**2 within ixO^L
  subroutine mhd_get_csound2(w,x,ixI^L,ixO^L,cs2)
    use mod_global_parameters
 
    integer, intent(in)          :: ixi^l, ixo^l
    double precision, intent(in) :: w(ixi^s, nw), x(ixi^s,1:ndim)
    double precision, intent(inout) :: cs2(ixi^s)
 
    double precision :: rho, inv_rho, ploc
    integer :: ix^d
 
    {do ix^db=ixomin^db,ixomax^db \}
        if(has_equi_rho_and_p) then
          rho=(w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,0))
          ploc=(w(ix^d,p_)+block%equi_vars(ix^d,equi_pe0_,0))
        else
          rho=w(ix^d,rho_)
          ploc=w(ix^d,p_)
        end if
        inv_rho=1.d0/rho
        ! sound speed**2 
        cs2(ix^d)=eos%gamma*ploc*inv_rho
   {end do\}
  end subroutine mhd_get_csound2
 
  !> Calculate cmax_idim=csound+abs(v_idim) within ixO^L
  subroutine mhd_get_cmax_origin(w,x,ixI^L,ixO^L,idim,cmax)
    use mod_global_parameters
 
    integer, intent(in)          :: ixi^l, ixo^l, idim
    double precision, intent(in) :: w(ixi^s, nw), x(ixi^s,1:ndim)
    double precision, intent(inout) :: cmax(ixi^s)
 
    double precision :: rho, inv_rho, ploc, cfast2, avmincs2, b2, kmax
    double precision :: cs2(ixi^s)
    double precision :: uawsom_zeta(ixi^s), uawsom_radius(ixi^s), uawsom_lperp(ixi^s)
    integer :: ix^d
 
    if(mhd_hall) kmax = dpi/min({dxlevel(^d)},bigdouble)*half
    if(mhd_uawsom) call mhd_uawsom_get_coefficients(w,x,ixi^l,ixo^l,.true.,&
         uawsom_zeta,uawsom_radius,uawsom_lperp)
 
    ! Sound speed squared via EoS dispatch (LTE+ionE -> Gamma_1 table; FI -> const gamma).
    call eos%get_csound2(w, x, ixi^l, ixo^l, cs2)
 
    if(b0field) then
     {do ix^db=ixomin^db,ixomax^db \}
        if(has_equi_rho_and_p) then
          rho=(w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,b0i))
          ploc=(w(ix^d,p_)+block%equi_vars(ix^d,equi_pe0_,b0i))
        else
          rho=w(ix^d,rho_)
          ploc=w(ix^d,p_)
        end if
        inv_rho=1.d0/rho
        cmax(ix^d)=cs2(ix^d)
        ! store |B|^2 in v
        b2=(^c&(w(ix^d,b^c_)+block%B0(ix^d,^c,b0i))**2+)
        cfast2=b2*inv_rho+cmax(ix^d)
        avmincs2=cfast2**2-4.0d0*cmax(ix^d)*(w(ix^d,mag(idim))+block%B0(ix^d,idim,b0i))**2*inv_rho
        if(avmincs2<zero) avmincs2=zero
        cmax(ix^d)=sqrt(half*(cfast2+sqrt(avmincs2)))
        if(mhd_hall) then
          ! take the Hall velocity into account: most simple estimate, high k limit:
          ! largest wavenumber supported by grid: Nyquist (in practise can reduce by some factor)
          cmax(ix^d)=max(cmax(ix^d),mhd_etah*sqrt(b2)*inv_rho*kmax)
        end if
        if(mhd_uawsom) then
          cmax(ix^d)=max(cmax(ix^d),abs(w(ix^d,mag(idim))+&
               block%B0(ix^d,idim,b0i))*dsqrt(inv_rho))
          cmax(ix^d)=max(cmax(ix^d),abs(w(ix^d,mag(idim))+&
               block%B0(ix^d,idim,b0i))/dsqrt(rho*&
               ((uawsom_zeta(ix^d)+one)/(two*(one+mhd_uawsom_filling_factor*&
               uawsom_zeta(ix^d)-mhd_uawsom_filling_factor)))))
        end if
        cmax(ix^d)=abs(w(ix^d,mom(idim)))+cmax(ix^d)
     {end do\}
    else
     {do ix^db=ixomin^db,ixomax^db \}
        if(has_equi_rho_and_p) then
          rho=(w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,b0i))
          ploc=(w(ix^d,p_)+block%equi_vars(ix^d,equi_pe0_,b0i))
        else
          rho=w(ix^d,rho_)
          ploc=w(ix^d,p_)
        end if
        inv_rho=1.d0/rho
        cmax(ix^d)=cs2(ix^d)
        ! store |B|^2 in v
        b2=(^c&w(ix^d,b^c_)**2+)
        cfast2=b2*inv_rho+cmax(ix^d)
        avmincs2=cfast2**2-4.0d0*cmax(ix^d)*w(ix^d,mag(idim))**2*inv_rho
        if(avmincs2<zero) avmincs2=zero
        cmax(ix^d)=sqrt(half*(cfast2+sqrt(avmincs2)))
        if(mhd_hall) then
          ! take the Hall velocity into account: most simple estimate, high k limit:
          ! largest wavenumber supported by grid: Nyquist (in practise can reduce by some factor)
          cmax(ix^d)=max(cmax(ix^d),mhd_etah*sqrt(b2)*inv_rho*kmax)
        end if
        if(mhd_uawsom) then
          cmax(ix^d)=max(cmax(ix^d),abs(w(ix^d,mag(idim)))*dsqrt(inv_rho))
          cmax(ix^d)=max(cmax(ix^d),abs(w(ix^d,mag(idim)))/dsqrt(rho*&
               ((uawsom_zeta(ix^d)+one)/(two*(one+mhd_uawsom_filling_factor*&
               uawsom_zeta(ix^d)-mhd_uawsom_filling_factor)))))
        end if
        cmax(ix^d)=abs(w(ix^d,mom(idim)))+cmax(ix^d)
     {end do\}
    end if
 
  end subroutine mhd_get_cmax_origin
 
  !> Calculate cmax_idim=csound+abs(v_idim) within ixO^L
  subroutine mhd_get_cmax_origin_noe(w,x,ixI^L,ixO^L,idim,cmax)
    use mod_global_parameters
    use mod_usr_methods, only: usr_set_adiab, usr_set_gamma
 
    integer, intent(in)          :: ixi^l, ixo^l, idim
    double precision, intent(in) :: w(ixi^s, nw), x(ixi^s,1:ndim)
    double precision, intent(inout) :: cmax(ixi^s)
 
    double precision :: rho, inv_rho, cfast2, avmincs2, b2, kmax
    double precision :: adiabs(ixi^s), gammas(ixi^s)
    integer :: ix^d
 
    if(mhd_hall) kmax = dpi/min({dxlevel(^d)},bigdouble)*half
 
    if(associated(usr_set_adiab)) then
       call usr_set_adiab(w,x,ixi^l,ixo^l,adiabs)
    else
       adiabs=mhd_adiab
    end if
    if(associated(usr_set_gamma)) then
       call usr_set_gamma(w,x,ixi^l,ixo^l,gammas)
    else
       gammas=eos%gamma
    end if
   {do ix^db=ixomin^db,ixomax^db \}
       rho=w(ix^d,rho_)
       inv_rho=1.d0/rho
       ! sound speed**2 
       cmax(ix^d)=gammas(ix^d)*adiabs(ix^d)*rho**(gammas(ix^d)-1.d0)
       ! store |B|^2 in v
       b2=(^c&w(ix^d,b^c_)**2+)
       cfast2=b2*inv_rho+cmax(ix^d)
       avmincs2=cfast2**2-4.0d0*cmax(ix^d)*w(ix^d,mag(idim))**2*inv_rho
       if(avmincs2<zero) avmincs2=zero
       cmax(ix^d)=sqrt(half*(cfast2+sqrt(avmincs2)))
       if(mhd_hall) then
         ! take the Hall velocity into account: most simple estimate, high k limit:
         ! largest wavenumber supported by grid: Nyquist (in practise can reduce by some factor)
         cmax(ix^d)=max(cmax(ix^d),mhd_etah*sqrt(b2)*inv_rho*kmax)
       end if
       cmax(ix^d)=abs(w(ix^d,mom(idim)))+cmax(ix^d)
   {end do\}
 
  end subroutine mhd_get_cmax_origin_noe
 
  !> Calculate cmax_idim for semirelativistic MHD
  subroutine mhd_get_cmax_semirelati(w,x,ixI^L,ixO^L,idim,cmax)
    use mod_global_parameters
 
    integer, intent(in)          :: ixi^l, ixo^l, idim
    double precision, intent(in) :: w(ixi^s, nw), x(ixi^s,1:ndim)
    double precision, intent(inout):: cmax(ixi^s)
 
    double precision :: csound, avmincs2, idim_alfven_speed2
    double precision :: inv_rho, alfven_speed2, gamma2
    integer :: ix^d
 
   {do ix^db=ixomin^db,ixomax^db \}
      inv_rho=1.d0/w(ix^d,rho_)
      alfven_speed2=(^c&w(ix^d,b^c_)**2+)*inv_rho
      gamma2=1.0d0/(1.d0+alfven_speed2*inv_squared_c)
      cmax(ix^d)=1.d0-gamma2*w(ix^d,mom(idim))**2*inv_squared_c
      ! squared sound speed
      csound=eos%gamma*w(ix^d,p_)*inv_rho
      idim_alfven_speed2=w(ix^d,mag(idim))**2*inv_rho
      ! Va_hat^2+a_hat^2 equation (57)
      ! equation (69)
      alfven_speed2=alfven_speed2*cmax(ix^d)+csound*(1.d0+idim_alfven_speed2*inv_squared_c)
      avmincs2=(gamma2*alfven_speed2)**2-4.0d0*gamma2*csound*idim_alfven_speed2*cmax(ix^d)
      if(avmincs2<zero) avmincs2=zero
      ! equation (68) fast magnetosonic wave speed
      csound = sqrt(half*(gamma2*alfven_speed2+sqrt(avmincs2)))
      cmax(ix^d)=gamma2*abs(w(ix^d,mom(idim)))+csound
   {end do\}
 
  end subroutine mhd_get_cmax_semirelati
 
  !> Calculate cmax_idim for semirelativistic MHD
  subroutine mhd_get_cmax_semirelati_noe(w,x,ixI^L,ixO^L,idim,cmax)
    use mod_global_parameters
    use mod_usr_methods, only: usr_set_adiab, usr_set_gamma
 
    integer, intent(in)          :: ixi^l, ixo^l, idim
    double precision, intent(in) :: w(ixi^s, nw), x(ixi^s,1:ndim)
    double precision, intent(inout):: cmax(ixi^s)
 
    double precision :: adiabs(ixi^s), gammas(ixi^s)
    double precision :: csound, avmincs2, idim_alfven_speed2
    double precision :: inv_rho, alfven_speed2, gamma2
    integer :: ix^d
 
    if(associated(usr_set_adiab)) then
       call usr_set_adiab(w,x,ixi^l,ixo^l,adiabs)
    else
       adiabs=mhd_adiab
    end if
    if(associated(usr_set_gamma)) then
       call usr_set_gamma(w,x,ixi^l,ixo^l,gammas)
    else
       gammas=eos%gamma
    end if
 
   {do ix^db=ixomin^db,ixomax^db \}
      inv_rho=1.d0/w(ix^d,rho_)
      alfven_speed2=(^c&w(ix^d,b^c_)**2+)*inv_rho
      gamma2=1.0d0/(1.d0+alfven_speed2*inv_squared_c)
      cmax(ix^d)=1.d0-gamma2*w(ix^d,mom(idim))**2*inv_squared_c
      csound=gammas(ix^d)*adiabs(ix^d)*w(ix^d,rho_)**(gammas(ix^d)-1.d0)
      idim_alfven_speed2=w(ix^d,mag(idim))**2*inv_rho
      ! Va_hat^2+a_hat^2 equation (57)
      ! equation (69)
      alfven_speed2=alfven_speed2*cmax(ix^d)+csound*(1.d0+idim_alfven_speed2*inv_squared_c)
      avmincs2=(gamma2*alfven_speed2)**2-4.0d0*gamma2*csound*idim_alfven_speed2*cmax(ix^d)
      if(avmincs2<zero) avmincs2=zero
      ! equation (68) fast magnetosonic wave speed
      csound = sqrt(half*(gamma2*alfven_speed2+sqrt(avmincs2)))
      cmax(ix^d)=gamma2*abs(w(ix^d,mom(idim)))+csound
   {end do\}
 
  end subroutine mhd_get_cmax_semirelati_noe
 
  !> get adaptive cutoff temperature for TRAC (Johnston 2019 ApJL, 873, L22)
  subroutine mhd_get_tcutoff(ixI^L,ixO^L,w,x,Tco_local,Tmax_local)
    use mod_global_parameters
    use mod_geometry
    use mod_usr_methods, only: usr_get_heating
    use mod_radiative_cooling, only: findl, calc_l_extended
    integer, intent(in) :: ixi^l,ixo^l
    double precision, intent(in) :: x(ixi^s,1:ndim)
    ! in primitive form
    double precision, intent(inout) :: w(ixi^s,1:nw)
    double precision, intent(out) :: tco_local,tmax_local
 
    double precision, parameter :: trac_delta=0.25d0
    double precision :: te(ixi^s),lts(ixi^s)
    double precision, dimension(1:ndim) :: bdir, bunitvec
    double precision, dimension(ixI^S,1:ndim) :: gradt
    double precision :: ltrc,ltrp,altr
    integer :: idims,ix^d,jxo^l,hxo^l,ixa^d,ixb^d
    integer :: jxp^l,hxp^l,ixp^l,ixq^l
    ! TRAC-7 (Johnston et al. 2021, A&A 654 A2) field-aligned local method
    double precision :: q_heat(ixi^s), ne(ixi^s), nh_arr(ixi^s)
    double precision :: bvec(1:ndir)
    double precision :: bmin_c, bmag, gnorm, bgtd, l_t, dl_eff, vmag, bdotv, binp2
    double precision :: v_n, a_coeff, l1, cooling, net_cool
    double precision :: kappa_par, disc, dx_over_delta, kappa_trac, kappa_eff, tcoff_eff
 
    if (eos%eos_type == 'LTE' .or. eos%eos_type == 'PI') then
      te(ixi^s) = w(ixi^s, te_)
    else
      call eos%get_Rfactor(w,x,ixi^l,ixi^l,te)
      te(ixi^s)=w(ixi^s,p_)/(te(ixi^s)*w(ixi^s,rho_))
    end if
    tco_local=zero
    tmax_local=maxval(te(ixo^s))
 
    {^ifoned
    select case(mhd_trac_type)
    case(0)
      !> test case, fixed cutoff temperature
      block%wextra(ixi^s,tcoff_)=2.5d5/unit_temperature
    case(1)
      do ix1=ixomin1,ixomax1
        lts(ix1)=0.5d0*abs(te(ix1+1)-te(ix1-1))/te(ix1)
        if(lts(ix1)>trac_delta) then
          tco_local=max(tco_local,te(ix1))
        end if
      end do
    case(2)
      !> iijima et al. 2021, LTRAC method
      ltrc=1.5d0
      ltrp=4.d0
      ixp^l=ixo^l^ladd1;
      hxo^l=ixo^l-1;
      jxo^l=ixo^l+1;
      hxp^l=ixp^l-1;
      jxp^l=ixp^l+1;
      lts(ixp^s)=0.5d0*abs(te(jxp^s)-te(hxp^s))/te(ixp^s)
      lts(ixp^s)=max(one, (exp(lts(ixp^s))/ltrc)**ltrp)
      lts(ixo^s)=0.25d0*(lts(jxo^s)+two*lts(ixo^s)+lts(hxo^s))
      block%wextra(ixo^s,tcoff_)=te(ixo^s)*lts(ixo^s)**0.4d0
    case default
      call mpistop("mhd_trac_type not allowed for 1D simulation")
    end select
    }
    {^nooned
    select case(mhd_trac_type)
    case(0)
      !> test case, fixed cutoff temperature
      block%wextra(ixi^s,tcoff_)=2.5d5/unit_temperature
    case(1,4,6)
      ! temperature gradient at cell centers
      do idims=1,ndim
        call gradient(te,ixi^l,ixo^l,idims,gradt(ixi^s,idims))
      end do
      if(mhd_trac_type .gt. 1) then
        ! B direction at block center
        bdir=zero
        if(b0field) then
          {do ixa^d=0,1\}
            ixb^d=(ixomin^d+ixomax^d-1)/2+ixa^d;
            bdir(1:ndim)=bdir(1:ndim)+w(ixb^d,iw_mag(1:ndim))+block%B0(ixb^d,1:ndim,0)
          {end do\}
        else
          {do ixa^d=0,1\}
            ixb^d=(ixomin^d+ixomax^d-1)/2+ixa^d;
            bdir(1:ndim)=bdir(1:ndim)+w(ixb^d,iw_mag(1:ndim))
          {end do\}
        end if
        {^iftwod
        if(bdir(1)/=0.d0) then
          block%special_values(3)=sign(1.d0,bdir(1))/dsqrt(1.d0+(bdir(2)/bdir(1))**2)
        else
          block%special_values(3)=0.d0
        end if
        if(bdir(2)/=0.d0) then
          block%special_values(4)=sign(1.d0,bdir(2))/dsqrt(1.d0+(bdir(1)/bdir(2))**2)
        else
          block%special_values(4)=0.d0
        end if
        }
        {^ifthreed
        if(bdir(1)/=0.d0) then
          block%special_values(3)=sign(1.d0,bdir(1))/dsqrt(1.d0+(bdir(2)/bdir(1))**2+&
           (bdir(3)/bdir(1))**2)
        else
          block%special_values(3)=0.d0
        end if
        if(bdir(2)/=0.d0) then
          block%special_values(4)=sign(1.d0,bdir(2))/dsqrt(1.d0+(bdir(1)/bdir(2))**2+&
           (bdir(3)/bdir(2))**2)
        else
          block%special_values(4)=0.d0
        end if
        if(bdir(3)/=0.d0) then
          block%special_values(5)=sign(1.d0,bdir(3))/dsqrt(1.d0+(bdir(1)/bdir(3))**2+&
           (bdir(2)/bdir(3))**2)
        else
          block%special_values(5)=0.d0
        end if
        }
      end if
      ! b unit vector: magnetic field direction vector
      block%special_values(1)=zero
     {do ix^db=ixomin^db,ixomax^db\}
        if(b0field) then
          ^d&bdir(^d)=w({ix^d},iw_mag(^d))+block%B0({ix^d},^d,0)\
        else
          ^d&bdir(^d)=w({ix^d},iw_mag(^d))\
        end if
        {^iftwod
        if(bdir(1)/=0.d0) then
          bunitvec(1)=sign(1.d0,bdir(1))/dsqrt(1.d0+(bdir(2)/bdir(1))**2)
        else
          bunitvec(1)=0.d0
        end if
        if(bdir(2)/=0.d0) then
          bunitvec(2)=sign(1.d0,bdir(2))/dsqrt(1.d0+(bdir(1)/bdir(2))**2)
        else
          bunitvec(2)=0.d0
        end if
        ! temperature length scale inversed
        lts(ix^d)=min(block%ds(ix^d,1),block%ds(ix^d,2))*&
          abs(^d&gradt({ix^d},^d)*bunitvec(^d)+)/te(ix^d)
        }
        {^ifthreed
        if(bdir(1)/=0.d0) then
          bunitvec(1)=sign(1.d0,bdir(1))/dsqrt(1.d0+(bdir(2)/bdir(1))**2+(bdir(3)/bdir(1))**2)
        else
          bunitvec(1)=0.d0
        end if
        if(bdir(2)/=0.d0) then
          bunitvec(2)=sign(1.d0,bdir(2))/dsqrt(1.d0+(bdir(1)/bdir(2))**2+(bdir(3)/bdir(2))**2)
        else
          bunitvec(2)=0.d0
        end if
        if(bdir(3)/=0.d0) then
          bunitvec(3)=sign(1.d0,bdir(3))/dsqrt(1.d0+(bdir(1)/bdir(3))**2+(bdir(2)/bdir(3))**2)
        else
          bunitvec(3)=0.d0
        end if
        ! temperature length scale inversed
        lts(ix^d)=min(block%ds(ix^d,1),block%ds(ix^d,2),block%ds(ix^d,3))*&
          abs(^d&gradt({ix^d},^d)*bunitvec(^d)+)/te(ix^d)
        }
        if(lts(ix^d)>trac_delta) then
          block%special_values(1)=max(block%special_values(1),te(ix^d))
        end if
     {end do\}
      block%special_values(2)=tmax_local
    case(2)
      !> iijima et al. 2021, LTRAC method
      ltrc=1.5d0
      ltrp=4.d0
      ixp^l=ixo^l^ladd2;
      ! temperature gradient at cell centers
      do idims=1,ndim
        ixq^l=ixp^l;
        hxp^l=ixp^l;
        jxp^l=ixp^l;
        select case(idims)
          {case(^d)
           ixqmin^d=ixqmin^d+1
           ixqmax^d=ixqmax^d-1
           hxpmax^d=ixpmin^d
           jxpmin^d=ixpmax^d
          \}
        end select
        call gradient(te,ixi^l,ixq^l,idims,gradt(ixi^s,idims))
        ! The outermost ghost cell has no room for a fourth-order one-sided
        ! stencil.  A first-order one-sided gradient keeps the two-ghost-layer
        ! LTRAC coverage without reading outside ixI.
        call gradientf(te,x,ixi^l,hxp^l,idims,gradt(ixi^s,idims),1,.true.)
        call gradientf(te,x,ixi^l,jxp^l,idims,gradt(ixi^s,idims),1,.false.)
      end do
      ! b unit vector: magnetic field direction vector
      if(b0field) then
       {do ix^db=ixpmin^db,ixpmax^db\}
          ^d&bdir(^d)=w({ix^d},iw_mag(^d))+block%B0({ix^d},^d,0)\
          {^iftwod
          if(bdir(1)/=0.d0) then
            bunitvec(1)=sign(1.d0,bdir(1))/dsqrt(1.d0+(bdir(2)/bdir(1))**2)
          else
            bunitvec(1)=0.d0
          end if
          if(bdir(2)/=0.d0) then
            bunitvec(2)=sign(1.d0,bdir(2))/dsqrt(1.d0+(bdir(1)/bdir(2))**2)
          else
            bunitvec(2)=0.d0
          end if
          }
          {^ifthreed
          if(bdir(1)/=0.d0) then
            bunitvec(1)=sign(1.d0,bdir(1))/dsqrt(1.d0+(bdir(2)/bdir(1))**2+(bdir(3)/bdir(1))**2)
          else
            bunitvec(1)=0.d0
          end if
          if(bdir(2)/=0.d0) then
            bunitvec(2)=sign(1.d0,bdir(2))/dsqrt(1.d0+(bdir(1)/bdir(2))**2+(bdir(3)/bdir(2))**2)
          else
            bunitvec(2)=0.d0
          end if
          if(bdir(3)/=0.d0) then
            bunitvec(3)=sign(1.d0,bdir(3))/dsqrt(1.d0+(bdir(1)/bdir(3))**2+(bdir(2)/bdir(3))**2)
          else
            bunitvec(3)=0.d0
          end if
          }
          ! temperature length scale inversed
          lts(ix^d)=abs(^d&gradt({ix^d},^d)*bunitvec(^d)+)/te(ix^d)
          ! fraction of cells size to temperature length scale
          lts(ix^d)=min(^d&block%ds({ix^d},^d))*lts(ix^d)
          lts(ix^d)=max(one,(exp(lts(ix^d))/ltrc)**ltrp)
       {end do\}
      else
       {do ix^db=ixpmin^db,ixpmax^db\}
         {^iftwod
          if(w(ix^d,iw_mag(1))/=0.d0) then
            bunitvec(1)=sign(1.d0,w(ix^d,iw_mag(1)))/dsqrt(1.d0+(w(ix^d,iw_mag(2))/w(ix^d,iw_mag(1)))**2)
          else
            bunitvec(1)=0.d0
          end if
          if(w(ix^d,iw_mag(2))/=0.d0) then
            bunitvec(2)=sign(1.d0,w(ix^d,iw_mag(2)))/dsqrt(1.d0+(w(ix^d,iw_mag(1))/w(ix^d,iw_mag(2)))**2)
          else
            bunitvec(2)=0.d0
          end if
         }
         {^ifthreed
          if(w(ix^d,iw_mag(1))/=0.d0) then
            bunitvec(1)=sign(1.d0,w(ix^d,iw_mag(1)))/dsqrt(1.d0+(w(ix^d,iw_mag(2))/w(ix^d,iw_mag(1)))**2+&
              (w(ix^d,iw_mag(3))/w(ix^d,iw_mag(1)))**2)
          else
            bunitvec(1)=0.d0
          end if
          if(w(ix^d,iw_mag(2))/=0.d0) then
            bunitvec(2)=sign(1.d0,w(ix^d,iw_mag(2)))/dsqrt(1.d0+(w(ix^d,iw_mag(1))/w(ix^d,iw_mag(2)))**2+&
              (w(ix^d,iw_mag(3))/w(ix^d,iw_mag(2)))**2)
          else
            bunitvec(2)=0.d0
          end if
          if(w(ix^d,iw_mag(3))/=0.d0) then
            bunitvec(3)=sign(1.d0,w(ix^d,iw_mag(3)))/dsqrt(1.d0+(w(ix^d,iw_mag(1))/w(ix^d,iw_mag(3)))**2+&
              (w(ix^d,iw_mag(2))/w(ix^d,iw_mag(3)))**2)
          else
            bunitvec(3)=0.d0
          end if
         }
          ! temperature length scale inversed
          lts(ix^d)=abs(^d&gradt({ix^d},^d)*bunitvec(^d)+)/te(ix^d)
          ! fraction of cells size to temperature length scale
          lts(ix^d)=min(^d&block%ds({ix^d},^d))*lts(ix^d)
          lts(ix^d)=max(one,(exp(lts(ix^d))/ltrc)**ltrp)
       {end do\}
      end if
  
      ! need one ghost layer for thermal conductivity
      ixp^l=ixo^l^ladd1;
     {do ix^db=ixpmin^db,ixpmax^db\}
        {^iftwod
        altr=0.25d0*((lts(ix1-1,ix2)+two*lts(ix^d)+lts(ix1+1,ix2))*bunitvec(1)**2+&
                     (lts(ix1,ix2-1)+two*lts(ix^d)+lts(ix1,ix2+1))*bunitvec(2)**2)
        block%wextra(ix^d,tcoff_)=te(ix^d)*altr**0.4d0
        }
        {^ifthreed
        altr=0.25d0*((lts(ix1-1,ix2,ix3)+two*lts(ix^d)+lts(ix1+1,ix2,ix3))*bunitvec(1)**2+&
                     (lts(ix1,ix2-1,ix3)+two*lts(ix^d)+lts(ix1,ix2+1,ix3))*bunitvec(2)**2+&
                     (lts(ix1,ix2,ix3-1)+two*lts(ix^d)+lts(ix1,ix2,ix3+1))*bunitvec(3)**2)
        block%wextra(ix^d,tcoff_)=te(ix^d)*altr**0.4d0
        }
     {end do\}
    case(7)
      ! Johnston et al. 2021 (A&A 654, A2) local field-aligned TRAC for MHD.
      ! Anisotropic conduction broadens the TR along B, so the length scale (Eq.18) and the
      ! enthalpy flux (Eq.16) are projected on the field, regularized by b_min=0.1 G (paper
      ! value) as B->0 or B perpendicular to grad T. Per-cell adaptive parallel conductivity from the
      ! steady-state balance (Eq.11/12) with the Eq.13 selection; general-EoS cooling n_e n_H L.
      ! (HD isotropic version used the grad-T direction; here it is the magnetic field.)
      call usr_get_heating(q_heat, ixi^l, ixo^l, w, x)
      call eos%get_ne_nH(ixi^l, ixo^l, w, x, ne, nh_arr)
      block%wextra(ixi^s,tcoff_) = te(ixi^s)         ! default (incl. ghost layer): no broadening
      do idims=1,ndim
        call gradient(te,ixi^l,ixo^l,idims,gradt(ixi^s,idims))
      end do
      bmin_c = 0.1d0/unit_magneticfield              ! 0.1 G in code units
      {do ix^db=ixomin^db,ixomax^db\}
        ! full field B-magnitude (Eq.18 numerator, regularized), and B.v, v-magnitude over ndir
        bmag=bmin_c**2; bdotv=0.d0; vmag=0.d0
        do idims=1,ndir
          bvec(idims)=w(ix^d,iw_mag(idims))
          if(b0field) bvec(idims)=bvec(idims)+block%B0(ix^d,idims,0)
          bmag =bmag +bvec(idims)**2
          bdotv=bdotv+bvec(idims)*w(ix^d,mom(idims))
          vmag =vmag +w(ix^d,mom(idims))**2
        end do
        bmag=dsqrt(bmag); vmag=dsqrt(vmag)
        ! in-plane grad-T norm, in-plane field^2, and in-plane B.grad T (grad T has no z-part in 2D)
        gnorm=0.d0; binp2=0.d0; bgtd=0.d0
        do idims=1,ndim
          gnorm=gnorm+gradt(ix^d,idims)**2
          binp2=binp2+bvec(idims)**2
          bgtd =bgtd +bvec(idims)*gradt(ix^d,idims)
        end do
        gnorm=dsqrt(gnorm)
        if(gnorm<smalldouble .or. binp2<smalldouble) then
          block%wextra(ix^d,tcoff_)=te(ix^d)          ! uniform T or no in-plane field: no TR
        else
          ! Eq.18 field-aligned length scale (dabs: conduction is bidirectional along B)
          l_t=te(ix^d)*bmag/(dabs(bgtd)+bmin_c*gnorm)
          ! grid spacing along the (in-plane) field direction b = Bvec/Bmag
          dl_eff=0.d0
          do idims=1,ndim
            dl_eff=dl_eff+(bvec(idims)/block%ds(ix^d,idims))**2
          end do
          dl_eff=bmag/dsqrt(dl_eff)
          ! Eq.16 field-aligned enthalpy (mass) flux
          v_n=(dabs(bdotv)+bmin_c*vmag)/bmag
          a_coeff=2.5d0*w(ix^d,p_)*v_n/te(ix^d)
          ! optically-thin cooling n_e n_H Lambda(T), guarded to the table range (positive
          ! in-range test so a non-finite Te falls to zero rather than indexing findL with NaN)
          if(te(ix^d)>rc_fl%tcoolmin .and. te(ix^d)<rc_fl%tcoolmax) then
            call findl(te(ix^d),l1,rc_fl); cooling=l1*ne(ix^d)*nh_arr(ix^d)
          else if(te(ix^d)>=rc_fl%tcoolmax) then
            call calc_l_extended(te(ix^d),l1,rc_fl); cooling=l1*ne(ix^d)*nh_arr(ix^d)
          else
            cooling=0.d0
          end if
          net_cool=dabs(cooling-q_heat(ix^d))
          kappa_par=tc_fl%tc_k_para*te(ix^d)**2.5d0
          disc=a_coeff**2+4.d0*tc_fl%tc_k_para*te(ix^d)**1.5d0*net_cool
          dx_over_delta=dl_eff/mhd_trac_delta
          ! Eq.13 selection: under-resolved (Eq.11, keep mass flux) vs over-resolved (Eq.12, limiter)
          if(l_t<=2.d0*dx_over_delta) then
            kappa_trac=(a_coeff+dsqrt(disc))/(2.d0/dx_over_delta)
          else
            kappa_trac=dsqrt(4.d0*tc_fl%tc_k_para*te(ix^d)**1.5d0*net_cool)/(2.d0/dx_over_delta)
          end if
          kappa_eff=max(kappa_trac,kappa_par)
          tcoff_eff=(kappa_eff/tc_fl%tc_k_para)**0.4d0
          block%wextra(ix^d,tcoff_)=max(te(ix^d),tcoff_eff)
        end if
      {end do\}
    case(3,5)
      !> do nothing here
    case default
      call mpistop("unknown mhd_trac_type")
    end select
    }
  end subroutine mhd_get_tcutoff
 
  !> get H speed for H-correction to fix the carbuncle problem at grid-aligned shock front
  subroutine mhd_get_h_speed(wprim,x,ixI^L,ixO^L,idim,Hspeed)
    use mod_global_parameters
 
    integer, intent(in)             :: ixi^l, ixo^l, idim
    double precision, intent(in)    :: wprim(ixi^s, nw)
    double precision, intent(in)    :: x(ixi^s,1:ndim)
    double precision, intent(out)   :: hspeed(ixi^s,1:number_species)
 
    double precision :: csound(ixi^s,ndim)
    double precision, allocatable :: tmp(:^d&)
    integer :: jxc^l, ixc^l, ixa^l, id, ix^d
 
    hspeed=0.d0
    ixa^l=ixo^l^ladd1;
    allocate(tmp(ixa^s))
    do id=1,ndim
      if(has_equi_rho_and_p) then
         call mhd_get_csound_prim_split(wprim,x,ixi^l,ixa^l,id,tmp)
      else
         call mhd_get_csound_prim(wprim,x,ixi^l,ixa^l,id,tmp)
      endif
      csound(ixa^s,id)=tmp(ixa^s)
    end do
    ixcmax^d=ixomax^d;
    ixcmin^d=ixomin^d+kr(idim,^d)-1;
    jxcmax^d=ixcmax^d+kr(idim,^d);
    jxcmin^d=ixcmin^d+kr(idim,^d);
    hspeed(ixc^s,1)=0.5d0*abs(wprim(jxc^s,mom(idim))+csound(jxc^s,idim)-wprim(ixc^s,mom(idim))+csound(ixc^s,idim))
 
    do id=1,ndim
      if(id==idim) cycle
      ixamax^d=ixcmax^d+kr(id,^d);
      ixamin^d=ixcmin^d+kr(id,^d);
      hspeed(ixc^s,1)=max(hspeed(ixc^s,1),0.5d0*abs(wprim(ixa^s,mom(id))+csound(ixa^s,id)-wprim(ixc^s,mom(id))+csound(ixc^s,id)))
      ixamax^d=ixcmax^d-kr(id,^d);
      ixamin^d=ixcmin^d-kr(id,^d);
      hspeed(ixc^s,1)=max(hspeed(ixc^s,1),0.5d0*abs(wprim(ixc^s,mom(id))+csound(ixc^s,id)-wprim(ixa^s,mom(id))+csound(ixa^s,id)))
    end do
 
    do id=1,ndim
      if(id==idim) cycle
      ixamax^d=jxcmax^d+kr(id,^d);
      ixamin^d=jxcmin^d+kr(id,^d);
      hspeed(ixc^s,1)=max(hspeed(ixc^s,1),0.5d0*abs(wprim(ixa^s,mom(id))+csound(ixa^s,id)-wprim(jxc^s,mom(id))+csound(jxc^s,id)))
      ixamax^d=jxcmax^d-kr(id,^d);
      ixamin^d=jxcmin^d-kr(id,^d);
      hspeed(ixc^s,1)=max(hspeed(ixc^s,1),0.5d0*abs(wprim(jxc^s,mom(id))+csound(jxc^s,id)-wprim(ixa^s,mom(id))+csound(ixa^s,id)))
    end do
    deallocate(tmp)
 
  end subroutine mhd_get_h_speed
 
  !> Estimating bounds for the minimum and maximum signal velocities without split
  subroutine mhd_get_cbounds(wLC,wRC,wLp,wRp,x,ixI^L,ixO^L,idim,Hspeed,cmax,cmin)
    use mod_global_parameters
    !!use mod_fld, only: fld_bound_diff, fld_get_local_invtauc
 
    integer, intent(in)             :: ixi^l, ixo^l, idim
    double precision, intent(in)    :: wlc(ixi^s, nw), wrc(ixi^s, nw)
    double precision, intent(in)    :: wlp(ixi^s, nw), wrp(ixi^s, nw)
    double precision, intent(in)    :: x(ixi^s,1:ndim)
    double precision, intent(inout) :: cmax(ixi^s,1:number_species)
    double precision, intent(inout), optional :: cmin(ixi^s,1:number_species)
    double precision, intent(in)    :: hspeed(ixi^s,1:number_species)
 
    double precision :: wmean(ixi^s,nw), csoundl(ixo^s), csoundr(ixo^s)
    !!double precision :: invtaucL(ixI^S),invtaucR(ixI^S),invtauc
    double precision :: umean, dmean, tmp1, tmp2, tmp3
    integer :: ix^d
 
    select case (boundspeed)
    case (1)
      ! This implements formula (10.52) from "Riemann Solvers and Numerical
      ! Methods for Fluid Dynamics" by Toro.
      call mhd_get_csound_prim(wlp,x,ixi^l,ixo^l,idim,csoundl)
      call mhd_get_csound_prim(wrp,x,ixi^l,ixo^l,idim,csoundr)
      !!if(mhd_radiation_fld.and.fld_bound_diff)then
      !!   call fld_get_local_invtauc(wLp,ixI^L,ixO^L,{dxlevel(^D)},x,invtaucL,fld_fl)
      !!   call fld_get_local_invtauc(wRp,ixI^L,ixO^L,{dxlevel(^D)},x,invtaucR,fld_fl)
      !!endif
      if(present(cmin)) then
       {do ix^db=ixomin^db,ixomax^db\}
          tmp1=sqrt(wlp(ix^d,rho_))
          tmp2=sqrt(wrp(ix^d,rho_))
          tmp3=1.d0/(tmp1+tmp2)
          umean=(wlp(ix^d,mom(idim))*tmp1+wrp(ix^d,mom(idim))*tmp2)*tmp3
          dmean=sqrt((tmp1*csoundl(ix^d)**2+tmp2*csoundr(ix^d)**2)*tmp3+&
           half*tmp1*tmp2*tmp3**2*(wrp(ix^d,mom(idim))-wlp(ix^d,mom(idim)))**2)
          cmin(ix^d,1)=umean-dmean
          cmax(ix^d,1)=umean+dmean
          !!if(mhd_radiation_fld.and.fld_bound_diff)then
          !!  invtauc=min(invtaucL(ix^D),invtaucR(ix^D))
          !!  cmax(ix^D,1)=min(cmax(ix^D,1),+invtauc)
          !!  cmin(ix^D,1)=max(cmin(ix^D,1),-invtauc)
          !!endif
       {end do\}
        if(h_correction) then
          {do ix^db=ixomin^db,ixomax^db\}
            cmin(ix^d,1)=sign(one,cmin(ix^d,1))*max(abs(cmin(ix^d,1)),hspeed(ix^d,1))
            cmax(ix^d,1)=sign(one,cmax(ix^d,1))*max(abs(cmax(ix^d,1)),hspeed(ix^d,1))
          {end do\}
        end if
      else
       {do ix^db=ixomin^db,ixomax^db\}
          tmp1=sqrt(wlp(ix^d,rho_))
          tmp2=sqrt(wrp(ix^d,rho_))
          tmp3=1.d0/(tmp1+tmp2)
          umean=(wlp(ix^d,mom(idim))*tmp1+wrp(ix^d,mom(idim))*tmp2)*tmp3
          dmean=sqrt((tmp1*csoundl(ix^d)**2+tmp2*csoundr(ix^d)**2)*tmp3+&
           half*tmp1*tmp2*tmp3**2*(wrp(ix^d,mom(idim))-wlp(ix^d,mom(idim)))**2)
          cmax(ix^d,1)=abs(umean)+dmean
          !!if(mhd_radiation_fld.and.fld_bound_diff)then
          !!  invtauc=min(invtaucL(ix^D),invtaucR(ix^D))
          !!  cmax(ix^D,1)=min(cmax(ix^D,1),+invtauc)
          !!endif
       {end do\}
      end if
    case (2)
      wmean(ixo^s,1:nwflux)=0.5d0*(wlp(ixo^s,1:nwflux)+wrp(ixo^s,1:nwflux))
      call mhd_get_csound_prim(wmean,x,ixi^l,ixo^l,idim,csoundr)
      !!if(mhd_radiation_fld.and.fld_bound_diff)then
      !!   call fld_get_local_invtauc(wmean,ixI^L,ixO^L,{dxlevel(^D)},x,invtaucL,fld_fl)
      !!endif
      if(present(cmin)) then
       {do ix^db=ixomin^db,ixomax^db\}
          cmax(ix^d,1)=max(wmean(ix^d,mom(idim))+csoundr(ix^d),zero)
          cmin(ix^d,1)=min(wmean(ix^d,mom(idim))-csoundr(ix^d),zero)
          !!if(mhd_radiation_fld.and.fld_bound_diff)then
          !!  invtauc=invtaucL(ix^D)
          !!  cmax(ix^D,1)=min(cmax(ix^D,1),+invtauc)
          !!  cmin(ix^D,1)=max(cmin(ix^D,1),-invtauc)
          !!endif
       {end do\}
        if(h_correction) then
          {do ix^db=ixomin^db,ixomax^db\}
            cmin(ix^d,1)=sign(one,cmin(ix^d,1))*max(abs(cmin(ix^d,1)),hspeed(ix^d,1))
            cmax(ix^d,1)=sign(one,cmax(ix^d,1))*max(abs(cmax(ix^d,1)),hspeed(ix^d,1))
          {end do\}
        end if
      else
        cmax(ixo^s,1)=abs(wmean(ixo^s,mom(idim)))+csoundr(ixo^s)
        !!if(mhd_radiation_fld.and.fld_bound_diff)then
        !!    invtauc=invtaucL(ix^D)
        !!    cmax(ix^D,1)=min(cmax(ix^D,1),+invtauc)
        !!endif
      end if
    case (3)
      ! Miyoshi 2005 JCP 208, 315 equation (67)
      call mhd_get_csound_prim(wlp,x,ixi^l,ixo^l,idim,csoundl)
      call mhd_get_csound_prim(wrp,x,ixi^l,ixo^l,idim,csoundr)
      !!if(mhd_radiation_fld.and.fld_bound_diff)then
      !!   call fld_get_local_invtauc(wLp,ixI^L,ixO^L,{dxlevel(^D)},x,invtaucL,fld_fl)
      !!   call fld_get_local_invtauc(wRp,ixI^L,ixO^L,{dxlevel(^D)},x,invtaucR,fld_fl)
      !!endif
      if(present(cmin)) then
       {do ix^db=ixomin^db,ixomax^db\}
          csoundl(ix^d)=max(csoundl(ix^d),csoundr(ix^d))
          cmin(ix^d,1)=min(wlp(ix^d,mom(idim)),wrp(ix^d,mom(idim)))-csoundl(ix^d)
          cmax(ix^d,1)=max(wlp(ix^d,mom(idim)),wrp(ix^d,mom(idim)))+csoundl(ix^d)
          !!if(mhd_radiation_fld.and.fld_bound_diff)then
          !!  invtauc=min(invtaucL(ix^D),invtaucR(ix^D))
          !!  cmax(ix^D,1)=min(cmax(ix^D,1),+invtauc)
          !!  cmin(ix^D,1)=max(cmin(ix^D,1),-invtauc)
          !!endif
       {end do\}
        if(h_correction) then
          {do ix^db=ixomin^db,ixomax^db\}
            cmin(ix^d,1)=sign(one,cmin(ix^d,1))*max(abs(cmin(ix^d,1)),hspeed(ix^d,1))
            cmax(ix^d,1)=sign(one,cmax(ix^d,1))*max(abs(cmax(ix^d,1)),hspeed(ix^d,1))
          {end do\}
        end if
      else
       {do ix^db=ixomin^db,ixomax^db\}
          csoundl(ix^d)=max(csoundl(ix^d),csoundr(ix^d))
          cmax(ix^d,1)=max(wlp(ix^d,mom(idim)),wrp(ix^d,mom(idim)))+csoundl(ix^d)
          !!if(mhd_radiation_fld.and.fld_bound_diff)then
          !!  invtauc=min(invtaucL(ix^D),invtaucR(ix^D))
          !!  cmax(ix^D,1)=min(cmax(ix^D,1),+invtauc)
          !!endif
       {end do\}
      end if
    end select
 
  end subroutine mhd_get_cbounds
 
  !> Estimating bounds for the minimum and maximum signal velocities without split
  subroutine mhd_get_cbounds_semirelati(wLC,wRC,wLp,wRp,x,ixI^L,ixO^L,idim,Hspeed,cmax,cmin)
    use mod_global_parameters
 
    integer, intent(in)             :: ixi^l, ixo^l, idim
    double precision, intent(in)    :: wlc(ixi^s, nw), wrc(ixi^s, nw)
    double precision, intent(in)    :: wlp(ixi^s, nw), wrp(ixi^s, nw)
    double precision, intent(in)    :: x(ixi^s,1:ndim)
    double precision, intent(inout) :: cmax(ixi^s,1:number_species)
    double precision, intent(inout), optional :: cmin(ixi^s,1:number_species)
    double precision, intent(in)    :: hspeed(ixi^s,1:number_species)
 
    double precision, dimension(ixO^S) :: csoundl, csoundr, gamma2l, gamma2r
    integer :: ix^d
 
    ! Miyoshi 2005 JCP 208, 315 equation (67)
    if(mhd_energy) then
      call mhd_get_csound_semirelati(wlp,x,ixi^l,ixo^l,idim,csoundl,gamma2l)
      call mhd_get_csound_semirelati(wrp,x,ixi^l,ixo^l,idim,csoundr,gamma2r)
    else
      call mhd_get_csound_semirelati_noe(wlp,x,ixi^l,ixo^l,idim,csoundl,gamma2l)
      call mhd_get_csound_semirelati_noe(wrp,x,ixi^l,ixo^l,idim,csoundr,gamma2r)
    end if
    if(present(cmin)) then
     {do ix^db=ixomin^db,ixomax^db\}
        csoundl(ix^d)=max(csoundl(ix^d),csoundr(ix^d))
        cmin(ix^d,1)=min(gamma2l(ix^d)*wlp(ix^d,mom(idim)),gamma2r(ix^d)*wrp(ix^d,mom(idim)))-csoundl(ix^d)
        cmax(ix^d,1)=max(gamma2l(ix^d)*wlp(ix^d,mom(idim)),gamma2r(ix^d)*wrp(ix^d,mom(idim)))+csoundl(ix^d)
     {end do\}
    else
     {do ix^db=ixomin^db,ixomax^db\}
        csoundl(ix^d)=max(csoundl(ix^d),csoundr(ix^d))
        cmax(ix^d,1)=max(gamma2l(ix^d)*wlp(ix^d,mom(idim)),gamma2r(ix^d)*wrp(ix^d,mom(idim)))+csoundl(ix^d)
     {end do\}
    end if
 
  end subroutine mhd_get_cbounds_semirelati
 
  !> Estimating bounds for the minimum and maximum signal velocities with rho split
  subroutine mhd_get_cbounds_split_rho(wLC,wRC,wLp,wRp,x,ixI^L,ixO^L,idim,Hspeed,cmax,cmin)
    use mod_global_parameters
 
    integer, intent(in)             :: ixi^l, ixo^l, idim
    double precision, intent(in)    :: wlc(ixi^s, nw), wrc(ixi^s, nw)
    double precision, intent(in)    :: wlp(ixi^s, nw), wrp(ixi^s, nw)
    double precision, intent(in)    :: x(ixi^s,1:ndim)
    double precision, intent(inout) :: cmax(ixi^s,1:number_species)
    double precision, intent(inout), optional :: cmin(ixi^s,1:number_species)
    double precision, intent(in)    :: hspeed(ixi^s,1:number_species)
 
    double precision :: wmean(ixi^s,nw), csoundl(ixo^s), csoundr(ixo^s)
    double precision :: umean, dmean, tmp1, tmp2, tmp3
    integer :: ix^d
 
    select case (boundspeed)
    case (1)
      ! This implements formula (10.52) from "Riemann Solvers and Numerical
      ! Methods for Fluid Dynamics" by Toro.
      call mhd_get_csound_prim_split(wlp,x,ixi^l,ixo^l,idim,csoundl)
      call mhd_get_csound_prim_split(wrp,x,ixi^l,ixo^l,idim,csoundr)
      if(present(cmin)) then
       {do ix^db=ixomin^db,ixomax^db\}
          tmp1=sqrt(wlp(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,b0i))
          tmp2=sqrt(wrp(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,b0i))
          tmp3=1.d0/(tmp1+tmp2)
          umean=(wlp(ix^d,mom(idim))*tmp1+wrp(ix^d,mom(idim))*tmp2)*tmp3
          dmean=sqrt((tmp1*csoundl(ix^d)**2+tmp2*csoundr(ix^d)**2)*tmp3+&
           half*tmp1*tmp2*tmp3**2*(wrp(ix^d,mom(idim))-wlp(ix^d,mom(idim)))**2)
          cmin(ix^d,1)=umean-dmean
          cmax(ix^d,1)=umean+dmean
       {end do\}
        if(h_correction) then
          {do ix^db=ixomin^db,ixomax^db\}
            cmin(ix^d,1)=sign(one,cmin(ix^d,1))*max(abs(cmin(ix^d,1)),hspeed(ix^d,1))
            cmax(ix^d,1)=sign(one,cmax(ix^d,1))*max(abs(cmax(ix^d,1)),hspeed(ix^d,1))
          {end do\}
        end if
      else
       {do ix^db=ixomin^db,ixomax^db\}
          tmp1=sqrt(wlp(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,b0i))
          tmp2=sqrt(wrp(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,b0i))
          tmp3=1.d0/(tmp1+tmp2)
          umean=(wlp(ix^d,mom(idim))*tmp1+wrp(ix^d,mom(idim))*tmp2)*tmp3
          dmean=sqrt((tmp1*csoundl(ix^d)**2+tmp2*csoundr(ix^d)**2)*tmp3+&
           half*tmp1*tmp2*tmp3**2*(wrp(ix^d,mom(idim))-wlp(ix^d,mom(idim)))**2)
          cmax(ix^d,1)=abs(umean)+dmean
       {end do\}
      end if
    case (2)
      wmean(ixo^s,1:nwflux)=0.5d0*(wlp(ixo^s,1:nwflux)+wrp(ixo^s,1:nwflux))
      call mhd_get_csound_prim_split(wmean,x,ixi^l,ixo^l,idim,csoundr)
      if(present(cmin)) then
       {do ix^db=ixomin^db,ixomax^db\}
          cmax(ix^d,1)=max(wmean(ix^d,mom(idim))+csoundr(ix^d),zero)
          cmin(ix^d,1)=min(wmean(ix^d,mom(idim))-csoundr(ix^d),zero)
       {end do\}
        if(h_correction) then
          {do ix^db=ixomin^db,ixomax^db\}
            cmin(ix^d,1)=sign(one,cmin(ix^d,1))*max(abs(cmin(ix^d,1)),hspeed(ix^d,1))
            cmax(ix^d,1)=sign(one,cmax(ix^d,1))*max(abs(cmax(ix^d,1)),hspeed(ix^d,1))
          {end do\}
        end if
      else
        cmax(ixo^s,1)=abs(wmean(ixo^s,mom(idim)))+csoundr(ixo^s)
      end if
    case (3)
      ! Miyoshi 2005 JCP 208, 315 equation (67)
      call mhd_get_csound_prim_split(wlp,x,ixi^l,ixo^l,idim,csoundl)
      call mhd_get_csound_prim_split(wrp,x,ixi^l,ixo^l,idim,csoundr)
      if(present(cmin)) then
       {do ix^db=ixomin^db,ixomax^db\}
          csoundl(ix^d)=max(csoundl(ix^d),csoundr(ix^d))
          cmin(ix^d,1)=min(wlp(ix^d,mom(idim)),wrp(ix^d,mom(idim)))-csoundl(ix^d)
          cmax(ix^d,1)=max(wlp(ix^d,mom(idim)),wrp(ix^d,mom(idim)))+csoundl(ix^d)
       {end do\}
        if(h_correction) then
          {do ix^db=ixomin^db,ixomax^db\}
            cmin(ix^d,1)=sign(one,cmin(ix^d,1))*max(abs(cmin(ix^d,1)),hspeed(ix^d,1))
            cmax(ix^d,1)=sign(one,cmax(ix^d,1))*max(abs(cmax(ix^d,1)),hspeed(ix^d,1))
          {end do\}
        end if
      else
       {do ix^db=ixomin^db,ixomax^db\}
          csoundl(ix^d)=max(csoundl(ix^d),csoundr(ix^d))
          cmax(ix^d,1)=max(wlp(ix^d,mom(idim)),wrp(ix^d,mom(idim)))+csoundl(ix^d)
       {end do\}
      end if
    end select
 
  end subroutine mhd_get_cbounds_split_rho
 
  !> prepare velocities for ct methods
  subroutine mhd_get_ct_velocity_average(vcts,wLp,wRp,ixI^L,ixO^L,idim,cmax,cmin)
    use mod_global_parameters
 
    integer, intent(in)             :: ixi^l, ixo^l, idim
    double precision, intent(in)    :: wlp(ixi^s, nw), wrp(ixi^s, nw)
    double precision, intent(in)    :: cmax(ixi^s)
    double precision, intent(in), optional :: cmin(ixi^s)
    type(ct_velocity), intent(inout):: vcts
 
  end subroutine mhd_get_ct_velocity_average
 
  subroutine mhd_get_ct_velocity_contact(vcts,wLp,wRp,ixI^L,ixO^L,idim,cmax,cmin)
    use mod_global_parameters
 
    integer, intent(in)             :: ixi^l, ixo^l, idim
    double precision, intent(in)    :: wlp(ixi^s, nw), wrp(ixi^s, nw)
    double precision, intent(in)    :: cmax(ixi^s)
    double precision, intent(in), optional :: cmin(ixi^s)
    type(ct_velocity), intent(inout):: vcts
 
    if(.not.allocated(vcts%vnorm)) allocate(vcts%vnorm(ixi^s,1:ndim))
    ! get average normal velocity at cell faces
    vcts%vnorm(ixo^s,idim)=0.5d0*(wlp(ixo^s,mom(idim))+wrp(ixo^s,mom(idim)))
 
  end subroutine mhd_get_ct_velocity_contact
 
  subroutine mhd_get_ct_velocity_hll(vcts,wLp,wRp,ixI^L,ixO^L,idim,cmax,cmin)
    use mod_global_parameters
 
    integer, intent(in)             :: ixi^l, ixo^l, idim
    double precision, intent(in)    :: wlp(ixi^s, nw), wrp(ixi^s, nw)
    double precision, intent(in)    :: cmax(ixi^s)
    double precision, intent(in), optional :: cmin(ixi^s)
    type(ct_velocity), intent(inout):: vcts
 
    integer                         :: idime,idimn
 
    if(.not.allocated(vcts%vbarC)) then
      allocate(vcts%vbarC(ixi^s,1:ndir,2),vcts%vbarLC(ixi^s,1:ndir,2),vcts%vbarRC(ixi^s,1:ndir,2))
      allocate(vcts%cbarmin(ixi^s,1:ndim),vcts%cbarmax(ixi^s,1:ndim))
    end if
    ! Store magnitude of characteristics
    if(present(cmin)) then
      vcts%cbarmin(ixo^s,idim)=max(-cmin(ixo^s),zero)
      vcts%cbarmax(ixo^s,idim)=max( cmax(ixo^s),zero)
    else
      vcts%cbarmax(ixo^s,idim)=max( cmax(ixo^s),zero)
      vcts%cbarmin(ixo^s,idim)=vcts%cbarmax(ixo^s,idim)
    end if
 
    idimn=mod(idim,ndir)+1 ! 'Next' direction
    idime=mod(idim+1,ndir)+1 ! Electric field direction
    ! Store velocities
    vcts%vbarLC(ixo^s,idim,1)=wlp(ixo^s,mom(idimn))
    vcts%vbarRC(ixo^s,idim,1)=wrp(ixo^s,mom(idimn))
    vcts%vbarC(ixo^s,idim,1)=(vcts%cbarmax(ixo^s,idim)*vcts%vbarLC(ixo^s,idim,1) &
         +vcts%cbarmin(ixo^s,idim)*vcts%vbarRC(ixo^s,idim,1))&
        /(vcts%cbarmax(ixo^s,idim)+vcts%cbarmin(ixo^s,idim))
 
    vcts%vbarLC(ixo^s,idim,2)=wlp(ixo^s,mom(idime))
    vcts%vbarRC(ixo^s,idim,2)=wrp(ixo^s,mom(idime))
    vcts%vbarC(ixo^s,idim,2)=(vcts%cbarmax(ixo^s,idim)*vcts%vbarLC(ixo^s,idim,2) &
         +vcts%cbarmin(ixo^s,idim)*vcts%vbarRC(ixo^s,idim,2))&
        /(vcts%cbarmax(ixo^s,idim)+vcts%cbarmin(ixo^s,idim))
 
  end subroutine mhd_get_ct_velocity_hll
 
  !> Calculate modified squared sound speed for FLD
  !> NOTE: only for diagnostic purposes, unused subroutine
  subroutine mhd_get_csrad2(w,x,ixI^L,ixO^L,csound)
    use mod_global_parameters
    
    integer, intent(in)          :: ixi^l, ixo^l
    double precision, intent(in) :: w(ixi^s, nw), x(ixi^s,1:ndim)
    double precision, intent(out):: csound(ixi^s)
        
    double precision :: wprim(ixi^s, nw)
 
    wprim(ixi^s,1:nw)=w(ixi^s,1:nw)
    call eos%to_primitive(ixi^l,ixo^l,wprim,x)
    call mhd_get_csrad2_prim(wprim,x,ixi^l,ixo^l,csound)
 
  end subroutine mhd_get_csrad2
 
 
  !> Calculate modified squared fast wave speed for FLD
  !> NOTE: w is primitive on entry here!
  !> NOTE: used in FLD module as phys_get_csrad2
  subroutine mhd_get_csrad2_prim(w,x,ixI^L,ixO^L,csound)
    use mod_global_parameters
 
    integer, intent(in)          :: ixi^l, ixo^l
    double precision, intent(in) :: w(ixi^s, nw), x(ixi^s,1:ndim)
    double precision, intent(out):: csound(ixi^s)
 
    double precision :: inv_rho, b2
    double precision :: prad_tensor(ixi^s, 1:ndim, 1:ndim)
    double precision :: prad_max(ixi^s)
    integer :: ix^d,idim
 
    if(mhd_fld_pradtensor) then
       call mhd_get_pradiation_from_prim(w, x, ixi^l, ixo^l, prad_tensor)
    else
       prad_tensor=zero
       do idim=1,ndim
         prad_tensor(ixo^s,idim,idim)=w(ixo^s,r_e)/3.0d0
       enddo
    endif
 
    if(b0field) then
     {do ix^db=ixomin^db,ixomax^db \}
        inv_rho=1.d0/w(ix^d,rho_)
        prad_max(ix^d) = (4.0d0/3.0d0)*maxval(prad_tensor(ix^d,:,:))
        b2=(^c&(w(ix^d,b^c_)+block%B0(ix^d,^c,b0i))**2+)
        csound(ix^d)=(eos%gamma*w(ix^d,p_)+b2+prad_max(ix^d))*inv_rho
     {end do\}
    else
     {do ix^db=ixomin^db,ixomax^db \}
        inv_rho=1.d0/w(ix^d,rho_)
        prad_max(ix^d) = (4.0d0/3.0d0)*maxval(prad_tensor(ix^d,:,:))
        b2=(^c&w(ix^d,b^c_)**2+)
        csound(ix^d)=(eos%gamma*w(ix^d,p_)+b2+prad_max(ix^d))*inv_rho
     {end do\}
    end if
 
   if(minval(csound(ixo^s))<smalldouble)then
     print *,'issue with squared speed and rad pressure'
     print *,minval(csound(ixo^s))
     print *,minval(prad_max(ixo^s))
     call mpistop("negative squared speed in get_csrad2 for dt")
   endif
    
  end subroutine mhd_get_csrad2_prim
 
  !> Calculate fast magnetosonic wave speed
  subroutine mhd_get_csound_prim(w,x,ixI^L,ixO^L,idim,csound)
    use mod_global_parameters
    use mod_usr_methods, only: usr_set_adiab, usr_set_gamma
    use mod_fld, only: fld_bound_diff
 
    integer, intent(in)          :: ixi^l, ixo^l, idim
    double precision, intent(in) :: w(ixi^s, nw), x(ixi^s,1:ndim)
    double precision, intent(out):: csound(ixo^s)
 
    double precision :: adiabs(ixi^s), gammas(ixi^s)
    double precision :: inv_rho, cfast2, avmincs2, b2, kmax
    double precision :: cs2(ixi^s)
    integer :: ix^d
 
    if(mhd_hall) kmax = dpi/min({dxlevel(^d)},bigdouble)*half
 
    if(.not.mhd_energy) then
      if(associated(usr_set_adiab)) then
         call usr_set_adiab(w,x,ixi^l,ixo^l,adiabs)
      else
         adiabs=mhd_adiab
      end if
      if(associated(usr_set_gamma)) then
         call usr_set_gamma(w,x,ixi^l,ixo^l,gammas)
      else
         gammas=eos%gamma
      end if
    end if
 
    ! Sound speed squared via EoS dispatch (honours LTE+ionE Gamma_1 table).
    if(mhd_energy) then
      call eos%get_csound2(w, x, ixi^l, ixo^l, cs2)
    end if
 
    ! store |B|^2 in v
    if(b0field) then
     {do ix^db=ixomin^db,ixomax^db \}
        inv_rho=1.d0/w(ix^d,rho_)
        if(mhd_energy) then
          csound(ix^d)=cs2(ix^d)
          if(mhd_radiation_fld.and.fld_bound_diff)csound(ix^d)=cs2(ix^d)+4.0d0*w(ix^d,r_e)*inv_rho/9.0d0
        else
          csound(ix^d)=gammas(ix^d)*adiabs(ix^d)*w(ix^d,rho_)**(gammas(ix^d)-1.d0)
        end if
        b2=(^c&(w(ix^d,b^c_)+block%B0(ix^d,^c,b0i))**2+)
        cfast2=b2*inv_rho+csound(ix^d)
        avmincs2=cfast2**2-4.0d0*csound(ix^d)*(w(ix^d,mag(idim))+&
         block%B0(ix^d,idim,b0i))**2*inv_rho
        if(avmincs2<zero) avmincs2=zero
        csound(ix^d)=sqrt(half*(cfast2+sqrt(avmincs2)))
        if(mhd_hall) then
          csound(ix^d)=max(csound(ix^d),mhd_etah*sqrt(b2)*inv_rho*kmax)
        end if
     {end do\}
    else
     {do ix^db=ixomin^db,ixomax^db \}
        inv_rho=1.d0/w(ix^d,rho_)
        if(mhd_energy) then
          csound(ix^d)=cs2(ix^d)
          if(mhd_radiation_fld.and.fld_bound_diff)csound(ix^d)=cs2(ix^d)+4.0d0*w(ix^d,r_e)*inv_rho/9.0d0
        else
          csound(ix^d)=gammas(ix^d)*adiabs(ix^d)*w(ix^d,rho_)**(gammas(ix^d)-1.d0)
        end if
        b2=(^c&w(ix^d,b^c_)**2+)
        cfast2=b2*inv_rho+csound(ix^d)
        avmincs2=cfast2**2-4.0d0*csound(ix^d)*w(ix^d,mag(idim))**2*inv_rho
        if(avmincs2<zero) avmincs2=zero
        csound(ix^d)=sqrt(half*(cfast2+sqrt(avmincs2)))
        if(mhd_hall) then
          csound(ix^d)=max(csound(ix^d),mhd_etah*sqrt(b2)*inv_rho*kmax)
        end if
     {end do\}
    end if
 
  end subroutine mhd_get_csound_prim
 
  !> Calculate fast magnetosonic wave speed when rho and p are split
  !> hence has_equi_rho_and_p=T
  subroutine mhd_get_csound_prim_split(w,x,ixI^L,ixO^L,idim,csound)
    use mod_global_parameters
 
    integer, intent(in)          :: ixi^l, ixo^l, idim
    double precision, intent(in) :: w(ixi^s, nw), x(ixi^s,1:ndim)
    double precision, intent(out):: csound(ixo^s)
 
    double precision :: rho, inv_rho, cfast2, avmincs2, b2, kmax
    integer :: ix^d
 
    if(mhd_hall) kmax = dpi/min({dxlevel(^d)},bigdouble)*half
 
    ! store |B|^2 in v
    if(b0field) then
     {do ix^db=ixomin^db,ixomax^db \}
        rho=(w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,b0i))
        inv_rho=1.d0/rho
        csound(ix^d)=eos%gamma*(w(ix^d,p_)+block%equi_vars(ix^d,equi_pe0_,b0i))*inv_rho
        b2=(^c&(w(ix^d,b^c_)+block%B0(ix^d,^c,b0i))**2+)
        cfast2=b2*inv_rho+csound(ix^d)
        avmincs2=cfast2**2-4.0d0*csound(ix^d)*(w(ix^d,mag(idim))+&
         block%B0(ix^d,idim,b0i))**2*inv_rho
        if(avmincs2<zero) avmincs2=zero
        csound(ix^d)=sqrt(half*(cfast2+sqrt(avmincs2)))
        if(mhd_hall) then
          csound(ix^d)=max(csound(ix^d),mhd_etah*sqrt(b2)*inv_rho*kmax)
        end if
     {end do\}
    else
     {do ix^db=ixomin^db,ixomax^db \}
        rho=(w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,b0i))
        inv_rho=1.d0/rho
        csound(ix^d)=eos%gamma*(w(ix^d,p_)+block%equi_vars(ix^d,equi_pe0_,b0i))*inv_rho
        b2=(^c&w(ix^d,b^c_)**2+)
        cfast2=b2*inv_rho+csound(ix^d)
        avmincs2=cfast2**2-4.0d0*csound(ix^d)*w(ix^d,mag(idim))**2*inv_rho
        if(avmincs2<zero) avmincs2=zero
        csound(ix^d)=sqrt(half*(cfast2+sqrt(avmincs2)))
        if(mhd_hall) then
          csound(ix^d)=max(csound(ix^d),mhd_etah*sqrt(b2)*inv_rho*kmax)
        end if
     {end do\}
    end if
 
  end subroutine mhd_get_csound_prim_split
 
  !> Calculate cmax_idim for semirelativistic MHD
  subroutine mhd_get_csound_semirelati(w,x,ixI^L,ixO^L,idim,csound,gamma2)
    use mod_global_parameters
 
    integer, intent(in)          :: ixi^l, ixo^l, idim
    ! here w is primitive variables
    double precision, intent(in) :: w(ixi^s, nw), x(ixi^s,1:ndim)
    double precision, intent(out):: csound(ixo^s), gamma2(ixo^s)
 
    double precision :: avmincs2, inv_rho, alfven_speed2, idim_alfven_speed2
    integer :: ix^d
 
   {do ix^db=ixomin^db,ixomax^db\}
      inv_rho = 1.d0/w(ix^d,rho_)
      ! squared sound speed
      csound(ix^d)=eos%gamma*w(ix^d,p_)*inv_rho
      alfven_speed2=(^c&w(ix^d,b^c_)**2+)*inv_rho
      gamma2(ix^d) = 1.0d0/(1.d0+alfven_speed2*inv_squared_c)
      avmincs2=1.d0-gamma2(ix^d)*w(ix^d,mom(idim))**2*inv_squared_c
      idim_alfven_speed2=w(ix^d,mag(idim))**2*inv_rho
      ! Va_hat^2+a_hat^2 equation (57)
      ! equation (69)
      alfven_speed2=alfven_speed2*avmincs2+csound(ix^d)*(1.d0+idim_alfven_speed2*inv_squared_c)
      avmincs2=(gamma2(ix^d)*alfven_speed2)**2-4.0d0*gamma2(ix^d)*csound(ix^d)*idim_alfven_speed2*avmincs2
      if(avmincs2<zero) avmincs2=zero
      ! equation (68) fast magnetosonic speed
      csound(ix^d) = sqrt(half*(gamma2(ix^d)*alfven_speed2+sqrt(avmincs2)))
   {end do\}
 
  end subroutine mhd_get_csound_semirelati
 
  !> Calculate cmax_idim for semirelativistic MHD
  subroutine mhd_get_csound_semirelati_noe(w,x,ixI^L,ixO^L,idim,csound,gamma2)
    use mod_global_parameters
    use mod_usr_methods, only: usr_set_adiab, usr_set_gamma
 
    integer, intent(in)          :: ixi^l, ixo^l, idim
    ! here w is primitive variables
    double precision, intent(in) :: w(ixi^s, nw), x(ixi^s,1:ndim)
    double precision, intent(out):: csound(ixo^s), gamma2(ixo^s)
 
    double precision :: adiabs(ixi^s), gammas(ixi^s)
    double precision :: avmincs2, inv_rho, alfven_speed2, idim_alfven_speed2
    integer :: ix^d
 
    if(associated(usr_set_adiab)) then
       call usr_set_adiab(w,x,ixi^l,ixo^l,adiabs)
    else
       adiabs=mhd_adiab
    end if
    if(associated(usr_set_gamma)) then
       call usr_set_gamma(w,x,ixi^l,ixo^l,gammas)
    else
       gammas=eos%gamma
    end if
   {do ix^db=ixomin^db,ixomax^db\}
      inv_rho = 1.d0/w(ix^d,rho_)
      ! squared sound speed
      csound(ix^d)=gammas(ix^d)*adiabs(ix^d)*w(ix^d,rho_)**(gammas(ix^d)-1.d0)
      alfven_speed2=(^c&w(ix^d,b^c_)**2+)*inv_rho
      gamma2(ix^d) = 1.0d0/(1.d0+alfven_speed2*inv_squared_c)
      avmincs2=1.d0-gamma2(ix^d)*w(ix^d,mom(idim))**2*inv_squared_c
      idim_alfven_speed2=w(ix^d,mag(idim))**2*inv_rho
      ! Va_hat^2+a_hat^2 equation (57)
      ! equation (69)
      alfven_speed2=alfven_speed2*avmincs2+csound(ix^d)*(1.d0+idim_alfven_speed2*inv_squared_c)
      avmincs2=(gamma2(ix^d)*alfven_speed2)**2-4.0d0*gamma2(ix^d)*csound(ix^d)*idim_alfven_speed2*avmincs2
      if(avmincs2<zero) avmincs2=zero
      ! equation (68) fast magnetosonic speed
      csound(ix^d) = sqrt(half*(gamma2(ix^d)*alfven_speed2+sqrt(avmincs2)))
   {end do\}
 
  end subroutine mhd_get_csound_semirelati_noe
 
  ! Thermal pressure and temperature subroutines (mhd_get_pthermal_noe,
  ! _inte, _origin, _semirelati, _hde, _LTE, mhd_get_temperature_from_eint,
  ! _from_etot, _from_etot_LTE, _with_equi, _equi, mhd_get_rho_equi,
  ! mhd_get_pe_equi) are defined in mod_mhd_eos.t. eos%get_temperature_from_{etot,eint}
  ! and tc_fl / rc_fl / te_fl_mhd hooks are bound by bind_eos_to_source.
 
 
  !> Calculate radiation pressure within ixO^L
  subroutine mhd_get_pradiation_from_prim(w, x, ixI^L, ixO^L, prad)
    use mod_global_parameters
    use mod_fld
    integer, intent(in)          :: ixi^l, ixo^l
    double precision, intent(in) :: w(ixi^s, 1:nw)
    double precision, intent(in) :: x(ixi^s, 1:ndim)
    double precision, intent(out):: prad(ixi^s, 1:ndim, 1:ndim)
       
    call fld_get_radpress(w, x, ixi^l, ixo^l, prad, fld_fl)
 
  end subroutine mhd_get_pradiation_from_prim
 
  !> Calculates the sum of the gas pressure and the max Prad tensor element
  subroutine mhd_get_pthermal_plus_pradiation(w, x, ixI^L, ixO^L, pth_plus_prad)
    use mod_global_parameters
    integer, intent(in)           :: ixi^l, ixo^l
    double precision, intent(in)  :: w(ixi^s, 1:nw)
    double precision, intent(in)  :: x(ixi^s, 1:ndim)
    double precision, intent(out) :: pth_plus_prad(ixi^s)
 
    double precision              :: wprim(ixi^s, 1:nw)
    double precision              :: prad_tensor(ixi^s, 1:ndim, 1:ndim)
    double precision              :: prad_max(ixi^s)
    integer :: ix^d
        
    wprim(ixi^s,1:nw)=w(ixi^s,1:nw)
    call eos%to_primitive(ixi^l,ixo^l,wprim,x)
    call mhd_get_pradiation_from_prim(wprim, x, ixi^l, ixo^l, prad_tensor)
    {do ix^d = ixomin^d,ixomax^d\}
      prad_max(ix^d) = maxval(prad_tensor(ix^d,:,:))
    {enddo\}
    pth_plus_prad(ixo^s) = wprim(ixo^s,p_) + prad_max(ixo^s)
  end subroutine mhd_get_pthermal_plus_pradiation
 
  !> Calculates radiation temperature 
  subroutine mhd_get_trad(w, x, ixI^L, ixO^L, trad)
    use mod_global_parameters
    use mod_constants
 
    integer, intent(in)          :: ixi^l, ixo^l
    double precision, intent(in) :: w(ixi^s, 1:nw)
    double precision, intent(in) :: x(ixi^s, 1:ndim)
    double precision, intent(out):: trad(ixi^s)
 
    trad(ixi^s) = (w(ixi^s,r_e)/arad_norm)**(1.d0/4.d0)
 
  end subroutine mhd_get_trad
 
  !> Calculate fluxes within ixO^L without any splitting
  subroutine mhd_get_flux(wC,w,x,ixI^L,ixO^L,idim,f)
    use mod_global_parameters
    use mod_geometry
 
    integer, intent(in)          :: ixi^l, ixo^l, idim
    ! conservative w
    double precision, intent(in) :: wc(ixi^s,nw)
    ! primitive w
    double precision, intent(in) :: w(ixi^s,nw)
    double precision, intent(in) :: x(ixi^s,1:ndim)
    double precision,intent(out) :: f(ixi^s,nwflux)
 
    double precision             :: vhall(ixi^s,1:ndir)
    double precision             :: ptotal
    double precision             :: r(ixi^s), te(ixi^s), rho_loc(ixi^s)
    double precision             :: bvec(ixi^s,1:ndir)
    double precision             :: bgradt(ixi^s), gradtperp_mag(ixi^s)
    double precision             :: nperp(ixi^s,1:ndir)
    double precision             :: uawsom_zeta(ixi^s), uawsom_radius(ixi^s)
    double precision             :: uawsom_lperp(ixi^s), uawsom_denom
    double precision             :: uawsom_pwave, uawsom_bi
    logical                      :: use_perp_flux
    integer                      :: iw, ix^d, idir
 
    if(mhd_uawsom) call mhd_uawsom_get_coefficients(w,x,ixi^l,ixo^l,.true.,&
         uawsom_zeta,uawsom_radius,uawsom_lperp)
 
    if(mhd_internal_e) then
     {do ix^db=ixomin^db,ixomax^db\}
        ! Get flux of density
        f(ix^d,rho_)=w(ix^d,mom(idim))*w(ix^d,rho_)
        ! f_i[m_k]=v_i*m_k-b_k*b_i
        ^c&f(ix^d,m^c_)=wc(ix^d,mom(idim))*w(ix^d,m^c_)-w(ix^d,mag(idim))*w(ix^d,b^c_)\
        ! normal one includes total pressure
        f(ix^d,mom(idim))=f(ix^d,mom(idim))+w(ix^d,p_)+half*(^c&w(ix^d,b^c_)**2+)
        ! Get flux of internal energy
        f(ix^d,e_)=w(ix^d,mom(idim))*wc(ix^d,e_)
        ! f_i[b_k]=v_i*b_k-v_k*b_i
        ^c&f(ix^d,b^c_)=w(ix^d,mom(idim))*w(ix^d,b^c_)-w(ix^d,mag(idim))*w(ix^d,m^c_)\
     {end do\}
    else
     {do ix^db=ixomin^db,ixomax^db\}
        ! Get flux of density
        f(ix^d,rho_)=w(ix^d,mom(idim))*w(ix^d,rho_)
        ! f_i[m_k]=v_i*m_k-b_k*b_i
        ^c&f(ix^d,m^c_)=wc(ix^d,mom(idim))*w(ix^d,m^c_)-w(ix^d,mag(idim))*w(ix^d,b^c_)\
        ptotal=w(ix^d,p_)+half*(^c&w(ix^d,b^c_)**2+)
        if(mhd_uawsom) then
          uawsom_pwave=mhd_uawsom_wave_pressure_cell(w(ix^d,:),uawsom_zeta(ix^d))
          ptotal=ptotal+uawsom_pwave
        end if
        ! normal one includes total pressure
        f(ix^d,mom(idim))=f(ix^d,mom(idim))+ptotal
        ! Get flux of total energy
        ! f_i[e]=v_i*e+v_i*ptotal-b_i*(b_k*v_k)
        f(ix^d,e_)=w(ix^d,mom(idim))*(wc(ix^d,e_)+ptotal)&
           -w(ix^d,mag(idim))*(^c&w(ix^d,b^c_)*w(ix^d,m^c_)+)
        if(mhd_uawsom) then
          uawsom_denom=dsqrt(w(ix^d,rho_)*(uawsom_zeta(ix^d)+one)/&
               (two*(one+mhd_uawsom_filling_factor*uawsom_zeta(ix^d)-&
               mhd_uawsom_filling_factor)))
          uawsom_bi=w(ix^d,mag(idim))
          f(ix^d,e_)=f(ix^d,e_)+uawsom_bi*(&
               (w(ix^d,waminus_)-w(ix^d,waplus_))/dsqrt(w(ix^d,rho_))+&
               (w(ix^d,wkminus_)-w(ix^d,wkplus_))/uawsom_denom)
        end if
        ! f_i[b_k]=v_i*b_k-v_k*b_i
        ^c&f(ix^d,b^c_)=w(ix^d,mom(idim))*w(ix^d,b^c_)-w(ix^d,mag(idim))*w(ix^d,m^c_)\
     {end do\}
    end if
    if(mhd_hall) then
      call mhd_getv_hall(w,x,ixi^l,ixo^l,vhall)
     {do ix^db=ixomin^db,ixomax^db\}
        if(total_energy) then
          ! f_i[e]= f_i[e] + vHall_i*(b_k*b_k) - b_i*(vHall_k*b_k)
          f(ix^d,e_)=f(ix^d,e_)+vhall(ix^d,idim)*(^c&w(ix^d,b^c_)**2+)&
               -w(ix^d,mag(idim))*(^c&vhall(ix^d,^c)*w(ix^d,b^c_)+)
        end if
        ! f_i[b_k] = f_i[b_k] + vHall_i*b_k - vHall_k*b_i
        ^c&f(ix^d,b^c_)=f(ix^d,b^c_)+vhall(ix^d,idim)*w(ix^d,b^c_)-vhall(ix^d,^c)*w(ix^d,mag(idim))\
     {end do\}
    end if
 
    if(mhd_glm) then
     {do ix^db=ixomin^db,ixomax^db\}
        f(ix^d,mag(idim))=w(ix^d,psi_)
        !f_i[psi]=Ch^2*b_{i} Eq. 24e and Eq. 38c Dedner et al 2002 JCP, 175, 645
        f(ix^d,psi_) = cmax_global**2*w(ix^d,mag(idim))
     {end do\}
    end if
 
    if(mhd_radiation_fld) then
      {do ix^db=ixomin^db,ixomax^db\}
        f(ix^d,r_e)=w(ix^d,mom(idim))*wc(ix^d,r_e)
      {end do\}
    endif
 
    if (mhd_fip) then
      f(ixo^s,fip_) = w(ixo^s,mom(idim)) * wc(ixo^s,fip_)
    end if
    if(mhd_uawsom) then
     {do ix^db=ixomin^db,ixomax^db\}
      uawsom_denom=dsqrt(w(ix^d,rho_)*(uawsom_zeta(ix^d)+one)/&
           (two*(one+mhd_uawsom_filling_factor*uawsom_zeta(ix^d)-&
           mhd_uawsom_filling_factor)))
      uawsom_bi=w(ix^d,mag(idim))
      f(ix^d,waplus_)=w(ix^d,waplus_)*(w(ix^d,mom(idim))-&
           uawsom_bi/dsqrt(w(ix^d,rho_)))
      f(ix^d,waminus_)=w(ix^d,waminus_)*(w(ix^d,mom(idim))+&
           uawsom_bi/dsqrt(w(ix^d,rho_)))
      f(ix^d,wkplus_)=w(ix^d,wkplus_)*(w(ix^d,mom(idim))-uawsom_bi/uawsom_denom)
      f(ix^d,wkminus_)=w(ix^d,wkminus_)*(w(ix^d,mom(idim))+uawsom_bi/uawsom_denom)
     {end do\}
    end if
    ! Get flux of tracer
    do iw=1,mhd_n_tracer
     {do ix^db=ixomin^db,ixomax^db\}
        f(ix^d,tracer(iw))=w(ix^d,mom(idim))*w(ix^d,tracer(iw))
     {end do\}
    end do
 
    use_perp_flux = mhd_hyperbolic_tc .and. mhd_hyperbolic_tc_use_perp .and. &
                    trim(mhd_hyperbolic_tc_perp_mode)/='off'
    if(use_perp_flux) then
      call mhd_get_rho(w,x,ixi^l,ixi^l,rho_loc)
      call eos%get_Rfactor(w,x,ixi^l,ixi^l,r)
      if(has_equi_rho_and_p) then
        te(ixi^s)=(w(ixi^s,p_)+block%equi_vars(ixi^s,equi_pe0_,b0i)) / &
                  (r(ixi^s)*rho_loc(ixi^s))
      else
        te(ixi^s)=w(ixi^s,p_)/(r(ixi^s)*rho_loc(ixi^s))
      end if
      {do ix^db=ixomin^db,ixomax^db\}
        do idir=1,ndir
          bvec(ix^d,idir)=w(ix^d,mag(idir))
        end do
      {end do\}
      call mhd_get_hyperbolic_tc_geometry(ixi^l,ixo^l,te,bvec,bgradt,gradtperp_mag,nperp)
    end if
 
    if(mhd_hyperbolic_tc) then
     {do ix^db=ixomin^db,ixomax^db\}
        f(ix^d,e_)=f(ix^d,e_)+w(ix^d,qpar_)*w(ix^d,mag(idim))/(dsqrt(^c&w(ix^d,b^c_)**2+)+smalldouble)
        f(ix^d,qpar_)=zero
        if(use_perp_flux) then
          f(ix^d,e_)=f(ix^d,e_)+w(ix^d,qperp_)*nperp(ix^d,idim)
          f(ix^d,qperp_)=zero
        end if
     {end do\}
    end if
  end subroutine mhd_get_flux
 
  !> Calculate fluxes within ixO^L for case without energy equation, hence without splitting
  !> and assuming polytropic closure
  subroutine mhd_get_flux_noe(wC,w,x,ixI^L,ixO^L,idim,f)
    use mod_global_parameters
    use mod_geometry
    use mod_usr_methods, only: usr_set_adiab, usr_set_gamma
 
    integer, intent(in)          :: ixi^l, ixo^l, idim
    ! conservative w
    double precision, intent(in) :: wc(ixi^s,nw)
    ! primitive w
    double precision, intent(in) :: w(ixi^s,nw)
    double precision, intent(in) :: x(ixi^s,1:ndim)
    double precision,intent(out) :: f(ixi^s,nwflux)
 
    double precision             :: vhall(ixi^s,1:ndir)
    double precision             :: adiabs(ixi^s), gammas(ixi^s)
    integer                      :: iw, ix^d
 
    if(associated(usr_set_adiab)) then
       call usr_set_adiab(w,x,ixi^l,ixo^l,adiabs)
    else
       adiabs=mhd_adiab
    end if
    if(associated(usr_set_gamma)) then
       call usr_set_gamma(w,x,ixi^l,ixo^l,gammas)
    else
       gammas=eos%gamma
    end if
   {do ix^db=ixomin^db,ixomax^db\}
      ! Get flux of density
      f(ix^d,rho_)=w(ix^d,mom(idim))*w(ix^d,rho_)
      ! f_i[m_k]=v_i*m_k-b_k*b_i
      ^c&f(ix^d,m^c_)=wc(ix^d,mom(idim))*w(ix^d,m^c_)-w(ix^d,mag(idim))*w(ix^d,b^c_)\
      ! normal one includes total pressure
      f(ix^d,mom(idim))=f(ix^d,mom(idim))+adiabs(ix^d)*w(ix^d,rho_)**gammas(ix^d)+half*(^c&w(ix^d,b^c_)**2+)
      ! f_i[b_k]=v_i*b_k-v_k*b_i
      ^c&f(ix^d,b^c_)=w(ix^d,mom(idim))*w(ix^d,b^c_)-w(ix^d,mag(idim))*w(ix^d,m^c_)\
   {end do\}
    if(mhd_hall) then
      call mhd_getv_hall(w,x,ixi^l,ixo^l,vhall)
     {do ix^db=ixomin^db,ixomax^db\}
        ! f_i[b_k] = f_i[b_k] + vHall_i*b_k - vHall_k*b_i
        ^c&f(ix^d,b^c_)=f(ix^d,b^c_)+vhall(ix^d,idim)*w(ix^d,b^c_)-vhall(ix^d,^c)*w(ix^d,mag(idim))\
     {end do\}
    end if
    if(mhd_glm) then
     {do ix^db=ixomin^db,ixomax^db\}
        f(ix^d,mag(idim))=w(ix^d,psi_)
        !f_i[psi]=Ch^2*b_{i} Eq. 24e and Eq. 38c Dedner et al 2002 JCP, 175, 645
        f(ix^d,psi_) = cmax_global**2*w(ix^d,mag(idim))
     {end do\}
    end if
    if (mhd_fip) then
      f(ixo^s,fip_) = w(ixo^s,mom(idim)) * wc(ixo^s,fip_)
    end if
    ! Get flux of tracer
    do iw=1,mhd_n_tracer
     {do ix^db=ixomin^db,ixomax^db\}
        f(ix^d,tracer(iw))=w(ix^d,mom(idim))*w(ix^d,tracer(iw))
     {end do\}
    end do
  end subroutine mhd_get_flux_noe
 
  !> Calculate fluxes with hydrodynamic energy equation
  subroutine mhd_get_flux_hde(wC,w,x,ixI^L,ixO^L,idim,f)
    use mod_global_parameters
    use mod_geometry
 
    integer, intent(in)          :: ixi^l, ixo^l, idim
    ! conservative w
    double precision, intent(in) :: wc(ixi^s,nw)
    ! primitive w
    double precision, intent(in) :: w(ixi^s,nw)
    double precision, intent(in) :: x(ixi^s,1:ndim)
    double precision,intent(out) :: f(ixi^s,nwflux)
 
    double precision             :: vhall(ixi^s,1:ndir)
    double precision             :: r(ixi^s), te(ixi^s), rho_loc(ixi^s)
    double precision             :: bvec(ixi^s,1:ndir)
    double precision             :: bgradt(ixi^s), gradtperp_mag(ixi^s)
    double precision             :: nperp(ixi^s,1:ndir)
    logical                      :: use_perp_flux
    integer                      :: iw, ix^d, idir
 
    {do ix^db=ixomin^db,ixomax^db\}
      ! Get flux of density
      f(ix^d,rho_)=w(ix^d,mom(idim))*w(ix^d,rho_)
      ! f_i[m_k]=v_i*m_k-b_k*b_i
      ^c&f(ix^d,m^c_)=wc(ix^d,mom(idim))*w(ix^d,m^c_)-w(ix^d,mag(idim))*w(ix^d,b^c_)\
      ! normal one includes total pressure
      f(ix^d,mom(idim))=f(ix^d,mom(idim))+w(ix^d,p_)+half*(^c&w(ix^d,b^c_)**2+)
      ! Get flux of energy
      f(ix^d,e_)=w(ix^d,mom(idim))*(wc(ix^d,e_)+w(ix^d,p_))
      ! f_i[b_k]=v_i*b_k-v_k*b_i
      ^c&f(ix^d,b^c_)=w(ix^d,mom(idim))*w(ix^d,b^c_)-w(ix^d,mag(idim))*w(ix^d,m^c_)\
   {end do\}
    if(mhd_hall) then
      call mhd_getv_hall(w,x,ixi^l,ixo^l,vhall)
     {do ix^db=ixomin^db,ixomax^db\}
        ! f_i[b_k] = f_i[b_k] + vHall_i*b_k - vHall_k*b_i
        ^c&f(ix^d,b^c_)=f(ix^d,b^c_)+vhall(ix^d,idim)*w(ix^d,b^c_)-vhall(ix^d,^c)*w(ix^d,mag(idim))\
     {end do\}
    end if
    if(mhd_glm) then
     {do ix^db=ixomin^db,ixomax^db\}
        f(ix^d,mag(idim))=w(ix^d,psi_)
        !f_i[psi]=Ch^2*b_{i} Eq. 24e and Eq. 38c Dedner et al 2002 JCP, 175, 645
        f(ix^d,psi_) = cmax_global**2*w(ix^d,mag(idim))
     {end do\}
    end if
    if (mhd_fip) then
      f(ixo^s,fip_) = w(ixo^s,mom(idim)) * wc(ixo^s,fip_)
    end if
    ! Get flux of tracer
    do iw=1,mhd_n_tracer
     {do ix^db=ixomin^db,ixomax^db\}
        f(ix^d,tracer(iw))=w(ix^d,mom(idim))*w(ix^d,tracer(iw))
     {end do\}
    end do
    use_perp_flux = mhd_hyperbolic_tc .and. mhd_hyperbolic_tc_use_perp .and. &
                    trim(mhd_hyperbolic_tc_perp_mode)/='off'
    if(use_perp_flux) then
      call mhd_get_rho(w,x,ixi^l,ixi^l,rho_loc)
      call eos%get_Rfactor(w,x,ixi^l,ixi^l,r)
      te(ixi^s)=w(ixi^s,p_)/(r(ixi^s)*rho_loc(ixi^s))
      {do ix^db=ixomin^db,ixomax^db\}
        do idir=1,ndir
          bvec(ix^d,idir)=w(ix^d,mag(idir))
        end do
      {end do\}
      call mhd_get_hyperbolic_tc_geometry(ixi^l,ixo^l,te,bvec,bgradt,gradtperp_mag,nperp)
    end if
    if(mhd_hyperbolic_tc) then
     {do ix^db=ixomin^db,ixomax^db\}
        f(ix^d,e_)=f(ix^d,e_)+w(ix^d,qpar_)*w(ix^d,mag(idim))/(dsqrt(^c&w(ix^d,b^c_)**2+)+smalldouble)
        f(ix^d,qpar_)=zero
        if(use_perp_flux) then
          f(ix^d,e_)=f(ix^d,e_)+w(ix^d,qperp_)*nperp(ix^d,idim)
          f(ix^d,qperp_)=zero
        end if
     {end do\}
    end if
  end subroutine mhd_get_flux_hde
 
  !> Calculate fluxes within ixO^L with possible splitting
  !> this covers four cases: B0field=T and mhd_internal_e=T (where has_equi_rho_and_p=F)
  !>                         B0field=T and has_equi_rho_and_p=F for total_energy=T
  !>                         B0field=F and has_equi_rho_and_p=T for total_energy=T
  !>                         B0field=T and has_equi_rho_and_p=T for total_energy=T
  subroutine mhd_get_flux_split(wC,w,x,ixI^L,ixO^L,idim,f)
    use mod_global_parameters
    use mod_geometry
 
    integer, intent(in)          :: ixi^l, ixo^l, idim
    ! conservative w
    double precision, intent(in) :: wc(ixi^s,nw)
    ! primitive w
    double precision, intent(in) :: w(ixi^s,nw)
    double precision, intent(in) :: x(ixi^s,1:ndim)
    double precision,intent(out) :: f(ixi^s,nwflux)
 
    double precision             :: vhall(ixi^s,1:ndir)
    double precision             :: ptotal, btotal(ixo^s,1:ndir)
    double precision             :: r(ixi^s), te(ixi^s), rho_loc(ixi^s)
    double precision             :: bvec(ixi^s,1:ndir)
    double precision             :: bgradt(ixi^s), gradtperp_mag(ixi^s)
    double precision             :: nperp(ixi^s,1:ndir)
    double precision             :: uawsom_zeta(ixi^s), uawsom_radius(ixi^s)
    double precision             :: uawsom_lperp(ixi^s), uawsom_denom
    double precision             :: uawsom_pwave, uawsom_bi
    logical                      :: use_perp_flux
    integer                      :: iw, ix^d, idir
 
    if(mhd_uawsom) call mhd_uawsom_get_coefficients(w,x,ixi^l,ixo^l,.true.,&
         uawsom_zeta,uawsom_radius,uawsom_lperp)
 
   {do ix^db=ixomin^db,ixomax^db\}
      ! Get flux of density
      if(has_equi_rho_and_p) then
        f(ix^d,rho_)=w(ix^d,mom(idim))*(w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,b0i))
      else
        f(ix^d,rho_)=w(ix^d,mom(idim))*w(ix^d,rho_)
      end if
 
      ptotal=w(ix^d,p_)+half*(^c&w(ix^d,b^c_)**2+)
 
      if(b0field) then
        ^c&btotal(ix^d,^c)=w(ix^d,b^c_)+block%B0(ix^d,^c,idim)\
        ptotal=ptotal+(^c&w(ix^d,b^c_)*block%B0(ix^d,^c,idim)+)
        ! Get flux of momentum and magnetic field
        ! f_i[m_k]=v_i*m_k-b_k*b_i
        ^c&f(ix^d,m^c_)=wc(ix^d,mom(idim))*w(ix^d,m^c_)-&
                          btotal(ix^d,idim)*w(ix^d,b^c_)-w(ix^d,mag(idim))*block%B0(ix^d,^c,idim)\
        f(ix^d,mom(idim))=f(ix^d,mom(idim))+ptotal
      else
        ^c&btotal(ix^d,^c)=w(ix^d,b^c_)\
        ! Get flux of momentum and magnetic field
        ! f_i[m_k]=v_i*m_k-b_k*b_i
        ^c&f(ix^d,m^c_)=wc(ix^d,mom(idim))*w(ix^d,m^c_)-w(ix^d,mag(idim))*w(ix^d,b^c_)\
        f(ix^d,mom(idim))=f(ix^d,mom(idim))+ptotal
      end if
      if(mhd_uawsom) then
        uawsom_pwave=mhd_uawsom_wave_pressure_cell(w(ix^d,:),uawsom_zeta(ix^d))
        f(ix^d,mom(idim))=f(ix^d,mom(idim))+uawsom_pwave
      end if
      ! f_i[b_k]=v_i*b_k-v_k*b_i
      ^c&f(ix^d,b^c_)=w(ix^d,mom(idim))*btotal(ix^d,^c)-btotal(ix^d,idim)*w(ix^d,m^c_)\
 
      ! Get flux of energy
      ! f_i[e]=v_i*e+v_i*ptotal-b_i*(b_k*v_k)
      if(mhd_internal_e) then
        f(ix^d,e_)=w(ix^d,mom(idim))*wc(ix^d,e_)
      else
        f(ix^d,e_)=w(ix^d,mom(idim))*(wc(ix^d,e_)+ptotal)&
           -btotal(ix^d,idim)*(^c&w(ix^d,b^c_)*w(ix^d,m^c_)+)
        if(mhd_uawsom) then
          uawsom_denom=dsqrt(w(ix^d,rho_)*(uawsom_zeta(ix^d)+one)/&
               (two*(one+mhd_uawsom_filling_factor*uawsom_zeta(ix^d)-&
               mhd_uawsom_filling_factor)))
          uawsom_bi=btotal(ix^d,idim)
          f(ix^d,e_)=f(ix^d,e_)+w(ix^d,mom(idim))*uawsom_pwave+uawsom_bi*(&
               (w(ix^d,waminus_)-w(ix^d,waplus_))/dsqrt(w(ix^d,rho_))+&
               (w(ix^d,wkminus_)-w(ix^d,wkplus_))/uawsom_denom)
        end if
      end if
   {end do\}
 
    if(mhd_glm) then
     {do ix^db=ixomin^db,ixomax^db\}
        f(ix^d,mag(idim))=w(ix^d,psi_)
        !f_i[psi]=Ch^2*b_{i} Eq. 24e and Eq. 38c Dedner et al 2002 JCP, 175, 645
        f(ix^d,psi_) = cmax_global**2*w(ix^d,mag(idim))
     {end do\}
    end if
 
    if(mhd_radiation_fld) then
      {do ix^db=ixomin^db,ixomax^db\}
        f(ix^d,r_e)=w(ix^d,mom(idim))*wc(ix^d,r_e)
      {end do\}
    endif
 
    if(mhd_hall) then
      call mhd_getv_hall(w,x,ixi^l,ixo^l,vhall)
     {do ix^db=ixomin^db,ixomax^db\}
        ! f_i[b_k] = f_i[b_k] + vHall_i*b_k - vHall_k*b_i
        ^c&f(ix^d,b^c_)=f(ix^d,b^c_)+vhall(ix^d,idim)*btotal(ix^d,^c)-btotal(ix^d,idim)*vhall(ix^d,^c)\
        if(total_energy) then
          ! f_i[e]= f_i[e] + vHall_i*(b_k*b_k) - b_i*(vHall_k*b_k)
          f(ix^d,e_)=f(ix^d,e_)+vhall(ix^d,idim)*(^c&w(ix^d,b^c_)*btotal(ix^d,^c)+)&
                    -btotal(ix^d,idim)*(^c&vhall(ix^d,^c)*w(ix^d,b^c_)+)
        end if
     {end do\}
    end if
    if (mhd_fip) then
      f(ixo^s,fip_) = w(ixo^s,mom(idim)) * wc(ixo^s,fip_)
    end if
    if(mhd_uawsom) then
     {do ix^db=ixomin^db,ixomax^db\}
      uawsom_denom=dsqrt(w(ix^d,rho_)*(uawsom_zeta(ix^d)+one)/&
           (two*(one+mhd_uawsom_filling_factor*uawsom_zeta(ix^d)-&
           mhd_uawsom_filling_factor)))
      uawsom_bi=btotal(ix^d,idim)
      f(ix^d,waplus_)=w(ix^d,waplus_)*(w(ix^d,mom(idim))-&
           uawsom_bi/dsqrt(w(ix^d,rho_)))
      f(ix^d,waminus_)=w(ix^d,waminus_)*(w(ix^d,mom(idim))+&
           uawsom_bi/dsqrt(w(ix^d,rho_)))
      f(ix^d,wkplus_)=w(ix^d,wkplus_)*(w(ix^d,mom(idim))-uawsom_bi/uawsom_denom)
      f(ix^d,wkminus_)=w(ix^d,wkminus_)*(w(ix^d,mom(idim))+uawsom_bi/uawsom_denom)
     {end do\}
    end if
    ! Get flux of tracer
    do iw=1,mhd_n_tracer
     {do ix^db=ixomin^db,ixomax^db\}
        f(ix^d,tracer(iw))=w(ix^d,mom(idim))*w(ix^d,tracer(iw))
     {end do\}
    end do
    use_perp_flux = mhd_hyperbolic_tc .and. mhd_hyperbolic_tc_use_perp .and. &
                    trim(mhd_hyperbolic_tc_perp_mode)/='off'
    if(use_perp_flux) then
      call mhd_get_rho(w,x,ixi^l,ixi^l,rho_loc)
      call eos%get_Rfactor(w,x,ixi^l,ixi^l,r)
      if(has_equi_rho_and_p) then
        te(ixi^s)=(w(ixi^s,p_)+block%equi_vars(ixi^s,equi_pe0_,b0i)) / &
                  (r(ixi^s)*rho_loc(ixi^s))
      else
        te(ixi^s)=w(ixi^s,p_)/(r(ixi^s)*rho_loc(ixi^s))
      end if
      {do ix^db=ixomin^db,ixomax^db\}
        do idir=1,ndir
          bvec(ix^d,idir)=btotal(ix^d,idir)
        end do
      {end do\}
      call mhd_get_hyperbolic_tc_geometry(ixi^l,ixo^l,te,bvec,bgradt,gradtperp_mag,nperp)
    end if
    if(mhd_hyperbolic_tc) then
     {do ix^db=ixomin^db,ixomax^db\}
        f(ix^d,e_)=f(ix^d,e_)+w(ix^d,qpar_)*btotal(ix^d,idim)/(dsqrt(^c&btotal(ix^d,^c)**2+)+smalldouble)
        f(ix^d,qpar_)=zero
        if(use_perp_flux) then
          f(ix^d,e_)=f(ix^d,e_)+w(ix^d,qperp_)*nperp(ix^d,idim)
          f(ix^d,qperp_)=zero
        end if
     {end do\}
    end if
  end subroutine mhd_get_flux_split
 
  !> Calculate semirelativistic fluxes within ixO^L without any splitting
  subroutine mhd_get_flux_semirelati(wC,w,x,ixI^L,ixO^L,idim,f)
    use mod_global_parameters
    use mod_geometry
 
    integer, intent(in)          :: ixi^l, ixo^l, idim
    ! conservative w
    double precision, intent(in) :: wc(ixi^s,nw)
    ! primitive w
    double precision, intent(in) :: w(ixi^s,nw)
    double precision, intent(in) :: x(ixi^s,1:ndim)
    double precision,intent(out) :: f(ixi^s,nwflux)
    double precision             :: sa(ixo^s,1:ndir),e(ixo^s,1:ndir),e2
    double precision             :: r(ixi^s), te(ixi^s), rho_loc(ixi^s)
    double precision             :: bvec(ixi^s,1:ndir)
    double precision             :: bgradt(ixi^s), gradtperp_mag(ixi^s)
    double precision             :: nperp(ixi^s,1:ndir)
    logical                      :: use_perp_flux
    integer                      :: iw, ix^d, idir
 
   {do ix^db=ixomin^db,ixomax^db\}
      ! Get flux of density
      f(ix^d,rho_)=w(ix^d,mom(idim))*w(ix^d,rho_)
      ! E=Bxv
      {^ifthreec
      e(ix^d,1)=w(ix^d,b2_)*w(ix^d,m3_)-w(ix^d,b3_)*w(ix^d,m2_)
      e(ix^d,2)=w(ix^d,b3_)*w(ix^d,m1_)-w(ix^d,b1_)*w(ix^d,m3_)
      e(ix^d,3)=w(ix^d,b1_)*w(ix^d,m2_)-w(ix^d,b2_)*w(ix^d,m1_)
      }
      {^iftwoc
      e(ix^d,1)=zero
      ! switch 2 and 3 to add 3 when ^C is from 1 to 2
      e(ix^d,2)=w(ix^d,b1_)*w(ix^d,m2_)-w(ix^d,b2_)*w(ix^d,m1_)
      }
      {^ifonec
      e(ix^d,1)=zero
      }
      e2=(^c&e(ix^d,^c)**2+)
      if(mhd_internal_e) then
        ! Get flux of internal energy
        f(ix^d,e_)=w(ix^d,mom(idim))*wc(ix^d,e_)
      else
        ! S=ExB
        {^ifthreec
        sa(ix^d,1)=e(ix^d,2)*w(ix^d,b3_)-e(ix^d,3)*w(ix^d,b2_)
        sa(ix^d,2)=e(ix^d,3)*w(ix^d,b1_)-e(ix^d,1)*w(ix^d,b3_)
        sa(ix^d,3)=e(ix^d,1)*w(ix^d,b2_)-e(ix^d,2)*w(ix^d,b1_)
        }
        {^iftwoc
        sa(ix^d,1)=-e(ix^d,2)*w(ix^d,b2_)
        sa(ix^d,2)=e(ix^d,2)*w(ix^d,b1_)
        ! set E2 back to 0, after e^2 is stored
        e(ix^d,2)=zero
        }
        {^ifonec
        sa(ix^d,1)=zero
        }
        ! Get flux of total energy
        f(ix^d,e_)=w(ix^d,mom(idim))*(half*w(ix^d,rho_)*(^c&w(ix^d,m^c_)**2+)+&
                    eos%gamma*w(ix^d,p_)*eos%inv_gamma_minus_1)+sa(ix^d,idim)
      end if
      ! Get flux of momentum
      ^c&f(ix^d,m^c_)=w(ix^d,rho_)*w(ix^d,mom(idim))*w(ix^d,m^c_)&
       -w(ix^d,mag(idim))*w(ix^d,b^c_)-e(ix^d,idim)*e(ix^d,^c)*inv_squared_c\
      ! gas pressure + magnetic pressure + electric pressure
      f(ix^d,mom(idim))=f(ix^d,mom(idim))+w(ix^d,p_)+half*((^c&w(ix^d,b^c_)**2+)+e2*inv_squared_c)
      ! compute flux of magnetic field
      ! f_i[b_k]=v_i*b_k-v_k*b_i
      ^c&f(ix^d,b^c_)=w(ix^d,mom(idim))*w(ix^d,b^c_)-w(ix^d,mag(idim))*w(ix^d,m^c_)\
   {end do\}
 
    if(mhd_glm) then
     {do ix^db=ixomin^db,ixomax^db\}
        f(ix^d,mag(idim))=w(ix^d,psi_)
        !f_i[psi]=Ch^2*b_{i} Eq. 24e and Eq. 38c Dedner et al 2002 JCP, 175, 645
        f(ix^d,psi_)=cmax_global**2*w(ix^d,mag(idim))
     {end do\}
    end if
    if (mhd_fip) then
      f(ixo^s,fip_) = w(ixo^s,mom(idim)) * wc(ixo^s,fip_)
    end if
    ! Get flux of tracer
    do iw=1,mhd_n_tracer
     {do ix^db=ixomin^db,ixomax^db\}
        f(ix^d,tracer(iw))=w(ix^d,mom(idim))*w(ix^d,tracer(iw))
     {end do\}
    end do
    use_perp_flux = mhd_hyperbolic_tc .and. mhd_hyperbolic_tc_use_perp .and. &
                    trim(mhd_hyperbolic_tc_perp_mode)/='off'
    if(use_perp_flux) then
      call mhd_get_rho(w,x,ixi^l,ixi^l,rho_loc)
      call eos%get_Rfactor(w,x,ixi^l,ixi^l,r)
      te(ixi^s)=w(ixi^s,p_)/(r(ixi^s)*rho_loc(ixi^s))
      {do ix^db=ixomin^db,ixomax^db\}
        do idir=1,ndir
          bvec(ix^d,idir)=w(ix^d,mag(idir))
        end do
      {end do\}
      call mhd_get_hyperbolic_tc_geometry(ixi^l,ixo^l,te,bvec,bgradt,gradtperp_mag,nperp)
    end if
    if(mhd_hyperbolic_tc) then
     {do ix^db=ixomin^db,ixomax^db\}
        f(ix^d,e_)=f(ix^d,e_)+w(ix^d,qpar_)*w(ix^d,mag(idim))/(dsqrt(^c&w(ix^d,b^c_)**2+)+smalldouble)
        f(ix^d,qpar_)=zero
        if(use_perp_flux) then
          f(ix^d,e_)=f(ix^d,e_)+w(ix^d,qperp_)*nperp(ix^d,idim)
          f(ix^d,qperp_)=zero
        end if
     {end do\}
    end if
  end subroutine mhd_get_flux_semirelati
 
  subroutine mhd_get_flux_semirelati_noe(wC,w,x,ixI^L,ixO^L,idim,f)
    use mod_global_parameters
    use mod_geometry
    use mod_usr_methods, only: usr_set_adiab, usr_set_gamma
 
    integer, intent(in)          :: ixi^l, ixo^l, idim
    ! conservative w
    double precision, intent(in) :: wc(ixi^s,nw)
    ! primitive w
    double precision, intent(in) :: w(ixi^s,nw)
    double precision, intent(in) :: x(ixi^s,1:ndim)
    double precision,intent(out) :: f(ixi^s,nwflux)
 
    double precision             :: adiabs(ixi^s), gammas(ixi^s)
    double precision             :: e(ixo^s,1:ndir),e2
    integer                      :: iw, ix^d
 
    if(associated(usr_set_adiab)) then
       call usr_set_adiab(w,x,ixi^l,ixo^l,adiabs)
    else
       adiabs=mhd_adiab
    end if
    if(associated(usr_set_gamma)) then
       call usr_set_gamma(w,x,ixi^l,ixo^l,gammas)
    else
       gammas=eos%gamma
    end if
   {do ix^db=ixomin^db,ixomax^db\}
      ! Get flux of density
      f(ix^d,rho_)=w(ix^d,mom(idim))*w(ix^d,rho_)
      ! E=Bxv
      {^ifthreec
      e(ix^d,1)=w(ix^d,b2_)*w(ix^d,m3_)-w(ix^d,b3_)*w(ix^d,m2_)
      e(ix^d,2)=w(ix^d,b3_)*w(ix^d,m1_)-w(ix^d,b1_)*w(ix^d,m3_)
      e(ix^d,3)=w(ix^d,b1_)*w(ix^d,m2_)-w(ix^d,b2_)*w(ix^d,m1_)
      e2=(^c&e(ix^d,^c)**2+)
      }
      {^iftwoc
      e(ix^d,1)=zero
      ! switch 2 and 3 to add 3 when ^C is from 1 to 2
      e(ix^d,2)=w(ix^d,b1_)*w(ix^d,m2_)-w(ix^d,b2_)*w(ix^d,m1_)
      e2=e(ix^d,2)**2
      e(ix^d,2)=zero
      }
      {^ifonec
      e(ix^d,1)=zero
      e2=zero
      }
      ! Get flux of momentum
      ^c&f(ix^d,m^c_)=w(ix^d,rho_)*w(ix^d,mom(idim))*w(ix^d,m^c_)&
       -w(ix^d,mag(idim))*w(ix^d,b^c_)-e(ix^d,idim)*e(ix^d,^c)*inv_squared_c\
      ! gas pressure + magnetic pressure + electric pressure
      f(ix^d,mom(idim))=f(ix^d,mom(idim))+adiabs(ix^d)*w(ix^d,rho_)**gammas(ix^d)+half*((^c&w(ix^d,b^c_)**2+)+e2*inv_squared_c)
      ! compute flux of magnetic field
      ! f_i[b_k]=v_i*b_k-v_k*b_i
      ^c&f(ix^d,b^c_)=w(ix^d,mom(idim))*w(ix^d,b^c_)-w(ix^d,mag(idim))*w(ix^d,m^c_)\
   {end do\}
 
    if(mhd_glm) then
     {do ix^db=ixomin^db,ixomax^db\}
        f(ix^d,mag(idim))=w(ix^d,psi_)
        !f_i[psi]=Ch^2*b_{i} Eq. 24e and Eq. 38c Dedner et al 2002 JCP, 175, 645
        f(ix^d,psi_)=cmax_global**2*w(ix^d,mag(idim))
     {end do\}
    end if
    if (mhd_fip) then
      f(ixo^s,fip_) = w(ixo^s,mom(idim)) * wc(ixo^s,fip_)
    end if
    ! Get flux of tracer
    do iw=1,mhd_n_tracer
     {do ix^db=ixomin^db,ixomax^db\}
        f(ix^d,tracer(iw))=w(ix^d,mom(idim))*w(ix^d,tracer(iw))
     {end do\}
    end do
  end subroutine mhd_get_flux_semirelati_noe
 
  !> Source term J.E_ambi in internal energy
  !> For the ambipolar electric field we have E_ambi = -eta_A * JxBxB= eta_A * B^2 (J_perpB)
  !> and eta_A is mhd_ambi_coef/rho^2 or is user-defined
  !> the source term J.E_ambi = eta_A * B^2 * J_perpB^2 = eta_A * [(JxB)xB]^2/B^2
  !> note that J_perpB= - (JxB)xB/B^2
  !> multiplyAmbiCoef is actually doing multiplication with -mhd_ambi_coef/rho^2
  subroutine add_source_ambipolar_internal_energy(qdt,ixI^L,ixO^L,wCT,w,x)
    use mod_global_parameters
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(in)    :: qdt
    double precision, intent(in)    :: wct(ixi^s,1:nw), x(ixi^s,1:ndim)
    double precision, intent(inout) :: w(ixi^s,1:nw)
 
    double precision :: tmp(ixi^s),btot2(ixi^s)
    double precision :: jxbxb(ixi^s,1:3)
 
    call mhd_get_jxbxb(wct,x,ixi^l,ixo^l,jxbxb)
    ! avoiding nulls here
    btot2(ixo^s)=mhd_mag_en_all(wct,ixi^l,ixo^l)
    where (btot2(ixo^s)>smalldouble )
       tmp(ixo^s) = sum(jxbxb(ixo^s,1:3)**2,dim=ndim+1) / btot2(ixo^s)
    elsewhere
       tmp(ixo^s) = zero
    endwhere
    call multiplyambicoef(ixi^l,ixo^l,tmp,wct,x)
    ! multiplyAmbiCoef is actually doing multiplication with -mhd_ambi_coef/rho^2
    ! hence minus sign here
    w(ixo^s,e_)=w(ixo^s,e_)- qdt*tmp(ixo^s)
 
  end subroutine add_source_ambipolar_internal_energy
 
  !> this subroutine computes -J_perpB= (J x B) x B= B(J.B) - J B^2
  subroutine mhd_get_jxbxb(w,x,ixI^L,ixO^L,res)
    use mod_global_parameters
 
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(in)    :: w(ixi^s,nw)
    double precision, intent(in)    :: x(ixi^s,1:ndim)
    double precision, intent(out)   :: res(ixi^s,1:3)
 
    double precision :: btot(ixi^s,1:3)
    double precision :: current(ixi^s,7-2*ndir:3)
    double precision :: tmp(ixi^s),b2(ixi^s)
    integer          :: idir, idirmin
 
    res=0.d0
    ! Calculate current density and idirmin
    ! current has nonzero values only for components in the range idirmin, 3
    call get_current(w,ixi^l,ixo^l,idirmin,current)
 
    btot=0.d0
    if(b0field) then
      do idir=1,ndir
        btot(ixo^s, idir) = w(ixo^s,mag(idir)) + block%B0(ixo^s,idir,b0i)
      enddo
    else
      do idir=1,ndir
        btot(ixo^s, idir) = w(ixo^s,mag(idir)) 
      enddo
    endif
 
    tmp(ixo^s)= sum(current(ixo^s,idirmin:3)*btot(ixo^s,idirmin:3),dim=ndim+1) !J.B
    b2(ixo^s) = sum(btot(ixo^s,1:3)**2,dim=ndim+1) !B^2
    do idir=1,idirmin-1
      res(ixo^s,idir) = btot(ixo^s,idir) * tmp(ixo^s)
    enddo
    do idir=idirmin,3
      res(ixo^s,idir) = btot(ixo^s,idir) * tmp(ixo^s) - current(ixo^s,idir) * b2(ixo^s)
    enddo
 
    ! avoid possible issues at nulls
    do idir=1,3
      where (b2(ixo^s)<smalldouble )
       res(ixo^s,idir) = zero
      endwhere
    enddo
  end subroutine mhd_get_jxbxb
 
  !> Sets the sources for the ambipolar terms for the STS method
  !> The sources are added directly (instead of fluxes as in the explicit)
  !> at the corresponding indices
  !> store_flux_var is explicitly called for each of the fluxes one by one
  subroutine sts_set_source_ambipolar(ixI^L,ixO^L,w,x,wres,fix_conserve_at_step,my_dt,igrid,nflux)
    use mod_global_parameters
    use mod_fix_conserve
 
    integer, intent(in) :: ixi^l,ixo^l,igrid,nflux
    double precision, intent(in) ::  x(ixi^s,1:ndim)
    double precision, intent(inout) ::  wres(ixi^s,1:nw), w(ixi^s,1:nw)
    double precision, intent(in) :: my_dt
    logical, intent(in) :: fix_conserve_at_step
 
    double precision, dimension(ixI^S,1:3) :: tmp,ff
    double precision :: fluxall(ixi^s,1:nflux,1:ndim)
    double precision :: fe(ixi^s,sdim:3)
    double precision :: btot(ixi^s,1:3),tmp2(ixi^s)
    integer :: i, ixa^l, ie_
 
    ixa^l=ixo^l^ladd1;
 
    fluxall=zero
 
    ! here we compute (JxB)xB= - B^2 J_perpB
    call mhd_get_jxbxb(w,x,ixi^l,ixa^l,tmp)
 
    ! set ambipolar electric field in tmp: E_ambi = -eta_A * JxBxB= eta_A * B^2 (J_perpB)
    ! and eta_A is mhd_ambi_coef/rho^2 or is user-defined
    ! multiplyAmbiCoef is actually doing multiplication with -mhd_ambi_coef/rho^2
    do i=1,3
      call multiplyambicoef(ixi^l,ixa^l,tmp(ixi^s,i),w,x)
    enddo
 
    ! Note: internal     energy case is handled through add_source_internal_e
    ! Note: hydrodynamic energy case is handled through add_source_hydrodynamic_e
    !       both of the above use     add_source_ambipolar_internal_energy
    ! 
    ! Note: total energy case without B0field split is ok here and adds div(BxE_ambi)
    ! Note: total energy case in semirelativistic variant (hence no B0field split) is ok here
    ! Note: total energy with B0field=T here adds div(B_1xE_ambi) which needs correction in add_source_B0split
    if(mhd_energy .and. .not.(mhd_internal_e.or.mhd_hydrodynamic_e))  then
      btot(ixa^s,1:3)    = 0.d0
      ! HERE: only uses B_1 if split, otherwise this is B
      btot(ixa^s,1:ndir) = w(ixa^s,mag(1:ndir))
      ! compute ff= E_ambi x B (where B can be B_1 if B0field=T)
      call cross_product(ixi^l,ixa^l,tmp,btot,ff)
      ! compute actual cell face fluxes in ff and their divergence in tmp2
      call get_flux_on_cell_face(ixi^l,ixo^l,ff,tmp2)
      if(fix_conserve_at_step) fluxall(ixi^s,1,1:ndim)=ff(ixi^s,1:ndim)
      ! - sign as the source is actually div(BxE_ambi) and we have div(E_ambi x B) in tmp2
      wres(ixo^s,e_)=-tmp2(ixo^s)
    endif
 
    if(stagger_grid) then
      ! always 2D or more (2.5/3D)
      if(ndir>ndim) then
        !!!Bz
        ff(ixa^s,1) = tmp(ixa^s,2)
        ff(ixa^s,2) = -tmp(ixa^s,1)
        ff(ixa^s,3) = 0.d0
        call get_flux_on_cell_face(ixi^l,ixo^l,ff,tmp2)
        if(fix_conserve_at_step) fluxall(ixi^s,1+ndir,1:ndim)=ff(ixi^s,1:ndim)
        wres(ixo^s,mag(ndir))=-tmp2(ixo^s)
      end if
      fe=0.d0
      call update_faces_ambipolar(ixi^l,ixo^l,w,x,tmp,fe,btot)
      ixamax^d=ixomax^d;
      ixamin^d=ixomin^d-1;
      wres(ixa^s,mag(1:ndim))=-btot(ixa^s,1:ndim)
    else
      !write curl(ele) as the divergence
      !m1={0,ele[[3]],-ele[[2]]}
      !m2={-ele[[3]],0,ele[[1]]}
      !m3={ele[[2]],-ele[[1]],0}
 
      {^ifoned
      !!!Bx
      ff(ixa^s,1) = 0.d0
      ff(ixa^s,2) = tmp(ixa^s,3)
      ff(ixa^s,3) = -tmp(ixa^s,2)
      call get_flux_on_cell_face(ixi^l,ixo^l,ff,tmp2)
      if(fix_conserve_at_step) fluxall(ixi^s,2,1:ndim)=ff(ixi^s,1:ndim)
      !flux divergence is a source now
      wres(ixo^s,mag(1))=-tmp2(ixo^s)
      if(ndir==2.or.ndir==3)then
        !!!By
        ff(ixa^s,1) = -tmp(ixa^s,3)
        ff(ixa^s,2) = 0.d0
        ff(ixa^s,3) = tmp(ixa^s,1)
        call get_flux_on_cell_face(ixi^l,ixo^l,ff,tmp2)
        if(fix_conserve_at_step) fluxall(ixi^s,3,1:ndim)=ff(ixi^s,1:ndim)
        wres(ixo^s,mag(2))=-tmp2(ixo^s)
      endif
      }
      {^nooned
      !!!Bx
      ff(ixa^s,1) = 0.d0
      ff(ixa^s,2) = tmp(ixa^s,3)
      ff(ixa^s,3) = -tmp(ixa^s,2)
      call get_flux_on_cell_face(ixi^l,ixo^l,ff,tmp2)
      if(fix_conserve_at_step) fluxall(ixi^s,2,1:ndim)=ff(ixi^s,1:ndim)
      !flux divergence is a source now
      wres(ixo^s,mag(1))=-tmp2(ixo^s)
      !!!By
      ff(ixa^s,1) = -tmp(ixa^s,3)
      ff(ixa^s,2) = 0.d0
      ff(ixa^s,3) = tmp(ixa^s,1)
      call get_flux_on_cell_face(ixi^l,ixo^l,ff,tmp2)
      if(fix_conserve_at_step) fluxall(ixi^s,3,1:ndim)=ff(ixi^s,1:ndim)
      wres(ixo^s,mag(2))=-tmp2(ixo^s)
      }
 
      if(ndir==3) then
        !!!Bz
        ff(ixa^s,1) = tmp(ixa^s,2)
        ff(ixa^s,2) = -tmp(ixa^s,1)
        ff(ixa^s,3) = 0.d0
        call get_flux_on_cell_face(ixi^l,ixo^l,ff,tmp2)
        if(fix_conserve_at_step) fluxall(ixi^s,1+ndir,1:ndim)=ff(ixi^s,1:ndim)
        wres(ixo^s,mag(ndir))=-tmp2(ixo^s)
      end if
 
    end if
 
    if(fix_conserve_at_step) then
      fluxall=my_dt*fluxall
      call store_flux(igrid,fluxall,1,ndim,nflux)
      if(stagger_grid) then
        call store_edge(igrid,ixi^l,my_dt*fe,1,ndim)
      end if
    end if
 
  end subroutine sts_set_source_ambipolar
 
  !> get ambipolar electric field and the integrals around cell faces
  subroutine update_faces_ambipolar(ixI^L,ixO^L,w,x,ECC,fE,circ)
    use mod_global_parameters
 
    integer, intent(in)                :: ixi^l, ixo^l
    double precision, intent(in)       :: w(ixi^s,1:nw)
    double precision, intent(in)       :: x(ixi^s,1:ndim)
    ! amibipolar electric field at cell centers
    double precision, intent(in)       :: ecc(ixi^s,1:3)
    double precision, intent(out)      :: fe(ixi^s,sdim:3)
    double precision, intent(out)      :: circ(ixi^s,1:ndim)
 
    integer                            :: hxc^l,ixc^l,ixa^l
    integer                            :: idim1,idim2,idir,ix^d
 
    fe=zero
    ! calculate ambipolar electric field on cell edges from cell centers
    do idir=sdim,3
      ixcmax^d=ixomax^d;
      ixcmin^d=ixomin^d+kr(idir,^d)-1;
     {do ix^db=0,1\}
        if({ ix^d==1 .and. ^d==idir | .or.}) cycle
        ixamin^d=ixcmin^d+ix^d;
        ixamax^d=ixcmax^d+ix^d;
        fe(ixc^s,idir)=fe(ixc^s,idir)+ecc(ixa^s,idir)
     {end do\}
      fe(ixc^s,idir)=fe(ixc^s,idir)*0.25d0*block%dsC(ixc^s,idir)
    end do
 
    ! Calculate circulation on each face to get value of line integral of
    ! electric field in the positive idir direction.
    ixcmax^d=ixomax^d;
    ixcmin^d=ixomin^d-1;
 
    circ=zero
    do idim1=1,ndim ! Coordinate perpendicular to face
      do idim2=1,ndim
        do idir=sdim,3 ! Direction of line integral
          ! Assemble indices
          hxc^l=ixc^l-kr(idim2,^d);
          ! Add line integrals in direction idir
          circ(ixc^s,idim1)=circ(ixc^s,idim1)&
                           +lvc(idim1,idim2,idir)&
                           *(fe(ixc^s,idir)&
                            -fe(hxc^s,idir))
        end do
      end do
      circ(ixc^s,idim1)=circ(ixc^s,idim1)/block%surfaceC(ixc^s,idim1)
    end do
 
  end subroutine update_faces_ambipolar
 
  !> use cell-center flux vector to get cell-face flux vector
  !> which will be used to add the source term as the divergence of the flux
  !> we return fluxes at all faces as well as the divergence of the flux
  !> Note that for ndir>ndim, we do not modify the input cell center flux
  subroutine get_flux_on_cell_face(ixI^L,ixO^L,ff,src)
    use mod_global_parameters
 
    integer, intent(in) :: ixi^l, ixo^l
    double precision, dimension(ixI^S,1:3), intent(inout) :: ff
    double precision, intent(out) :: src(ixi^s)
 
    double precision :: ffc(ixi^s,1:ndim)
    double precision :: dxinv(ndim)
    integer :: idims, ix^d, ixa^l, ixb^l, ixc^l
 
    ixa^l=ixo^l^ladd1;
    dxinv=1.d0/dxlevel
    ! cell corner flux in ffc
    ! TO BE GENERALIZED FOR NON-UNIFORM NON-CARTESIAN MESH
    if (slab_uniform)then
      ffc=0.d0
      ixcmax^d=ixomax^d; ixcmin^d=ixomin^d-1;
      {do ix^db=0,1\}
        ixbmin^d=ixcmin^d+ix^d;
        ixbmax^d=ixcmax^d+ix^d;
        ffc(ixc^s,1:ndim)=ffc(ixc^s,1:ndim)+ff(ixb^s,1:ndim)
      {end do\}
      ffc(ixc^s,1:ndim)=0.5d0**ndim*ffc(ixc^s,1:ndim)
    else
      call mpistop("to generalize using volume averaging")
    endif
    ! now get flux at cell face from corner fluxes in fcc
    ff(ixi^s,1:ndim)=0.d0
    do idims=1,ndim
      ixb^l=ixo^l-kr(idims,^d);
      ixcmax^d=ixomax^d; ixcmin^d=ixbmin^d;
      {do ix^db=0,1 \}
         if({ ix^d==0 .and. ^d==idims | .or.}) then
           ixbmin^d=ixcmin^d-ix^d;
           ixbmax^d=ixcmax^d-ix^d;
           ff(ixc^s,idims)=ff(ixc^s,idims)+ffc(ixb^s,idims)
         end if
      {end do\}
      ff(ixc^s,idims)=ff(ixc^s,idims)*0.5d0**(ndim-1)
    end do
    src=0.d0
    if(slab_uniform) then
      do idims=1,ndim
        ff(ixa^s,idims)=dxinv(idims)*ff(ixa^s,idims)
        ixb^l=ixo^l-kr(idims,^d);
        src(ixo^s)=src(ixo^s)+ff(ixo^s,idims)-ff(ixb^s,idims)
      end do
    else
      do idims=1,ndim
        ff(ixa^s,idims)=ff(ixa^s,idims)*block%surfaceC(ixa^s,idims)
        ixb^l=ixo^l-kr(idims,^d);
        src(ixo^s)=src(ixo^s)+ff(ixo^s,idims)-ff(ixb^s,idims)
      end do
      src(ixo^s)=src(ixo^s)/block%dvolume(ixo^s)
    end if
  end subroutine get_flux_on_cell_face
 
  !> Calculates the explicit dt for the ambipolar term
  !> This function is used by both explicit scheme and STS method
  function get_ambipolar_dt(w,ixI^L,ixO^L,dx^D,x)  result(dtnew)
    use mod_global_parameters
 
    integer, intent(in) :: ixi^l, ixo^l
    double precision, intent(in) :: dx^d, x(ixi^s,1:ndim)
    double precision, intent(in) :: w(ixi^s,1:nw)
    double precision :: dtnew
 
    double precision              :: coef
    double precision              :: dxarr(ndim)
    double precision              :: tmp(ixi^s)
 
    ^d&dxarr(^d)=dx^d;
    tmp(ixo^s) = mhd_mag_en_all(w, ixi^l, ixo^l)
    call multiplyambicoef(ixi^l,ixo^l,tmp,w,x)
    ! now we have -mhd_eta_ambi B^2 /rho^2 in tmp
    coef = maxval(dabs(tmp(ixo^s)))
    if(coef/=0.d0) then
      coef=1.d0/coef
    else
      coef=bigdouble
    end if
    if(slab_uniform) then
      dtnew=minval(dxarr(1:ndim))**2.0d0*coef
    else
      dtnew=minval(block%ds(ixo^s,1:ndim))**2.0d0*coef
    end if
 
  end function get_ambipolar_dt
 
  !> multiply res by the ambipolar coefficient
  !> The ambipolar coefficient is calculated as -mhd_eta_ambi/rho^2
  !> The user may mask its value in the user file
  !> by implementing usr_mask_ambipolar subroutine
  subroutine multiplyambicoef(ixI^L,ixO^L,res,w,x)
    use mod_global_parameters
    integer, intent(in) :: ixi^l, ixo^l
    double precision, intent(in) :: w(ixi^s,1:nw), x(ixi^s,1:ndim)
    double precision, intent(inout) :: res(ixi^s)
    double precision :: tmp(ixi^s)
    double precision :: rho(ixi^s)
 
    call mhd_get_rho(w,x,ixi^l,ixi^l,rho)
    tmp(ixi^s)=-mhd_eta_ambi/rho(ixi^s)**2
    if (associated(usr_mask_ambipolar)) then
      call usr_mask_ambipolar(ixi^l,ixo^l,w,x,tmp)
    end if
    res(ixo^s) = tmp(ixo^s) * res(ixo^s)
 
  end subroutine multiplyambicoef
 
  !> w[iws]=w[iws]+qdt*S[iws,wCT] where S is the source based on wCT within ixO
  subroutine mhd_add_source(qdt,dtfactor,ixI^L,ixO^L,wCT,wCTprim,w,x,qsourcesplit,active)
    use mod_global_parameters
    use mod_timing, only: time_htc_total, time_htc0
    use mod_radiative_cooling, only: radiative_cooling_add_source
    use mod_viscosity, only: viscosity_add_source
    use mod_gravity, only: gravity_add_source
    use mod_cak_force, only: cak_add_source
 
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(in)    :: qdt,dtfactor
    double precision, intent(in)    :: wct(ixi^s,1:nw),wctprim(ixi^s,1:nw), x(ixi^s,1:ndim)
    double precision, intent(inout) :: w(ixi^s,1:nw)
    logical, intent(in)             :: qsourcesplit
    logical, intent(inout)            :: active
 
    !TODO local_timestep support is only added for splitting
    ! but not for other nonideal terms such gravity, RC, viscosity,..
    ! it will also only work for divbfix  'linde', which does not require
    ! modification as it does not use dt in the update
 
    if (.not. qsourcesplit) then
      if(mhd_uawsom) then
        active = .true.
        call mhd_add_source_uawsom(qdt,ixi^l,ixo^l,wct,wctprim,w,x)
      end if
      if(mhd_internal_e) then
        ! Source for solving internal energy
        active = .true.
        call add_source_internal_e(qdt,ixi^l,ixo^l,wct,w,x,wctprim)
      else
        if(has_equi_rho_and_p) then
          active = .true.
          call add_equi_terms(qdt,dtfactor,ixi^l,ixo^l,wct,w,x,wctprim)
        end if
      end if
 
      if(mhd_hyperbolic_tc) then
        active = .true.
        call add_hyperbolic_tc_source(qdt,ixi^l,ixo^l,wct,w,x,wctprim)
      end if
 
      ! Source for B0 splitting
      if (b0field) then
        active = .true.
        ! this adds source to momentum of type J0 x B0 and to energy equation
        ! latter always + J0 * E (electric field being E_ideal, E_hall, E_ambi)
        ! used for total energy variants
        call add_source_b0split(qdt,dtfactor,ixi^l,ixo^l,wct,w,x,wctprim)
      end if
 
      ! Sources for resistivity in eqs. for e, B1, B2 and B3
      if (abs(mhd_eta)>smalldouble)then
        active = .true.
        call add_source_res_exp(qdt,ixi^l,ixo^l,wct,w,x)
      end if
 
      if (mhd_ambipolar_exp)then
        active = .true.
        call add_source_ambi_exp(qdt,ixi^l,ixo^l,wct,w,x)
      end if
 
      if (mhd_eta_hyper>0.d0)then
        active = .true.
        call add_source_hyperres(qdt,ixi^l,ixo^l,wct,w,x)
      end if
 
      if(mhd_hydrodynamic_e) then
        ! Source for solving hydrodynamic energy
        active = .true.
        call add_source_hydrodynamic_e(qdt,ixi^l,ixo^l,wct,w,x,wctprim)
      else if (mhd_semirelativistic) then
        ! add sources for semirelativistic MHD
        active = .true.
        call add_source_semirelativistic(qdt,ixi^l,ixo^l,wct,w,x,wctprim)
      end if
    end if
 
    {^nooned
    if(source_split_divb .eqv. qsourcesplit) then
      ! Sources related to div B
      select case (type_divb)
      case (divb_ct)
        continue ! Do nothing
      case (divb_linde)
        active = .true.
        call add_source_linde(qdt,ixi^l,ixo^l,wct,w,x)
      case (divb_glm)
        active = .true.
        call add_source_glm(qdt,ixi^l,ixo^l,wct,w,x)
      case (divb_powel)
        active = .true.
        call add_source_powel(qdt,ixi^l,ixo^l,wctprim,w,x)
      case (divb_janhunen)
        active = .true.
        call add_source_janhunen(qdt,ixi^l,ixo^l,wctprim,w,x)
      case (divb_lindejanhunen)
        active = .true.
        call add_source_linde(qdt,ixi^l,ixo^l,wct,w,x)
        call add_source_janhunen(qdt,ixi^l,ixo^l,wctprim,w,x)
      case (divb_lindepowel)
        active = .true.
        call add_source_linde(qdt,ixi^l,ixo^l,wct,w,x)
        call add_source_powel(qdt,ixi^l,ixo^l,wctprim,w,x)
      case (divb_lindeglm)
        active = .true.
        call add_source_linde(qdt,ixi^l,ixo^l,wct,w,x)
        call add_source_glm(qdt,ixi^l,ixo^l,wct,w,x)
      case (divb_multigrid)
        continue ! Do nothing
      case (divb_none)
        ! Do nothing
      case default
        call mpistop('Unknown divB fix')
      end select
    end if
    }
 
    if(mhd_radiative_cooling) then
      call radiative_cooling_add_source(qdt,ixi^l,ixo^l,wct,wctprim,&
           w,x,qsourcesplit,active, rc_fl)
    end if
 
    if(mhd_viscosity) then
      call viscosity_add_source(qdt,ixi^l,ixo^l,wct,wctprim,&
           w,x,mhd_energy,qsourcesplit,active)
    end if
 
    if(mhd_gravity) then
      call gravity_add_source(qdt,ixi^l,ixo^l,wct,wctprim,&
           w,x,gravity_energy,qsourcesplit,active)
    end if
 
    if (mhd_cak_force) then
      call cak_add_source(qdt,ixi^l,ixo^l,wct,w,x,mhd_energy,qsourcesplit,active)
    end if
 
    ! This is where the radiation force and heating/cooling are added
    if (mhd_radiation_fld) then
       call mhd_add_radiation_source(qdt,ixi^l,ixo^l,wct,wctprim,w,x,qsourcesplit,active)
    endif
 
    ! update temperature from new pressure, density, and old ionization degree
    if(eos%eos_type == 'PI') then
      if(.not.qsourcesplit) then
        active = .true.
        call eos%update_eos(ixi^l,ixo^l,w,x)
      end if
    end if
 
  end subroutine mhd_add_source
 
  subroutine mhd_add_radiation_source(qdt,ixI^L,ixO^L,wCT,wCTprim,w,x,qsourcesplit,active)
    use mod_constants
    use mod_global_parameters
    use mod_usr_methods
    use mod_fld
 
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(in)    :: qdt, x(ixi^s,1:ndim)
    double precision, intent(in)    :: wct(ixi^s,1:nw),wctprim(ixi^s,1:nw)
    double precision, intent(inout) :: w(ixi^s,1:nw)
    logical, intent(in) :: qsourcesplit
    logical, intent(inout) :: active
 
    ! add radiation force and work done by it, changes momentum and gas energy
    ! handle photon tiring, heating and cooling exchange between gas and radiation field
    call add_fld_rad_force(qdt,ixi^l,ixo^l,wct,wctprim,w,x,qsourcesplit,active,fld_fl)
 
  end subroutine mhd_add_radiation_source
 
  !> add some source terms to total energy related to has_equi_rho_and_p=T
  subroutine add_equi_terms(qdt,dtfactor,ixI^L,ixO^L,wCT,w,x,wCTprim)
    use mod_global_parameters
    use mod_geometry
    use mod_usr_methods
 
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(in)    :: qdt,dtfactor
    double precision, intent(in)    :: wct(ixi^s,1:nw), x(ixi^s,1:ndim)
    double precision, intent(in)    :: wctprim(ixi^s,1:nw)
    double precision, intent(inout) :: w(ixi^s,1:nw)
 
    double precision                :: divv(ixi^s)
    double precision :: a(ixi^s,3), b(ixi^s,3), axb(ixi^s,3)
    double precision :: gravity_field(ixi^s,1:ndim)
    integer :: idir
 
    if(slab_uniform) then
      if(nghostcells .gt. 2) then
        call divvector(wctprim(ixi^s,mom(1:ndir)),ixi^l,ixo^l,divv,3)
      else
        call divvector(wctprim(ixi^s,mom(1:ndir)),ixi^l,ixo^l,divv,2)
      end if
    else
     call divvector(wctprim(ixi^s,mom(1:ndir)),ixi^l,ixo^l,divv)
    end if
    divv(ixo^s)=divv(ixo^s)*eos%gamma*eos%inv_gamma_minus_1
    if(local_timestep) then
      w(ixo^s,e_)=w(ixo^s,e_)-dtfactor*block%dt(ixo^s)*block%equi_vars(ixo^s,equi_pe0_,0)*divv(ixo^s)
    else
      w(ixo^s,e_)=w(ixo^s,e_)-qdt*block%equi_vars(ixo^s,equi_pe0_,0)*divv(ixo^s)
    end if
    if(b0field)then
      if(b0field_forcefree.and.mhd_gravity)then
        ! add -v dot(rho_0 g)/(gamma-1)
        call usr_gravity(ixi^l,ixo^l,wct,x,gravity_field)
        do idir=1,ndim
           w(ixo^s,e_)=w(ixo^s,e_)-qdt*wctprim(ixo^s,mom(idir))*block%equi_vars(ixo^s,equi_rho0_,0)*gravity_field(ixo^s,idir)*eos%inv_gamma_minus_1
        enddo
      else
        a=0.d0
        b=0.d0
        ! store B0 magnetic field in b
        b(ixo^s,1:ndir)=block%B0(ixo^s,1:ndir,0)
        ! store J0 current in a
        do idir=7-2*ndir,3
          a(ixo^s,idir)=block%J0(ixo^s,idir)
        end do
        call cross_product(ixi^l,ixo^l,a,b,axb)
        ! add -v dot(rho_0 g + J0 x B_0)/(gamma-1)
        do idir=1,ndir
           w(ixo^s,e_)=w(ixo^s,e_)-qdt*wctprim(ixo^s,mom(idir))*axb(ixo^s,idir)*eos%inv_gamma_minus_1
        enddo
        if(mhd_gravity)then
          ! add -v dot(rho_0 g)/(gamma-1)
          call usr_gravity(ixi^l,ixo^l,wct,x,gravity_field)
          do idir=1,ndim
           w(ixo^s,e_)=w(ixo^s,e_)-qdt*wctprim(ixo^s,mom(idir))*block%equi_vars(ixo^s,equi_rho0_,0)*gravity_field(ixo^s,idir)*eos%inv_gamma_minus_1
          enddo
        endif
      endif
    else
      if(mhd_gravity)then
        ! add -v dot(rho_0 g)/(gamma-1)
        call usr_gravity(ixi^l,ixo^l,wct,x,gravity_field)
        do idir=1,ndim
         w(ixo^s,e_)=w(ixo^s,e_)-qdt*wctprim(ixo^s,mom(idir))*block%equi_vars(ixo^s,equi_rho0_,0)*gravity_field(ixo^s,idir)*eos%inv_gamma_minus_1
        enddo
      endif
    endif
  end subroutine add_equi_terms
 
  subroutine mhd_get_hyperbolic_tc_geometry(ixI^L,ixO^L,Te,Bvec,bgradT,gradTperp_mag,nperp)
    use mod_global_parameters
    use mod_geometry, only: gradient
    integer, intent(in) :: ixi^l,ixo^l
    double precision, intent(in) :: te(ixi^s)
    double precision, intent(in) :: bvec(ixi^s,1:ndir)
    double precision, intent(out) :: bgradt(ixi^s), gradtperp_mag(ixi^s)
    double precision, intent(out) :: nperp(ixi^s,1:ndir)
 
    double precision :: bmag, bunitvec(ndir), gradt(ndir), gradt_perp(ndir)
    double precision :: gradt_cell(ixi^s,1:ndir)
    integer :: ix^d, idir
 
    gradt_cell=zero
    if(.not. slab_uniform) then
      do idir=1,ndim
        call gradient(te,ixi^l,ixo^l,idir,gradt_cell(ixi^s,idir))
      end do
    end if
 
   {^iftwod
    do ix2=ixomin2,ixomax2
      do ix1=ixomin1,ixomax1
        bmag=zero
        do idir=1,ndir
          bmag=bmag+bvec(ix^d,idir)**2
        end do
        bmag=dsqrt(bmag)
 
        if(bmag>smalldouble) then
          do idir=1,ndir
            bunitvec(idir)=bvec(ix^d,idir)/bmag
          end do
        else
          do idir=1,ndir
            bunitvec(idir)=zero
          end do
        end if
        if(slab_uniform) then
          gradt(1)=((8.d0*(te(ix1+1,ix2)-te(ix1-1,ix2))-te(ix1+2,ix2)+te(ix1-2,ix2))/12.d0)/block%ds(ix^d,1)
          gradt(2)=((8.d0*(te(ix1,ix2+1)-te(ix1,ix2-1))-te(ix1,ix2+2)+te(ix1,ix2-2))/12.d0)/block%ds(ix^d,2)
          if(ndir>2) gradt(3)=zero
        else
          do idir=1,ndir
            gradt(idir)=gradt_cell(ix^d,idir)
          end do
        end if
 
        bgradt(ix^d)=zero
        do idir=1,ndir
          bgradt(ix^d)=bgradt(ix^d)+bunitvec(idir)*gradt(idir)
        end do
 
        do idir=1,ndir
          gradt_perp(idir)=gradt(idir)-bgradt(ix^d)*bunitvec(idir)
        end do
 
        gradtperp_mag(ix^d)=zero
        do idir=1,ndir
          gradtperp_mag(ix^d)=gradtperp_mag(ix^d)+gradt_perp(idir)**2
        end do
        gradtperp_mag(ix^d)=dsqrt(gradtperp_mag(ix^d))
 
        if(gradtperp_mag(ix^d)>smalldouble) then
          do idir=1,ndir
            nperp(ix^d,idir)=gradt_perp(idir)/gradtperp_mag(ix^d)
          end do
        else
          gradtperp_mag(ix^d)=zero
          do idir=1,ndir
            nperp(ix^d,idir)=zero
          end do
        end if
      end do
    end do
   }
   {^ifthreed
    do ix3=ixomin3,ixomax3
      do ix2=ixomin2,ixomax2
        do ix1=ixomin1,ixomax1
          bmag=dsqrt(bvec(ix^d,1)**2+bvec(ix^d,2)**2+bvec(ix^d,3)**2)
          if(bmag>smalldouble) then
            bunitvec(1)=bvec(ix^d,1)/bmag
            bunitvec(2)=bvec(ix^d,2)/bmag
            bunitvec(3)=bvec(ix^d,3)/bmag
          else
            bunitvec(1)=zero
            bunitvec(2)=zero
            bunitvec(3)=zero
          end if
 
          if(slab_uniform) then
            gradt(1)=((8.d0*(te(ix1+1,ix2,ix3)-te(ix1-1,ix2,ix3))-te(ix1+2,ix2,ix3)+te(ix1-2,ix2,ix3))/12.d0)/block%ds(ix^d,1)
            gradt(2)=((8.d0*(te(ix1,ix2+1,ix3)-te(ix1,ix2-1,ix3))-te(ix1,ix2+2,ix3)+te(ix1,ix2-2,ix3))/12.d0)/block%ds(ix^d,2)
            gradt(3)=((8.d0*(te(ix1,ix2,ix3+1)-te(ix1,ix2,ix3-1))-te(ix1,ix2,ix3+2)+te(ix1,ix2,ix3-2))/12.d0)/block%ds(ix^d,3)
          else
            do idir=1,ndir
              gradt(idir)=gradt_cell(ix^d,idir)
            end do
          end if
 
          bgradt(ix^d)=zero
          do idir=1,ndir
            bgradt(ix^d)=bgradt(ix^d)+bunitvec(idir)*gradt(idir)
          end do
 
          do idir=1,ndir
            gradt_perp(idir)=gradt(idir)-bgradt(ix^d)*bunitvec(idir)
          end do
 
          gradtperp_mag(ix^d)=dsqrt(gradt_perp(1)**2+gradt_perp(2)**2+gradt_perp(3)**2)
          if(gradtperp_mag(ix^d)>smalldouble) then
            do idir=1,ndir
              nperp(ix^d,idir)=gradt_perp(idir)/gradtperp_mag(ix^d)
            end do
          else
            gradtperp_mag(ix^d)=zero
            do idir=1,ndir
              nperp(ix^d,idir)=zero
            end do
          end if
        end do
      end do
    end do
    }
  end subroutine mhd_get_hyperbolic_tc_geometry
 
  subroutine add_hyperbolic_tc_source(qdt,ixI^L,ixO^L,wCT,w,x,wCTprim)
    use mod_global_parameters
    use mod_geometry, only: gradient
    integer, intent(in) :: ixi^l,ixo^l
    double precision, intent(in) :: qdt
    double precision, dimension(ixI^S,1:ndim), intent(in) :: x
    double precision, dimension(ixI^S,1:nw), intent(in) :: wct,wctprim
    double precision, dimension(ixI^S,1:nw), intent(inout) :: w
 
    double precision, dimension(ixI^S) :: r,te,rho_loc,pth_loc
    double precision, dimension(ixI^S) :: ne_loc,nh_dummy
    double precision, dimension(ixI^S,1:ndir) :: bvec
    double precision, dimension(ixI^S) :: bgradt, gradtperp_mag
    double precision, dimension(ixI^S,1:ndir) :: nperp
    double precision, dimension(ixI^S) :: gradt_geom
    double precision, parameter :: xe_prefac_cgs = 4.753567596681522d6
    double precision :: kappa_t5,kappa_t5_perp,kappa_t5_perp_eff
    double precision :: kappa_t7,f_sat,kappat5_bgradt,kappat5_gradtperp,tau,b2,fb,gradt1
    double precision :: qclass_diss
    double precision :: bmag_loc,tloc,tcond,nloc_code,cchi,chi
    double precision :: cmax(ndim),c2,cfast2,avmincs2(ndim),inv_rho
    logical :: use_perp_source
    integer :: ix^d,idir
 
    ! xe_prefac_cgs expects B [G], T [K], and ne [cm^-3]. Convert the
    ! normalisation units explicitly in SI mode, while retaining code-unit
    ! state variables in the cell loop below.
    cchi=zero
    if(trim(mhd_hyperbolic_tc_perp_mode)=='electron_magnetization') then
      if(si_unit) then
        cchi = (xe_prefac_cgs/mhd_hyperbolic_tc_coulomb_log) * &
               (1.d4*unit_magneticfield)*unit_temperature**1.5d0 / &
               (1.d-6*unit_numberdensity)
      else
        cchi = (xe_prefac_cgs/mhd_hyperbolic_tc_coulomb_log) * &
               unit_magneticfield*unit_temperature**1.5d0/unit_numberdensity
      end if
    end if
    call eos%get_Rfactor(wct,x,ixi^l,ixi^l,r)
    {do ix^db=iximin^db,iximax^db\}
      if(has_equi_rho_and_p) then
        rho_loc(ix^d)=wctprim(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,0)
        pth_loc(ix^d)=wctprim(ix^d,p_)+block%equi_vars(ix^d,equi_pe0_,0)
      else
        rho_loc(ix^d)=wctprim(ix^d,rho_)
        pth_loc(ix^d)=wctprim(ix^d,p_)
      end if
      te(ix^d)=pth_loc(ix^d)/(r(ix^d)*rho_loc(ix^d))
    {end do\}
    ! Electron number density in code units. Under the FI/PI normalisation,
    ! rho_code equals nH_code. FI uses the composition-dependent fully ionised
    ! electron count. PI obtains the local electron count from its R factor:
    ! R*(2+3 A_He) = (n_nuclei+n_e)/n_H. LTE stores ne explicitly.
    if(trim(mhd_hyperbolic_tc_perp_mode)=='electron_magnetization') then
      if(eos%eos_type=='LTE') then
        call eos%get_ne_nH(ixi^l,ixi^l,wct, x,ne_loc,nh_dummy)
      else if(eos%eos_type=='PI') then
        ne_loc(ixi^s)=rho_loc(ixi^s)*max(r(ixi^s)*(2.d0+3.d0*eos%He_abundance) &
             -(1.d0+eos%He_abundance),smalldouble)
      else
        ne_loc(ixi^s)=rho_loc(ixi^s)*(1.d0+2.d0*eos%He_abundance)
      end if
    end if
    use_perp_source = mhd_hyperbolic_tc_use_perp .and. &
                      trim(mhd_hyperbolic_tc_perp_mode)/='off'
    if(b0field) then
      {do ix^db=ixomin^db,ixomax^db\}
        do idir=1,ndir
          bvec(ix^d,idir)=wct(ix^d,mag(idir))+block%B0(ix^d,idir,0)
        end do
      {end do\}
    else
      {do ix^db=ixomin^db,ixomax^db\}
        do idir=1,ndir
          bvec(ix^d,idir)=wct(ix^d,mag(idir))
        end do
      {end do\}
    end if
   {^nooned
    call mhd_get_hyperbolic_tc_geometry(ixi^l,ixo^l,te,bvec,bgradt,gradtperp_mag,nperp)
   }
   {^ifoned
    gradt_geom=zero
    if(.not.slab_uniform) then
      call gradient(te,ixi^l,ixo^l,1,gradt_geom)
    end if
    do ix1=ixomin1,ixomax1
      if(mhd_hyperbolic_tc_constant) then
        kappa_t5=mhd_hyperbolic_tc_kappa
        kappa_t7=kappa_t5*te(ix1)
      else
        tcond = te(ix1)
        if(mhd_trac) then
          tcond = max(tcond, block%wextra(ix1,tcoff_))
        end if
        kappa_t5=mhd_hyperbolic_tc_kappa*sqrt(tcond**5)
        kappa_t7=kappa_t5*tcond
      end if
      if(slab_uniform) then
        gradt1=((8.d0*(te(ix1+1)-te(ix1-1))-te(ix1+2)+te(ix1-2))/12.d0)/block%ds(ix1,1)
      else
        gradt1=gradt_geom(ix1)
      end if
      b2=zero
      do idir=1,ndir
        b2=b2+bvec(ix1,idir)**2
      end do
      if(b2>smalldouble**2) then
        bgradt(ix1)=bvec(ix1,1)*gradt1/dsqrt(b2)
      else
        bgradt(ix1)=zero
      end if
      kappat5_bgradt=kappa_t5*bgradt(ix1)
      inv_rho=1.d0/rho_loc(ix1)
      c2=eos%gamma*pth_loc(ix1)*inv_rho
      cfast2 = b2*inv_rho + c2
      avmincs2(1) = cfast2**2 - 4.0d0*c2*bvec(ix1,1)**2*inv_rho
      cmax(1) = sqrt(half*(cfast2 + sqrt(dabs(avmincs2(1)))))
      if(mhd_hyperbolic_tc_sat) then
        f_sat=one/(one+dabs(kappat5_bgradt)/(1.5d0*rho_loc(ix^d)*(pth_loc(ix^d)/rho_loc(ix^d))**1.5d0))
        tau=max(4.d0*dt, f_sat*kappa_t7*courantpar**2/(pth_loc(ix^d)*eos%inv_gamma_minus_1*cmax(1)**2))
        w(ix^d,qpar_)=w(ix^d,qpar_)-qdt*(f_sat*kappat5_bgradt+wct(ix^d,qpar_))/tau
      else
        w(ix^d,qpar_)=w(ix^d,qpar_)-qdt*(kappat5_bgradt+wct(ix^d,qpar_))/&
         max(4.d0*dt, kappa_t7*courantpar**2/(pth_loc(ix^d)*eos%inv_gamma_minus_1*cmax(1)**2))
      end if
    end do
   }
   {^iftwod
    do ix2=ixomin2,ixomax2
      do ix1=ixomin1,ixomax1
        if(mhd_hyperbolic_tc_constant) then
          kappa_t5=mhd_hyperbolic_tc_kappa
          kappa_t7=kappa_t5*te(ix^d)
        else
          tcond=te(ix^d)
          if(mhd_trac) then
            tcond=max(tcond, block%wextra(ix^d,tcoff_))
          end if
          kappa_t5=mhd_hyperbolic_tc_kappa*sqrt(tcond**5)
          kappa_t7 = kappa_t5*tcond
        end if
        kappat5_bgradt=kappa_t5*bgradt(ix^d)
        b2 = zero
        do idir = 1, ndir
          b2 = b2 + bvec(ix^d,idir)**2
        end do
        if(use_perp_source) then
          select case(trim(mhd_hyperbolic_tc_perp_mode))
          case('fixed_reference')
            kappa_t5_perp=mhd_hyperbolic_tc_kappa_perp_factor*kappa_t5
          case('weak_field_isotropization')
            if(mhd_hyperbolic_tc_bmin>zero) then
              fb=b2/(b2+mhd_hyperbolic_tc_bmin**2)
            else
              fb=one
            end if
            kappa_t5_perp_eff=(one-fb)*kappa_t5
            kappa_t5_perp=kappa_t5_perp_eff
          case('electron_magnetization')
            bmag_loc = dsqrt(b2)
            tloc = max(te(ix^d), smalldouble)
            nloc_code = max(ne_loc(ix^d), smalldouble)
            chi = cchi*bmag_loc*tloc**1.5d0/nloc_code
            kappa_t5_perp_eff = kappa_t5/(one+chi**2)
            kappa_t5_perp = kappa_t5_perp_eff
          case default
            kappa_t5_perp=zero
          end select
          kappat5_gradtperp=kappa_t5_perp*gradtperp_mag(ix^d)
        end if
        inv_rho=1.d0/rho_loc(ix^d)
        c2=eos%gamma*pth_loc(ix^d)*inv_rho
        cfast2 = b2*inv_rho + c2
        do idir=1,ndim
          avmincs2(idir)=cfast2**2-4.0d0*c2*bvec(ix^d,idir)**2*inv_rho
          cmax(idir)=sqrt(half*(cfast2+sqrt(dabs(avmincs2(idir)))))\
        end do
        if(mhd_hyperbolic_tc_sat) then
          qclass_diss=dabs(kappat5_bgradt)
          if(use_perp_source) &
            qclass_diss=dsqrt(kappat5_bgradt**2+kappat5_gradtperp**2)
          f_sat=one/(one+qclass_diss/(1.5d0*rho_loc(ix^d)*(pth_loc(ix^d)/rho_loc(ix^d))**1.5d0))
          tau=max(4.d0*dt, f_sat*kappa_t7*courantpar**2/(pth_loc(ix^d)*eos%inv_gamma_minus_1*maxval(cmax(:))**2))
          w(ix^d,qpar_)=w(ix^d,qpar_)-qdt*(f_sat*kappat5_bgradt+wct(ix^d,qpar_))/tau
          if(use_perp_source) then
            w(ix^d,qperp_)=w(ix^d,qperp_)-qdt*(f_sat*kappat5_gradtperp+wct(ix^d,qperp_))/tau
          end if
        else
          tau=max(4.d0*dt, kappa_t7*courantpar**2/(pth_loc(ix^d)*eos%inv_gamma_minus_1*maxval(cmax(:))**2))
          w(ix^d,qpar_)=w(ix^d,qpar_)-qdt*(kappat5_bgradt+wct(ix^d,qpar_))/tau
          if(use_perp_source) then
            w(ix^d,qperp_)=w(ix^d,qperp_)-qdt*(kappat5_gradtperp+wct(ix^d,qperp_))/tau
          end if
        end if
      end do
    end do
   }
   {^ifthreed
    do ix3=ixomin3,ixomax3
      do ix2=ixomin2,ixomax2
        do ix1=ixomin1,ixomax1
          if(mhd_hyperbolic_tc_constant) then
            kappa_t5=mhd_hyperbolic_tc_kappa
            kappa_t7=kappa_t5*te(ix^d)
          else
            tcond=te(ix^d)
            if(mhd_trac) then
              tcond=max(tcond, block%wextra(ix^d,tcoff_))
            end if
            kappa_t5=mhd_hyperbolic_tc_kappa*sqrt(tcond**5)
            kappa_t7 = kappa_t5*tcond
          end if
          kappat5_bgradt=kappa_t5*bgradt(ix^d)
          b2 = zero
          do idir = 1, ndir
            b2 = b2 + bvec(ix^d,idir)**2
          end do
          if(use_perp_source) then
            select case(trim(mhd_hyperbolic_tc_perp_mode))
            case('fixed_reference')
              kappa_t5_perp=mhd_hyperbolic_tc_kappa_perp_factor*kappa_t5
            case('weak_field_isotropization')
              if(mhd_hyperbolic_tc_bmin>zero) then
                fb=b2/(b2+mhd_hyperbolic_tc_bmin**2)
              else
                fb=one
              end if
              kappa_t5_perp_eff=(one-fb)*kappa_t5
              kappa_t5_perp=kappa_t5_perp_eff
            case('electron_magnetization')
              bmag_loc = dsqrt(b2)
              tloc = max(te(ix^d), smalldouble)
              nloc_code = max(ne_loc(ix^d), smalldouble)
              chi = cchi*bmag_loc*tloc**1.5d0/nloc_code
              kappa_t5_perp_eff = kappa_t5/(one+chi**2)
              kappa_t5_perp = kappa_t5_perp_eff
            case default
              kappa_t5_perp=zero
            end select
            kappat5_gradtperp=kappa_t5_perp*gradtperp_mag(ix^d)
          end if
          inv_rho=1.d0/rho_loc(ix^d)
          c2=eos%gamma*pth_loc(ix^d)*inv_rho
          cfast2 = b2*inv_rho + c2
          do idir = 1, ndim
            avmincs2(idir)=cfast2**2-4.0d0*c2*bvec(ix^d,idir)**2*inv_rho
            cmax(idir)=sqrt(half*(cfast2+sqrt(dabs(avmincs2(idir)))))\
          end do
          if(mhd_hyperbolic_tc_sat) then
            qclass_diss=dabs(kappat5_bgradt)
            if(use_perp_source) &
              qclass_diss=dsqrt(kappat5_bgradt**2+kappat5_gradtperp**2)
            f_sat=one/(one+qclass_diss/(1.5d0*rho_loc(ix^d)*(pth_loc(ix^d)/rho_loc(ix^d))**1.5d0))
            tau=max(4.d0*dt, f_sat*kappa_t7*courantpar**2/(pth_loc(ix^d)*eos%inv_gamma_minus_1*maxval(cmax(:))**2))
            w(ix^d,qpar_)=w(ix^d,qpar_)-qdt*(f_sat*kappat5_bgradt+wct(ix^d,qpar_))/tau
            if(use_perp_source) then
              w(ix^d,qperp_)=w(ix^d,qperp_)-qdt*(f_sat*kappat5_gradtperp+wct(ix^d,qperp_))/tau
            end if
          else
            tau=max(4.d0*dt, kappa_t7*courantpar**2/(pth_loc(ix^d)*eos%inv_gamma_minus_1*maxval(cmax(:))**2))
            w(ix^d,qpar_)=w(ix^d,qpar_)-qdt*(kappat5_bgradt+wct(ix^d,qpar_))/tau
            if(use_perp_source) then
              w(ix^d,qperp_)=w(ix^d,qperp_)-qdt*(kappat5_gradtperp+wct(ix^d,qperp_))/tau
            end if
          end if
        end do
      end do
    end do
   }
  end subroutine add_hyperbolic_tc_source
 
  !> Compute the Lorentz force (JxB) Note: Unused subroutine
  !> perhaps useful for post-processing when made public
  subroutine get_lorentz_force(ixI^L,ixO^L,w,JxB)
    use mod_global_parameters
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(in)    :: w(ixi^s,1:nw)
    double precision, intent(inout) :: jxb(ixi^s,3)
    double precision                :: a(ixi^s,3), b(ixi^s,3)
    ! For ndir=2 only 3rd component of J can exist, ndir=1 is impossible for MHD
    double precision :: current(ixi^s,7-2*ndir:3)
    integer                         :: idir, idirmin
 
    b=0.0d0
    if(b0field) then
      do idir = 1, ndir
        b(ixo^s, idir) = w(ixo^s,mag(idir))+block%B0(ixo^s,idir,0)
      end do
    else
      do idir = 1, ndir
        b(ixo^s, idir) = w(ixo^s,mag(idir))
      end do
    end if
 
    ! store J current in a
    call get_current(w,ixi^l,ixo^l,idirmin,current)
 
    a=0.0d0
    do idir=7-2*ndir,3
      a(ixo^s,idir)=current(ixo^s,idir)
    end do
 
    call cross_product(ixi^l,ixo^l,a,b,jxb)
  end subroutine get_lorentz_force
 
  subroutine mhd_get_rho(w,x,ixI^L,ixO^L,rho)
    use mod_global_parameters
    integer, intent(in)           :: ixi^l, ixo^l
    double precision, intent(in)  :: w(ixi^s,1:nw),x(ixi^s,1:ndim)
    double precision, intent(out) :: rho(ixi^s)
 
    if(has_equi_rho_and_p) then
      rho(ixo^s) = w(ixo^s,rho_) + block%equi_vars(ixo^s,equi_rho0_,b0i)
    else
      rho(ixo^s) = w(ixo^s,rho_)
    endif
 
  end subroutine mhd_get_rho
 
  !> handle small or negative internal energy
  subroutine mhd_handle_small_ei(w, x, ixI^L, ixO^L, ie, subname)
    use mod_global_parameters
    use mod_small_values
    integer, intent(in)             :: ixi^l,ixo^l, ie
    double precision, intent(inout) :: w(ixi^s,1:nw)
    double precision, intent(in)    :: x(ixi^s,1:ndim)
    character(len=*), intent(in)    :: subname
 
    double precision              :: rho(ixi^s)
    integer :: idir
    logical :: flag(ixi^s,1:nw)
 
    flag=.false.
    if(has_equi_rho_and_p) then
      where(w(ixo^s,ie)+block%equi_vars(ixo^s,equi_pe0_,0)*eos%inv_gamma_minus_1<small_e)&
             flag(ixo^s,ie)=.true.
    else
      where(w(ixo^s,ie)<small_e) flag(ixo^s,ie)=.true.
    endif
    if(any(flag(ixo^s,ie))) then
      select case (small_values_method)
      case ("replace")
        if(has_equi_rho_and_p) then
          where(flag(ixo^s,ie)) w(ixo^s,ie)=small_e - &
                  block%equi_vars(ixo^s,equi_pe0_,0)*eos%inv_gamma_minus_1
        else
          where(flag(ixo^s,ie)) w(ixo^s,ie)=small_e
        endif
      case ("average")
        call small_values_average(ixi^l, ixo^l, w, x, flag, ie)
      case default
        ! small values error shows primitive variables
        w(ixo^s,e_)=w(ixo^s,e_)*eos%gamma_minus_1
        call mhd_get_rho(w,x,ixi^l,ixo^l,rho)
        do idir = 1, ndir
           w(ixo^s, mom(idir)) = w(ixo^s, mom(idir))/rho(ixo^s)
        end do
        call small_values_error(w, x, ixi^l, ixo^l, flag, subname)
      end select
    end if
 
  end subroutine mhd_handle_small_ei
 
 
  !> Source terms after split off time-independent magnetic field
  subroutine add_source_b0split(qdt,dtfactor,ixI^L,ixO^L,wCT,w,x,wCTprim)
    use mod_global_parameters
 
    integer, intent(in) :: ixi^l, ixo^l
    double precision, intent(in) :: qdt, dtfactor,wct(ixi^s,1:nw), x(ixi^s,1:ndim)
    double precision, intent(in) :: wctprim(ixi^s,1:nw)
    double precision, intent(inout) :: w(ixi^s,1:nw)
 
    double precision :: a(ixi^s,3), b(ixi^s,3), axb(ixi^s,3)
    integer :: idir
 
    a=0.d0
    b=0.d0
    ! for force-free field J0xB0 =0
    if((.not.b0field_forcefree).and.(.not.has_equi_rho_and_p)) then
      ! store B0 magnetic field in b
      b(ixo^s,1:ndir)=block%B0(ixo^s,1:ndir,0)
 
      ! store J0 current in a
      do idir=7-2*ndir,3
        a(ixo^s,idir)=block%J0(ixo^s,idir)
      end do
      call cross_product(ixi^l,ixo^l,a,b,axb)
      if(local_timestep) then
        do idir=1,3
          axb(ixo^s,idir)=axb(ixo^s,idir)*block%dt(ixo^s)*dtfactor
        enddo
      else
        axb(ixo^s,:)=axb(ixo^s,:)*qdt
      endif
      ! add J0xB0 source term in momentum equations
      w(ixo^s,mom(1:ndir))=w(ixo^s,mom(1:ndir))+axb(ixo^s,1:ndir)
    end if
 
    if(total_energy) then
      a=0.d0
      ! for free-free field -(vxB0) dot J0 =0
      b(ixo^s,:)=wctprim(ixo^s,mag(:))
      ! store full magnetic field B0+B1 in b
      if((.not.b0field_forcefree).and.(.not.has_equi_rho_and_p)) b(ixo^s,:)=b(ixo^s,:)+block%B0(ixo^s,:,0)
      ! store velocity in a
      a(ixi^s,1:ndir)=wctprim(ixi^s,mom(1:ndir))
      ! -E = a x b
      call cross_product(ixi^l,ixo^l,a,b,axb)
      if(local_timestep) then
        do idir=1,3
          axb(ixo^s,idir)=axb(ixo^s,idir)*block%dt(ixo^s)*dtfactor
        enddo
      else
        axb(ixo^s,:)=axb(ixo^s,:)*qdt
      endif
      ! add -(vxB) dot J0 source term in energy equation
      ! where it is adding -J0 dot (vxB_1) when appropriate
      do idir=7-2*ndir,3
        w(ixo^s,e_)=w(ixo^s,e_)-axb(ixo^s,idir)*block%J0(ixo^s,idir)
      end do
      if(mhd_hall) then
         ! store hall velocity in a, only partial current is needed
         call mhd_getv_hall(wct,x,ixi^l,ixo^l,a,.true.)
         ! -E = a x b
         call cross_product(ixi^l,ixo^l,a,b,axb)
         if(local_timestep) then
           do idir=1,3
             axb(ixo^s,idir)=axb(ixo^s,idir)*block%dt(ixo^s)*dtfactor
           enddo
         else
           axb(ixo^s,:)=axb(ixo^s,:)*qdt
         endif
         ! add -(vxB) dot J0 source term in energy equation
         do idir=7-2*ndir,3
           w(ixo^s,e_)=w(ixo^s,e_)-axb(ixo^s,idir)*block%J0(ixo^s,idir)
         end do
      endif
      if(mhd_ambipolar_sts) then
        ! in STS variant of ambipolar, we added for split B the term div(B_1xE_ambi)
        ! hence needs to add J_0 dot E_ambi 
        ! to get finally the term etaA (J_perpB)^/B^2-B_1 dot (curl Eambi)
        !reuse axb
        call mhd_get_jxbxb(wct,x,ixi^l,ixo^l,axb)
        ! source J0 * E
        do idir=sdim,3
          !set electric field in jxbxb: E=nuA * jxbxb, where nuA=-etaA/rho^2
          call multiplyambicoef(ixi^l,ixo^l,axb(ixi^s,idir),wct,x)
          w(ixo^s,e_)=w(ixo^s,e_)+qdt*axb(ixo^s,idir)*block%J0(ixo^s,idir)
        enddo
      endif
    end if
    
 
    if (fix_small_values) call mhd_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_B0')
 
  end subroutine add_source_b0split
 
  !> Source terms for semirelativistic MHD Gombosi 2002 JCP 177, 176
  subroutine add_source_semirelativistic(qdt,ixI^L,ixO^L,wCT,w,x,wCTprim)
    use mod_global_parameters
    use mod_geometry
 
    integer, intent(in) :: ixi^l, ixo^l
    double precision, intent(in) :: qdt, wct(ixi^s,1:nw), x(ixi^s,1:ndim)
    double precision, intent(inout) :: w(ixi^s,1:nw)
    double precision, intent(in), optional :: wctprim(ixi^s,1:nw)
 
    double precision :: e(ixi^s,1:3),curle(ixi^s,1:3),dive(ixi^s)
    integer :: idir, idirmin, ix^d
 
   ! if ndir<3 the source is zero
   {^ifthreec
   {do ix^db=iximin^db,iximax^db\}
      ! E=Bxv
      e(ix^d,1)=w(ix^d,b2_)*wctprim(ix^d,m3_)-w(ix^d,b3_)*wctprim(ix^d,m2_)
      e(ix^d,2)=w(ix^d,b3_)*wctprim(ix^d,m1_)-w(ix^d,b1_)*wctprim(ix^d,m3_)
      e(ix^d,3)=w(ix^d,b1_)*wctprim(ix^d,m2_)-w(ix^d,b2_)*wctprim(ix^d,m1_)
   {end do\}
    call divvector(e,ixi^l,ixo^l,dive)
    ! curl E
    call curlvector(e,ixi^l,ixo^l,curle,idirmin,1,3)
    ! add source term in momentum equations (1/c0^2-1/c^2)(E divE - E x curlE)
    ! equation (26) and (27)
   {do ix^db=ixomin^db,ixomax^db\}
      w(ix^d,m1_)=w(ix^d,m1_)+qdt*(inv_squared_c0-inv_squared_c)*&
       (e(ix^d,1)*dive(ix^d)-e(ix^d,2)*curle(ix^d,3)+e(ix^d,3)*curle(ix^d,2))
      w(ix^d,m2_)=w(ix^d,m2_)+qdt*(inv_squared_c0-inv_squared_c)*&
       (e(ix^d,2)*dive(ix^d)-e(ix^d,3)*curle(ix^d,1)+e(ix^d,1)*curle(ix^d,3))
      w(ix^d,m3_)=w(ix^d,m3_)+qdt*(inv_squared_c0-inv_squared_c)*&
       (e(ix^d,3)*dive(ix^d)-e(ix^d,1)*curle(ix^d,2)+e(ix^d,2)*curle(ix^d,1) )
   {end do\}
   }
 
  end subroutine add_source_semirelativistic
 
  !> Source terms for internal energy version of MHD
  subroutine add_source_internal_e(qdt,ixI^L,ixO^L,wCT,w,x,wCTprim)
    use mod_global_parameters
    use mod_geometry
 
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(in)    :: qdt
    double precision, intent(in)    :: wct(ixi^s,1:nw), x(ixi^s,1:ndim)
    double precision, intent(inout) :: w(ixi^s,1:nw)
    double precision, intent(in)    :: wctprim(ixi^s,1:nw)
 
    double precision                :: divv(ixi^s), tmp
    integer :: ix^d
 
    if(slab_uniform) then
      if(nghostcells .gt. 2) then
        call divvector(wctprim(ixi^s,mom(:)),ixi^l,ixo^l,divv,3)
      else
        call divvector(wctprim(ixi^s,mom(:)),ixi^l,ixo^l,divv,2)
      end if
    else
      call divvector(wctprim(ixi^s,mom(:)),ixi^l,ixo^l,divv)
    end if
   {do ix^db=ixomin^db,ixomax^db\}
      tmp=w(ix^d,e_)
      w(ix^d,e_)=w(ix^d,e_)-qdt*wctprim(ix^d,p_)*divv(ix^d)
      if(w(ix^d,e_)<small_e) then
        w(ix^d,e_)=tmp
      end if
   {end do\}
    if(mhd_ambipolar_sts)then
      call add_source_ambipolar_internal_energy(qdt,ixi^l,ixo^l,wct,w,x)
    end if
 
    if(fix_small_values) then
      call mhd_handle_small_ei(w,x,ixi^l,ixo^l,e_,'add_source_internal_e')
    end if
  end subroutine add_source_internal_e
 
  !> Source terms for hydrodynamic energy version of MHD
  subroutine add_source_hydrodynamic_e(qdt,ixI^L,ixO^L,wCT,w,x,wCTprim)
    use mod_global_parameters
    use mod_geometry
    use mod_usr_methods, only: usr_gravity
 
    integer, intent(in) :: ixi^l, ixo^l
    double precision, intent(in) :: qdt, wct(ixi^s,1:nw), x(ixi^s,1:ndim)
    double precision, intent(inout) :: w(ixi^s,1:nw)
    double precision, intent(in), optional :: wctprim(ixi^s,1:nw)
 
    double precision :: b(ixi^s,3), j(ixi^s,3), jxb(ixi^s,3)
    double precision :: current(ixi^s,7-2*ndir:3)
    double precision :: bu(ixo^s,1:ndir), tmp(ixo^s), b2(ixo^s)
    double precision :: gravity_field(ixi^s,1:ndir), vaoc
    integer :: idir, idirmin, idims, ix^d
 
    {^nothreed
    b=0.0d0
    do idir = 1, ndir
      b(ixo^s, idir) = wct(ixo^s,mag(idir))
    end do
 
    if(slab_uniform)then
      ! get current in fourth order accuracy in Cartesian
      call curlvector(wct(ixi^s,mag(1:ndir)),ixi^l,ixo^l,current,idirmin,7-2*ndir,ndir,.true.)
    else
      call get_current(wct,ixi^l,ixo^l,idirmin,current)
    endif
 
    j=0.0d0
    do idir=7-2*ndir,3
      j(ixo^s,idir)=current(ixo^s,idir)
    end do
 
    ! get Lorentz force JxB
    call cross_product(ixi^l,ixo^l,j,b,jxb)
    }
    {^ifthreed
    if(slab_uniform)then
      ! get current in fourth order accuracy in Cartesian
      call curlvector(wct(ixi^s,mag(1:ndir)),ixi^l,ixo^l,current,idirmin,1,ndir,.true.)
    else
      call get_current(wct,ixi^l,ixo^l,idirmin,current)
    endif
    ! get Lorentz force JxB
    call cross_product(ixi^l,ixo^l,current,wct(ixi^s,mag(1:ndir)),jxb)
    }
 
    ! mhd_semirelativistic does not combine with mhd_hydrodynamic_e
    !!if(mhd_semirelativistic) then
    !!  ! (v . nabla) v
    !!  do idir=1,ndir
    !!    do idims=1,ndim
    !!      call gradient(wCTprim(ixI^S,mom(idir)),ixI^L,ixO^L,idims,J(ixI^S,idims))
    !!    end do
    !!    B(ixO^S,idir)=sum(wCTprim(ixO^S,mom(1:ndir))*J(ixO^S,1:ndir),dim=ndim+1)
    !!  end do
    !!  ! nabla p
    !!  do idir=1,ndir
    !!    call gradient(wCTprim(ixI^S,p_),ixI^L,ixO^L,idir,J(ixI^S,idir))
    !!  end do
    !!  if(mhd_gravity) then
    !!    gravity_field=0.d0
    !!    call usr_gravity(ixI^L,ixO^L,wCT,x,gravity_field(ixI^S,1:ndim))
    !!    do idir=1,ndir
    !!      B(ixO^S,idir)=wCT(ixO^S,rho_)*(B(ixO^S,idir)-gravity_field(ixO^S,idir))+J(ixO^S,idir)-JxB(ixO^S,idir)
    !!    end do
    !!  else
    !!    do idir=1,ndir
    !!      B(ixO^S,idir)=wCT(ixO^S,rho_)*B(ixO^S,idir)+J(ixO^S,idir)-JxB(ixO^S,idir)
    !!    end do
    !!  end if
    !!  b2(ixO^S)=sum(wCT(ixO^S,mag(:))**2,dim=ndim+1)
    !!  tmp(ixO^S)=sqrt(b2(ixO^S))
    !!  where(tmp(ixO^S)>smalldouble)
    !!    tmp(ixO^S)=1.d0/tmp(ixO^S)
    !!  else where
    !!    tmp(ixO^S)=0.d0
    !!  end where
    !!  ! unit vector of magnetic field
    !!  do idir=1,ndir
    !!    bu(ixO^S,idir)=wCT(ixO^S,mag(idir))*tmp(ixO^S)
    !!  end do
    !!  !b2(ixO^S)=b2(ixO^S)/w(ixO^S,rho_)*inv_squared_c
    !!  !b2(ixO^S)=b2(ixO^S)/(1.d0+b2(ixO^S))
    !!  {do ix^DB=ixOmin^DB,ixOmax^DB\}
    !!     ! Va^2/c^2
    !!     Vaoc=b2(ix^D)/w(ix^D,rho_)*inv_squared_c
    !!     ! Va^2/c^2 / (1+Va^2/c^2)
    !!     b2(ix^D)=Vaoc/(1.d0+Vaoc)
    !!  {end do\}
    !!  ! bu . F
    !!  tmp(ixO^S)=sum(bu(ixO^S,1:ndir)*B(ixO^S,1:ndir),dim=ndim+1)
    !!  ! Rempel 2017 ApJ 834, 10 equation (54)
    !!  do idir=1,ndir
    !!    J(ixO^S,idir)=b2(ixO^S)*(B(ixO^S,idir)-bu(ixO^S,idir)*tmp(ixO^S))
    !!  end do
    !!  !! Rempel 2017 ApJ 834, 10 equation (29) add SR force at momentum equation
    !!  do idir=1,ndir
    !!    w(ixO^S,mom(idir))=w(ixO^S,mom(idir))+qdt*J(ixO^S,idir)
    !!  end do
    !!  ! Rempel 2017 ApJ 834, 10 equation (30) add work of Lorentz force and SR force
    !!  w(ixO^S,e_)=w(ixO^S,e_)+qdt*sum(wCTprim(ixO^S,mom(1:ndir))*&
    !!          (JxB(ixO^S,1:ndir)+J(ixO^S,1:ndir)),dim=ndim+1)
    !!else
      ! add work of Lorentz force
      w(ixo^s,e_)=w(ixo^s,e_)+qdt*sum(wctprim(ixo^s,mom(1:ndir))*jxb(ixo^s,1:ndir),dim=ndim+1)
    !!end if
 
    if(mhd_ambipolar_sts)then
      call add_source_ambipolar_internal_energy(qdt,ixi^l,ixo^l,wct,w,x)
    end if
 
    if (fix_small_values) call mhd_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_hydrodynamic_e')
 
  end subroutine add_source_hydrodynamic_e
 
  !> Add resistive source to w within ixO Uses 3 point stencil (1 neighbour) in
  !> each direction, non-conservative. Uses the generic Laplacian
  !> with fourth order central difference (on uniform cartesian) for the laplacian. Then the
  !> stencil is 5 (2 neighbours). NOTE: Unused subroutine!
  subroutine add_source_res1(qdt,ixI^L,ixO^L,wCT,w,x)
    use mod_global_parameters
    use mod_usr_methods
    use mod_geometry
 
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(in)    :: qdt
    double precision, intent(in) :: wct(ixi^s,1:nw), x(ixi^s,1:ndim)
    double precision, intent(inout) :: w(ixi^s,1:nw)
 
    integer :: ixa^l,idir,jdir,kdir,idirmin,idim
    double precision :: tmp(ixi^s),tmp2(ixi^s)
 
    ! For ndir=2 only 3rd component of J can exist, ndir=1 is impossible for MHD
    double precision :: current(ixi^s,7-2*ndir:3),eta(ixi^s)
    double precision :: gradeta(ixi^s,1:ndim), bf(ixi^s,1:ndir)
    double precision :: lapl_vec(ixi^s,1:ndir)
 
    ! Calculating resistive sources involves one extra layer
    ! asking here for two, so Cartesian works with 4th order CD
    ixa^l=ixo^l^ladd2;
 
    if (iximin^d>ixamin^d.or.iximax^d<ixamax^d|.or.) &
         call mpistop("Error in add_source_res1: Non-conforming input limits")
 
    ! Calculate current density and idirmin
    call get_current(wct,ixi^l,ixo^l,idirmin,current)
 
    if (mhd_eta>zero)then
       eta(ixa^s)=mhd_eta
       gradeta(ixo^s,1:ndim)=zero
    else
       call usr_special_resistivity(wct,ixi^l,ixa^l,idirmin,x,current,eta)
       do idim=1,ndim
          call gradient(eta,ixi^l,ixo^l,idim,tmp)
          gradeta(ixo^s,idim)=tmp(ixo^s)
       end do
    end if
 
    if(b0field) then
      bf(ixi^s,1:ndir)=wct(ixi^s,mag(1:ndir))+block%B0(ixi^s,1:ndir,0)
    else
      bf(ixi^s,1:ndir)=wct(ixi^s,mag(1:ndir))
    end if
 
    call laplacian_of_vector(bf,ixi^l,ixo^l,lapl_vec)
 
    do idir=1,ndir
       ! Multiply by eta to store eta*Laplace B_idir
       tmp(ixo^s)=lapl_vec(ixo^s,idir)*eta(ixo^s)
       
       ! Subtract grad(eta) x J = eps_ijk d_j eta J_k if eta is non-constant
       if (mhd_eta<zero)then
          do jdir=1,ndim; do kdir=idirmin,3
             if (lvc(idir,jdir,kdir)/=0)then
                if (lvc(idir,jdir,kdir)==1)then
                   tmp(ixo^s)=tmp(ixo^s)-gradeta(ixo^s,jdir)*current(ixo^s,kdir)
                else
                   tmp(ixo^s)=tmp(ixo^s)+gradeta(ixo^s,jdir)*current(ixo^s,kdir)
                end if
             end if
          end do; end do
       end if
 
       ! Add sources related to eta*laplB-grad(eta) x J to B and e
       w(ixo^s,mag(idir))=w(ixo^s,mag(idir))+qdt*tmp(ixo^s)
       if(total_energy) then
          w(ixo^s,e_)=w(ixo^s,e_)+qdt*tmp(ixo^s)*bf(ixo^s,idir)
       end if
    end do ! idir
 
    if(mhd_energy) then
      ! de/dt+=eta*J**2
      w(ixo^s,e_)=w(ixo^s,e_)+qdt*eta(ixo^s)*sum(current(ixo^s,:)**2,dim=ndim+1)
    end if
 
    if (fix_small_values) call mhd_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_res1')
 
  end subroutine add_source_res1
 
  !> Add resistive source to w within ixO in an explicit fashion
  !> Uses 5 point stencil (2 neighbours) in each direction, conservative
  subroutine add_source_res_exp(qdt,ixI^L,ixO^L,wCT,w,x)
    use mod_global_parameters
    use mod_usr_methods
    use mod_geometry
 
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(in)    :: qdt
    double precision, intent(in)    :: wct(ixi^s,1:nw), x(ixi^s,1:ndim)
    double precision, intent(inout) :: w(ixi^s,1:nw)
 
    ! For ndir=2 only 3rd component of J can exist, ndir=1 is impossible for MHD
    double precision :: current(ixi^s,7-2*ndir:3),eta(ixi^s),curlj(ixi^s,1:3)
    double precision :: tmpvec(ixi^s,1:3),tmp(ixo^s)
    integer :: ixa^l,idir,idirmin,idirmin1
 
    ixa^l=ixo^l^ladd2;
 
    if (iximin^d>ixamin^d.or.iximax^d<ixamax^d|.or.) &
         call mpistop("Error in add_source_res_exp: Non-conforming input limits")
 
    ixa^l=ixo^l^ladd1;
    ! Calculate current density within ixL: J=curl B, thus J_i=eps_ijk*d_j B_k
    ! Determine exact value of idirmin while doing the loop.
    call get_current(wct,ixi^l,ixa^l,idirmin,current)
 
    tmpvec=zero
    if(mhd_eta>zero)then
      do idir=idirmin,3
        tmpvec(ixa^s,idir)=current(ixa^s,idir)*mhd_eta
      end do
    else
      call usr_special_resistivity(wct,ixi^l,ixa^l,idirmin,x,current,eta)
      do idir=idirmin,3
        tmpvec(ixa^s,idir)=current(ixa^s,idir)*eta(ixa^s)
      end do
    end if
 
    ! dB/dt= -curl(J*eta), thus B_i=B_i-eps_ijk d_j Jeta_k
    call curlvector(tmpvec,ixi^l,ixo^l,curlj,idirmin1,1,3)
    if(stagger_grid) then
      if(ndim==2.and.ndir==3) then
        ! if 2.5D
        w(ixo^s,mag(ndir)) = w(ixo^s,mag(ndir))-qdt*curlj(ixo^s,ndir)
      end if
    else
      w(ixo^s,mag(1:ndir)) = w(ixo^s,mag(1:ndir))-qdt*curlj(ixo^s,1:ndir)
    end if
 
    if(mhd_energy) then
      if(mhd_eta>zero)then
        tmp(ixo^s)=qdt*mhd_eta*sum(current(ixo^s,:)**2,dim=ndim+1)
      else
        tmp(ixo^s)=qdt*eta(ixo^s)*sum(current(ixo^s,:)**2,dim=ndim+1)
      end if
      if(total_energy) then
        ! de/dt= +div(B x Jeta) = eta J^2 - B dot curl(eta J)
        ! de1/dt= eta J^2 - B1 dot curl(eta J)
        w(ixo^s,e_)=w(ixo^s,e_)+tmp(ixo^s)-&
        qdt*sum(wct(ixo^s,mag(1:ndir))*curlj(ixo^s,1:ndir),dim=ndim+1)
      else
        ! add eta*J**2 source term in the internal energy equation
        w(ixo^s,e_)=w(ixo^s,e_)+tmp(ixo^s)
      end if
    end if
 
    if (fix_small_values) call mhd_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_res_exp')
  end subroutine add_source_res_exp
 
 
  !> Add ambipolar source to w within ixO in an explicit fashion
  !> Uses 5 point stencil (2 neighbours) in each direction, conservative
  subroutine add_source_ambi_exp(qdt,ixI^L,ixO^L,wCT,w,x)
    use mod_global_parameters
    use mod_usr_methods
    use mod_geometry
 
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(in)    :: qdt
    double precision, intent(in)    :: wct(ixi^s,1:nw), x(ixi^s,1:ndim)
    double precision, intent(inout) :: w(ixi^s,1:nw)
 
    double precision :: current(ixi^s,1:3),curlj(ixi^s,1:3)
    double precision :: tmpvec(ixi^s,1:3),tmp(ixi^s),btot2(ixi^s)
    integer :: ixa^l,idir,idirmin1
 
    ixa^l=ixo^l^ladd2;
 
    if (iximin^d>ixamin^d.or.iximax^d<ixamax^d|.or.) &
         call mpistop("Error in add_source_ambi_exp: Non-conforming input limits")
 
    ixa^l=ixo^l^ladd1;
    ! Calculate -J_perpB = (JxB)xB
    call mhd_get_jxbxb(wct,x,ixi^l,ixa^l,current)
 
    tmpvec=current
    do idir=1,3
      !set electric field in tmpvec : E=nuA * jxbxb, where nuA=-etaA/rho^2
      !tmpvec(ixA^S,i) = -(mhd_eta_ambi/w(ixA^S, rho_)**2) * jxbxb(ixA^S,i)
      call multiplyambicoef(ixi^l,ixa^l,tmpvec(ixi^s,idir),wct,x)
    end do
 
    ! dB/dt= -curl(J_perpB*etaA), thus B_i=B_i-eps_ijk d_j Jeta_k
    call curlvector(tmpvec,ixi^l,ixo^l,curlj,idirmin1,1,3)
    if(stagger_grid) then
      if(ndim==2.and.ndir==3) then
        ! if 2.5D
        w(ixo^s,mag(ndir)) = w(ixo^s,mag(ndir))-qdt*curlj(ixo^s,ndir)
      end if
    else
      w(ixo^s,mag(1:ndir)) = w(ixo^s,mag(1:ndir))-qdt*curlj(ixo^s,1:ndir)
    end if
 
    if(mhd_energy) then
      ! compute ambipolar heating term: nuA* J_perpB^2/ B^2
      ! avoiding nulls here
      btot2(ixa^s)=mhd_mag_en_all(wct,ixi^l,ixa^l)
      where (btot2(ixa^s)>smalldouble )
          tmp(ixa^s) = sum(current(ixa^s,1:3)**2,dim=ndim+1) / btot2(ixa^s)
      elsewhere
          tmp(ixa^s) = zero
      endwhere
      ! multiply with nuA where nuA=-etaA/rho^2
      call multiplyambicoef(ixi^l,ixa^l,tmp,wct,x)
      ! compensate - sign and add timestep
      tmp(ixo^s)=-qdt*tmp(ixo^s)
      if(total_energy) then
        ! de/dt= +div(B x E_ambi) = eta J^2 - B dot curl(eta J)
        ! de1/dt= eta J^2 - B1 dot curl(eta J)
        w(ixo^s,e_)=w(ixo^s,e_)+tmp(ixo^s)-&
        qdt*sum(wct(ixo^s,mag(1:ndir))*curlj(ixo^s,1:ndir),dim=ndim+1)
      else
        ! add eta*J**2 source term in the internal or hydrodynamic energy equation
        w(ixo^s,e_)=w(ixo^s,e_)+tmp(ixo^s)
      end if
    end if
 
    if (fix_small_values) call mhd_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_ambi_exp')
  end subroutine add_source_ambi_exp
 
  !> Add Hyper-resistive source to w within ixO
  !> Uses 9 point stencil (4 neighbours) in each direction.
  subroutine add_source_hyperres(qdt,ixI^L,ixO^L,wCT,w,x)
    use mod_global_parameters
    use mod_geometry
 
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(in)    :: qdt
    double precision, intent(in)    :: wct(ixi^s,1:nw), x(ixi^s,1:ndim)
    double precision, intent(inout) :: w(ixi^s,1:nw)
    !.. local ..
    double precision                :: current(ixi^s,7-2*ndir:3)
    double precision                :: tmpvec(ixi^s,1:3),tmpvec2(ixi^s,1:3),tmp(ixi^s),ehyper(ixi^s,1:3)
    integer                         :: ixa^l,idir,jdir,kdir,idirmin,idirmin1
 
    ixa^l=ixo^l^ladd3;
    if (iximin^d>ixamin^d.or.iximax^d<ixamax^d|.or.) &
         call mpistop("Error in add_source_hyperres: Non-conforming input limits")
 
    call get_current(wct,ixi^l,ixa^l,idirmin,current)
    tmpvec(ixa^s,1:ndir)=zero
    do jdir=idirmin,3
       tmpvec(ixa^s,jdir)=current(ixa^s,jdir)
    end do
 
    ixa^l=ixo^l^ladd2;
    call curlvector(tmpvec,ixi^l,ixa^l,tmpvec2,idirmin1,1,3)
 
    ixa^l=ixo^l^ladd1;
    tmpvec(ixa^s,1:ndir)=zero
    call curlvector(tmpvec2,ixi^l,ixa^l,tmpvec,idirmin1,1,3)
    ehyper(ixa^s,1:ndir) = - tmpvec(ixa^s,1:ndir)*mhd_eta_hyper
 
    ixa^l=ixo^l;
    tmpvec2(ixa^s,1:ndir)=zero
    call curlvector(ehyper,ixi^l,ixa^l,tmpvec2,idirmin1,1,3)
 
    do idir=1,ndir
      w(ixo^s,mag(idir)) = w(ixo^s,mag(idir))-tmpvec2(ixo^s,idir)*qdt
    end do
 
    if(total_energy) then
      ! de/dt= +div(B x Ehyper)
      ixa^l=ixo^l^ladd1;
      tmpvec2(ixa^s,1:ndir)=zero
      do idir=1,ndir; do jdir=1,ndir; do kdir=idirmin,3
        tmpvec2(ixa^s,idir) = tmpvec(ixa^s,idir)&
        + lvc(idir,jdir,kdir)*wct(ixa^s,mag(jdir))*ehyper(ixa^s,kdir)
      end do; end do; end do
      tmp(ixo^s)=zero
      call divvector(tmpvec2,ixi^l,ixo^l,tmp)
      w(ixo^s,e_)=w(ixo^s,e_)+tmp(ixo^s)*qdt
    end if
 
    if (fix_small_values)  call mhd_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_hyperres')
 
  end subroutine add_source_hyperres
 
  subroutine add_source_glm(qdt,ixI^L,ixO^L,wCT,w,x)
    ! Add divB related sources to w within ixO
    ! corresponding to Dedner JCP 2002, 175, 645 _equation 24_
    ! giving the EGLM-MHD scheme or GLM-MHD scheme
    use mod_global_parameters
    use mod_geometry
 
    integer, intent(in) :: ixi^l, ixo^l
    double precision, intent(in) :: qdt, wct(ixi^s,1:nw), x(ixi^s,1:ndim)
    double precision, intent(inout) :: w(ixi^s,1:nw)
 
    double precision:: divb(ixi^s), gradpsi(ixi^s), ba(ixo^s,1:ndir)
    integer          :: idir
 
 
    ! dPsi/dt =  - Ch^2/Cp^2 Psi
    if (mhd_glm_alpha < zero) then
      w(ixo^s,psi_) = abs(mhd_glm_alpha)*wct(ixo^s,psi_)
    else
      ! implicit update of Psi variable
      ! equation (27) in Mignone 2010 J. Com. Phys. 229, 2117
      if(slab_uniform) then
        w(ixo^s,psi_) = dexp(-qdt*cmax_global*mhd_glm_alpha/minval(dxlevel(:)))*w(ixo^s,psi_)
      else
        w(ixo^s,psi_) = dexp(-qdt*cmax_global*mhd_glm_alpha/minval(block%ds(ixo^s,:),dim=ndim+1))*w(ixo^s,psi_)
      end if
    end if
 
    if(mhd_glm_extended) then
      if(b0field) then
        ba(ixo^s,1:ndir)=wct(ixo^s,mag(1:ndir))+block%B0(ixo^s,1:ndir,0)
      else
        ba(ixo^s,1:ndir)=wct(ixo^s,mag(1:ndir))
      end if
      ! gradient of Psi
      if(total_energy) then
        do idir=1,ndim
          select case(typegrad)
          case("central")
            call gradient(wct(ixi^s,psi_),ixi^l,ixo^l,idir,gradpsi)
          case("limited")
            call gradientl(wct(ixi^s,psi_),ixi^l,ixo^l,idir,gradpsi)
          end select
          ! e  = e  -qdt (b . grad(Psi))
          w(ixo^s,e_) = w(ixo^s,e_)-qdt*ba(ixo^s,idir)*gradpsi(ixo^s)
        end do
      end if
 
      ! We calculate now div B
      call get_divb(wct,ixi^l,ixo^l,divb, mhd_divb_nth)
 
      ! m = m - qdt b div b
      do idir=1,ndir
        w(ixo^s,mom(idir))=w(ixo^s,mom(idir))-qdt*ba(ixo^s,idir)*divb(ixo^s)
      end do
    end if
 
    if (fix_small_values) call mhd_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_glm')
 
  end subroutine add_source_glm
 
  !> Add divB related sources to w within ixO corresponding to Powel
  subroutine add_source_powel(qdt,ixI^L,ixO^L,wCT,w,x)
    use mod_global_parameters
 
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(in)    :: qdt,   wct(ixi^s,1:nw), x(ixi^s,1:ndim)
    double precision, intent(inout) :: w(ixi^s,1:nw)
 
    double precision                :: divb(ixi^s), ba(1:ndir)
    integer                         :: idir, ix^d
 
    ! calculate div B
    call get_divb(wct,ixi^l,ixo^l,divb, mhd_divb_nth)
 
    if(b0field) then
     {do ix^db=ixomin^db,ixomax^db\}
        ! b = b - qdt v * div b
        ^c&w(ix^d,b^c_)=w(ix^d,b^c_)-qdt*wct(ix^d,m^c_)*divb(ix^d)\
        ! m = m - qdt b div b
        ^c&w(ix^d,m^c_)=w(ix^d,m^c_)-qdt*(wct(ix^d,b^c_)+block%B0(ix^d,^c,0))*divb(ix^d)\
        if (total_energy) then
          ! e = e - qdt (v . b) * div b
          w(ix^d,e_)=w(ix^d,e_)-qdt*(^c&wct(ix^d,m^c_)*(wct(ix^d,b^c_)+block%B0(ix^d,^c,0))+)*divb(ix^d)
        end if
     {end do\}
    else
     {do ix^db=ixomin^db,ixomax^db\}
        ! b = b - qdt v * div b
        ^c&w(ix^d,b^c_)=w(ix^d,b^c_)-qdt*wct(ix^d,m^c_)*divb(ix^d)\
        ! m = m - qdt b div b
        ^c&w(ix^d,m^c_)=w(ix^d,m^c_)-qdt*wct(ix^d,b^c_)*divb(ix^d)\
        if (total_energy) then
          ! e = e - qdt (v . b) * div b
          w(ix^d,e_)=w(ix^d,e_)-qdt*(^c&wct(ix^d,m^c_)*wct(ix^d,b^c_)+)*divb(ix^d)
        end if
     {end do\}
    end if
 
    if (fix_small_values) call mhd_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_powel')
 
  end subroutine add_source_powel
 
  subroutine add_source_janhunen(qdt,ixI^L,ixO^L,wCT,w,x)
    ! Add divB related sources to w within ixO
    ! corresponding to Janhunen, just the term in the induction equation.
    use mod_global_parameters
 
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(in)    :: qdt,   wct(ixi^s,1:nw), x(ixi^s,1:ndim)
    double precision, intent(inout) :: w(ixi^s,1:nw)
 
    double precision                :: divb(ixi^s)
    integer                         :: idir, ix^d
 
    ! calculate div B
    call get_divb(wct,ixi^l,ixo^l,divb, mhd_divb_nth)
 
   {do ix^db=ixomin^db,ixomax^db\}
      ! b = b - qdt v * div b
      ^c&w(ix^d,b^c_)=w(ix^d,b^c_)-qdt*wct(ix^d,m^c_)*divb(ix^d)\
   {end do\}
 
    if (fix_small_values) call mhd_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_janhunen')
 
  end subroutine add_source_janhunen
 
  subroutine add_source_linde(qdt,ixI^L,ixO^L,wCT,w,x)
    ! Add Linde's divB related sources to wnew within ixO
    use mod_global_parameters
    use mod_geometry
 
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(in)    :: qdt, wct(ixi^s,1:nw), x(ixi^s,1:ndim)
    double precision, intent(inout) :: w(ixi^s,1:nw)
 
    double precision :: divb(ixi^s),graddivb(ixi^s)
    integer :: idim, idir, ixp^l, i^d, iside
    logical, dimension(-1:1^D&) :: leveljump
 
    ! Calculate div B
    ixp^l=ixo^l^ladd1;
    call get_divb(wct,ixi^l,ixp^l,divb, mhd_divb_nth)
 
    ! for AMR stability, retreat one cell layer from the boarders of level jump
    {do i^db=-1,1\}
      if(i^d==0|.and.) cycle
      if(neighbor_type(i^d,block%igrid)==2 .or. neighbor_type(i^d,block%igrid)==4) then
        leveljump(i^d)=.true.
      else
        leveljump(i^d)=.false.
      end if
    {end do\}
 
    ixp^l=ixo^l;
    do idim=1,ndim
      select case(idim)
       {case(^d)
          do iside=1,2
            i^dd=kr(^dd,^d)*(2*iside-3);
            if (leveljump(i^dd)) then
              if (iside==1) then
                ixpmin^d=ixomin^d-i^d
              else
                ixpmax^d=ixomax^d-i^d
              end if
            end if
          end do
       \}
      end select
    end do
 
    ! Add Linde's diffusive terms
    do idim=1,ndim
       ! Calculate grad_idim(divb)
       call gradient(divb,ixi^l,ixp^l,idim,graddivb)
 
      {do i^db=ixpmin^db,ixpmax^db\}
         ! Multiply by Linde's eta*dt = divbdiff*(c_max*dx)*dt = divbdiff*dx**2
         graddivb(i^d)=graddivb(i^d)*divbdiff/(^d&1.0d0/block%ds({i^d},^d)**2+)
 
         w(i^d,mag(idim))=w(i^d,mag(idim))+graddivb(i^d)
 
         if (typedivbdiff=='all' .and. total_energy) then
           ! e += B_idim*eta*grad_idim(divb)
           w(i^d,e_)=w(i^d,e_)+wct(i^d,mag(idim))*graddivb(i^d)
         end if
      {end do\}
    end do
 
    if (fix_small_values) call mhd_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_linde')
 
  end subroutine add_source_linde
 
  !> get dimensionless div B = |divB| * volume / area / |B|
  subroutine get_normalized_divb(w,ixI^L,ixO^L,divb)
 
    use mod_global_parameters
 
    integer, intent(in)                :: ixi^l, ixo^l
    double precision, intent(in)       :: w(ixi^s,1:nw)
    double precision                   :: divb(ixi^s), dsurface(ixi^s)
 
    double precision :: invb(ixo^s)
    integer :: ixa^l,idims
 
    call get_divb(w,ixi^l,ixo^l,divb)
    invb(ixo^s)=sqrt(mhd_mag_en_all(w,ixi^l,ixo^l))
    where(invb(ixo^s)/=0.d0)
      invb(ixo^s)=1.d0/invb(ixo^s)
    end where
    if(slab_uniform) then
      divb(ixo^s)=0.5d0*abs(divb(ixo^s))*invb(ixo^s)/sum(1.d0/dxlevel(:))
    else
      ixamin^d=ixomin^d-1;
      ixamax^d=ixomax^d-1;
      dsurface(ixo^s)= sum(block%surfaceC(ixo^s,:),dim=ndim+1)
      do idims=1,ndim
        ixa^l=ixo^l-kr(idims,^d);
        dsurface(ixo^s)=dsurface(ixo^s)+block%surfaceC(ixa^s,idims)
      end do
      divb(ixo^s)=abs(divb(ixo^s))*invb(ixo^s)*&
      block%dvolume(ixo^s)/dsurface(ixo^s)
    end if
 
  end subroutine get_normalized_divb
 
  !> Calculate idirmin and the idirmin:3 components of the common current array
  !> make sure that dxlevel(^D) is set correctly.
  subroutine get_current(w,ixI^L,ixO^L,idirmin,current)
    use mod_global_parameters
    use mod_geometry
 
    integer, intent(in)  :: ixo^l, ixi^l
    double precision, intent(in) :: w(ixi^s,1:nw)
    integer, intent(out) :: idirmin
 
    ! For ndir=2 only 3rd component of J can exist, ndir=1 is impossible for MHD
    double precision :: current(ixi^s,7-2*ndir:3)
    integer :: idir, idirmin0
 
    idirmin0 = 7-2*ndir
 
    call curlvector(w(ixi^s,mag(1:ndir)),ixi^l,ixo^l,current,idirmin,idirmin0,ndir)
 
    if(b0field) current(ixo^s,idirmin0:3)=current(ixo^s,idirmin0:3)+&
        block%J0(ixo^s,idirmin0:3)
  end subroutine get_current
 
  !> If resistivity is not zero, check diffusion time limit for dt and similar other effects
  subroutine mhd_get_dt(wprim,ixI^L,ixO^L,dtnew,dx^D,x)
    use mod_global_parameters
    use mod_usr_methods
    use mod_viscosity, only: viscosity_get_dt
    use mod_gravity, only: gravity_get_dt
    use mod_cak_force, only: cak_get_dt
    use mod_fld, only: fld_radforce_get_dt
 
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(inout) :: dtnew
    double precision, intent(in)    :: dx^d
    double precision, intent(in)    :: wprim(ixi^s,1:nw)
    double precision, intent(in)    :: x(ixi^s,1:ndim)
 
    double precision              :: dxarr(ndim)
    double precision              :: current(ixi^s,7-2*ndir:3),eta(ixi^s)
    integer                       :: idirmin,idim
 
    dtnew = bigdouble
 
    ^d&dxarr(^d)=dx^d;
    if (mhd_eta>zero)then
      if(slab_uniform) then
       dtnew=dtdiffpar*minval(dxarr(1:ndim))**2/mhd_eta
      else
       dtnew=dtdiffpar*minval(block%ds(ixo^s,1:ndim))**2/mhd_eta
      end if
    else if (mhd_eta<zero)then
       call get_current(wprim,ixi^l,ixo^l,idirmin,current)
       call usr_special_resistivity(wprim,ixi^l,ixo^l,idirmin,x,current,eta)
       dtnew=bigdouble
       do idim=1,ndim
         if(slab_uniform) then
           dtnew=min(dtnew,&
                dtdiffpar/(smalldouble+maxval(eta(ixo^s)/dxarr(idim)**2)))
         else
           dtnew=min(dtnew,&
                dtdiffpar/(smalldouble+maxval(eta(ixo^s)/block%ds(ixo^s,idim)**2)))
         end if
       end do
    end if
 
    if(mhd_eta_hyper>zero) then
      if(slab_uniform) then
        dtnew=min(dtdiffpar*minval(dxarr(1:ndim))**4/mhd_eta_hyper,dtnew)
      else
        dtnew=min(dtdiffpar*minval(block%ds(ixo^s,1:ndim))**4/mhd_eta_hyper,dtnew)
      end if
    end if
 
    if(mhd_viscosity) then
      call viscosity_get_dt(wprim,ixi^l,ixo^l,dtnew,dx^d,x)
    end if
 
    if(mhd_gravity) then
      call gravity_get_dt(wprim,ixi^l,ixo^l,dtnew,dx^d,x)
    end if
 
    if(mhd_ambipolar_exp) then
      dtnew=min(dtdiffpar*get_ambipolar_dt(wprim,ixi^l,ixo^l,dx^d,x),dtnew)
    endif
 
    if (mhd_cak_force) then
      call cak_get_dt(wprim,ixi^l,ixo^l,dtnew,dx^d,x)
    end if
 
    if(mhd_radiation_fld) then
      call fld_radforce_get_dt(wprim,ixi^l,ixo^l,dtnew,dx^d,x,fld_fl)
    endif
 
  end subroutine mhd_get_dt
 
  !> Wrappers for the FLD implicit (MG diffusion) hooks: phys_implicit_update /
  !> phys_evaluate_implicit have fixed interfaces with no fluid argument, so
  !> these inject the module's fld_fl object into the threaded fld routines.
  subroutine mhd_fld_implicit_update(dtfactor,qdt,qtC,psa,psb)
    use mod_global_parameters
    use mod_fld, only: fld_implicit_update
    type(state), target          :: psa(max_blocks)
    type(state), target          :: psb(max_blocks)
    double precision, intent(in) :: qdt
    double precision, intent(in) :: qtc
    double precision, intent(in) :: dtfactor
 
    call fld_implicit_update(dtfactor,qdt,qtc,psa,psb,fld_fl)
  end subroutine mhd_fld_implicit_update
 
  subroutine mhd_fld_evaluate_implicit(qtC,psa)
    use mod_global_parameters
    use mod_fld, only: fld_evaluate_implicit
    type(state), target          :: psa(max_blocks)
    double precision, intent(in) :: qtc
 
    call fld_evaluate_implicit(qtc,psa,fld_fl)
  end subroutine mhd_fld_evaluate_implicit
 
  ! Add geometrical source terms to w
  ! Geometric sources to momentum and induction
  ! for the regular case, not semi-relativistic, nor any splitting active
  ! but possibly no energy equation at all
  ! NOTE: Hall terms in induction not handled yet
  subroutine mhd_add_source_geom(qdt,dtfactor,ixI^L,ixO^L,wCT,wprim,w,x)
    use mod_global_parameters
    use mod_geometry
    use mod_rotating_frame, only: rotating_frame_add_source
    use mod_usr_methods, only: usr_set_adiab, usr_set_gamma
 
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(in)    :: qdt, dtfactor,x(ixi^s,1:ndim)
    double precision, intent(inout) :: wct(ixi^s,1:nw),wprim(ixi^s,1:nw),w(ixi^s,1:nw)
 
    double precision :: adiabs(ixi^s), gammas(ixi^s)
    double precision :: tmp,tmp1,invr,cot
    integer          :: ix^d
    integer :: mr_,mphi_ ! Polar var. names
    integer :: br_,bphi_
 
    mr_=mom(1); mphi_=mom(1)-1+phi_  ! Polar var. names
    br_=mag(1); bphi_=mag(1)-1+phi_
 
    if(.not.mhd_energy) then
      if(associated(usr_set_adiab)) then
         call usr_set_adiab(w,x,ixi^l,ixo^l,adiabs)
      else
         adiabs=mhd_adiab
      end if
      if(associated(usr_set_gamma)) then
         call usr_set_gamma(w,x,ixi^l,ixo^l,gammas)
      else
         gammas=eos%gamma
      end if
    end if
 
    select case (coordinate)
    case (cylindrical)
     {do ix^db=ixomin^db,ixomax^db\}
        ! include dt in invr, invr is always used with qdt
        if(local_timestep) then
          invr=block%dt(ix^d) * dtfactor/x(ix^d,1)
        else
          invr=qdt/x(ix^d,1)
        end if
        if(mhd_energy) then
          tmp=wprim(ix^d,p_)+half*(^c&wprim(ix^d,b^c_)**2+)
        else
          tmp=adiabs(ix^d)*wprim(ix^d,rho_)**gammas(ix^d)+half*(^c&wprim(ix^d,b^c_)**2+)
        end if
        if(phi_>0) then
          w(ix^d,mr_)=w(ix^d,mr_)+invr*(tmp-&
                    wprim(ix^d,bphi_)**2+wprim(ix^d,mphi_)*wct(ix^d,mphi_))
          w(ix^d,mphi_)=w(ix^d,mphi_)+invr*(&
                   -wct(ix^d,mphi_)*wprim(ix^d,mr_) &
                   +wprim(ix^d,bphi_)*wprim(ix^d,br_))
          if(.not.stagger_grid) then
            w(ix^d,bphi_)=w(ix^d,bphi_)+invr*&
                     (wprim(ix^d,bphi_)*wprim(ix^d,mr_) &
                     -wprim(ix^d,br_)*wprim(ix^d,mphi_))
          end if
        else
          w(ix^d,mr_)=w(ix^d,mr_)+invr*tmp
        end if
        if(mhd_glm) w(ix^d,br_)=w(ix^d,br_)+wprim(ix^d,psi_)*invr
     {end do\}
    case (spherical)
     {do ix^db=ixomin^db,ixomax^db\}
        ! include dt in invr, invr is always used with qdt
        if(local_timestep) then
          invr=block%dt(ix^d) * dtfactor/x(ix^d,1)
        else
          invr=qdt/x(ix^d,1)
        end if
        if(mhd_energy) then
          tmp1=wprim(ix^d,p_)+half*(^c&wprim(ix^d,b^c_)**2+)
        else
          tmp1=adiabs(ix^d)*wprim(ix^d,rho_)**gammas(ix^d)+half*(^c&wprim(ix^d,b^c_)**2+)
        end if
        ! m1
        {^ifonec
        w(ix^d,mom(1))=w(ix^d,mom(1))+two*tmp1*invr
        }
        {^noonec
        w(ix^d,mom(1))=w(ix^d,mom(1))+invr*&
         (two*tmp1+(^ce&wprim(ix^d,m^ce_)*wct(ix^d,m^ce_)-wprim(ix^d,b^ce_)**2+))
        }
        ! b1
        if(mhd_glm) then
          w(ix^d,mag(1))=w(ix^d,mag(1))+invr*2.0d0*wprim(ix^d,psi_)
        end if
        {^ifoned
        cot=0.d0
        }
        {^nooned
        cot=1.d0/tan(x(ix^d,2))
        }
        {^iftwoc
        ! m2
        w(ix^d,mom(2))=w(ix^d,mom(2))+invr*(tmp1*cot-wprim(ix^d,m1_)*wct(ix^d,m2_)&
          +wprim(ix^d,b1_)*wprim(ix^d,b2_))
        ! b2
        if(.not.stagger_grid) then
          tmp=wprim(ix^d,m1_)*wprim(ix^d,b2_)-wprim(ix^d,m2_)*wprim(ix^d,b1_)
          if(mhd_glm) then
            tmp=tmp+wprim(ix^d,psi_)*cot
          end if
          w(ix^d,mag(2))=w(ix^d,mag(2))+tmp*invr
        end if
        }
        {^ifthreec
        ! m2
        w(ix^d,mom(2))=w(ix^d,mom(2))+invr*(tmp1*cot-wprim(ix^d,m1_)*wct(ix^d,m2_)&
          +wprim(ix^d,b1_)*wprim(ix^d,b2_)&
          +(wprim(ix^d,m3_)*wct(ix^d,m3_)-wprim(ix^d,b3_)**2)*cot)
        ! b2
        if(.not.stagger_grid) then
          tmp=wprim(ix^d,m1_)*wprim(ix^d,b2_)-wprim(ix^d,m2_)*wprim(ix^d,b1_)
          if(mhd_glm) then
            tmp=tmp+wprim(ix^d,psi_)*cot
          end if
          w(ix^d,mag(2))=w(ix^d,mag(2))+tmp*invr
        end if
        ! m3
        w(ix^d,mom(3))=w(ix^d,mom(3))-invr*&
             (wprim(ix^d,m3_)*wct(ix^d,m1_) &
             -wprim(ix^d,b3_)*wprim(ix^d,b1_) &
            +(wprim(ix^d,m2_)*wct(ix^d,m3_) &
             -wprim(ix^d,b2_)*wprim(ix^d,b3_))*cot)
        ! b3
        if(.not.stagger_grid) then
          w(ix^d,mag(3))=w(ix^d,mag(3))+invr*&
             (wprim(ix^d,m1_)*wprim(ix^d,b3_) &
             -wprim(ix^d,m3_)*wprim(ix^d,b1_) &
            -(wprim(ix^d,m3_)*wprim(ix^d,b2_) &
             -wprim(ix^d,m2_)*wprim(ix^d,b3_))*cot)
        end if
        }
     {end do\}
    end select
 
    if (mhd_rotating_frame) then
       call rotating_frame_add_source(qdt,dtfactor,ixi^l,ixo^l,wprim,w,x)
    end if
 
  end subroutine mhd_add_source_geom
 
  ! Add geometrical source terms to w
  ! Geometric sources to momentum and induction
  ! for the semi-relativistic, hence no splitting active
  ! but possibly no energy equation at all
  ! NOTE: Hall terms in induction not handled yet
  subroutine mhd_add_source_geom_semirelati(qdt,dtfactor,ixI^L,ixO^L,wCT,wprim,w,x)
    use mod_global_parameters
    use mod_geometry
    use mod_rotating_frame, only: rotating_frame_add_source
    use mod_usr_methods, only: usr_set_adiab, usr_set_gamma
 
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(in)    :: qdt, dtfactor,x(ixi^s,1:ndim)
    double precision, intent(inout) :: wct(ixi^s,1:nw),wprim(ixi^s,1:nw),w(ixi^s,1:nw)
 
    double precision :: adiabs(ixi^s), gammas(ixi^s)
    double precision :: tmp,tmp1,tmp2,invr,cot,ef(ixo^s,1:ndir)
    integer          :: ix^d
    integer :: mr_,mphi_ ! Polar var. names
    integer :: br_,bphi_
 
    mr_=mom(1); mphi_=mom(1)-1+phi_  ! Polar var. names
    br_=mag(1); bphi_=mag(1)-1+phi_
 
    if(.not.mhd_energy) then
      if(associated(usr_set_adiab)) then
         call usr_set_adiab(w,x,ixi^l,ixo^l,adiabs)
      else
         adiabs=mhd_adiab
      end if
      if(associated(usr_set_gamma)) then
         call usr_set_gamma(w,x,ixi^l,ixo^l,gammas)
      else
         gammas=eos%gamma
      end if
    end if
 
    select case (coordinate)
    case (cylindrical)
     {do ix^db=ixomin^db,ixomax^db\}
        ! include dt in invr, invr is always used with qdt
        if(local_timestep) then
          invr=block%dt(ix^d) * dtfactor/x(ix^d,1)
        else
          invr=qdt/x(ix^d,1)
        end if
        if(mhd_energy) then
          tmp=wprim(ix^d,p_)
        else
          tmp=adiabs(ix^d)*wprim(ix^d,rho_)**gammas(ix^d)
        end if
        ! E=Bxv
        {^ifthreec
        ef(ix^d,1)=wprim(ix^d,b2_)*wprim(ix^d,m3_)-wprim(ix^d,b3_)*wprim(ix^d,m2_)
        ef(ix^d,2)=wprim(ix^d,b3_)*wprim(ix^d,m1_)-wprim(ix^d,b1_)*wprim(ix^d,m3_)
        ef(ix^d,3)=wprim(ix^d,b1_)*wprim(ix^d,m2_)-wprim(ix^d,b2_)*wprim(ix^d,m1_)
        }
        {^iftwoc
        ef(ix^d,1)=zero
        ! store e3 in e2 to count e3 when ^C is from 1 to 2
        ef(ix^d,2)=wprim(ix^d,b1_)*wprim(ix^d,m2_)-wprim(ix^d,b2_)*wprim(ix^d,m1_)
        }
        {^ifonec
        ef(ix^d,1)=zero
        }
        if(phi_>0) then
          w(ix^d,mr_)=w(ix^d,mr_)+invr*(tmp+&
           half*((^c&wprim(ix^d,b^c_)**2+)+(^c&ef(ix^d,^c)**2+)*inv_squared_c) -&
                    wprim(ix^d,bphi_)**2+wprim(ix^d,rho_)*wprim(ix^d,mphi_)**2)
          w(ix^d,mphi_)=w(ix^d,mphi_)+invr*(&
                   -wprim(ix^d,rho_)*wprim(ix^d,mphi_)*wprim(ix^d,mr_) &
                   +wprim(ix^d,bphi_)*wprim(ix^d,br_)+ef(ix^d,phi_)*ef(ix^d,1)*inv_squared_c)
          if(.not.stagger_grid) then
            w(ix^d,bphi_)=w(ix^d,bphi_)+invr*&
                     (wprim(ix^d,bphi_)*wprim(ix^d,mr_) &
                     -wprim(ix^d,br_)*wprim(ix^d,mphi_))
          end if
        else
          w(ix^d,mr_)=w(ix^d,mr_)+invr*(tmp+half*((^c&wprim(ix^d,b^c_)**2+)+&
             (^c&ef(ix^d,^c)**2+)*inv_squared_c))
        end if
        if(mhd_glm) w(ix^d,br_)=w(ix^d,br_)+wprim(ix^d,psi_)*invr
     {end do\}
    case (spherical)
     {do ix^db=ixomin^db,ixomax^db\}
        ! include dt in invr, invr is always used with qdt
        if(local_timestep) then
          invr=block%dt(ix^d)*dtfactor/x(ix^d,1)
        else
          invr=qdt/x(ix^d,1)
        end if
        ! E=Bxv
        {^ifthreec
        ef(ix^d,1)=wprim(ix^d,b2_)*wprim(ix^d,m3_)-wprim(ix^d,b3_)*wprim(ix^d,m2_)
        ef(ix^d,2)=wprim(ix^d,b3_)*wprim(ix^d,m1_)-wprim(ix^d,b1_)*wprim(ix^d,m3_)
        ef(ix^d,3)=wprim(ix^d,b1_)*wprim(ix^d,m2_)-wprim(ix^d,b2_)*wprim(ix^d,m1_)
        }
        {^iftwoc
        ! store e3 in e1 to count e3 when ^C is from 1 to 2
        ef(ix^d,1)=wprim(ix^d,b1_)*wprim(ix^d,m2_)-wprim(ix^d,b2_)*wprim(ix^d,m1_)
        ef(ix^d,2)=zero
        }
        {^ifonec
        ef(ix^d,1)=zero
        }
        if(mhd_energy) then
          tmp1=wprim(ix^d,p_)+half*((^c&wprim(ix^d,b^c_)**2+)+(^c&ef(ix^d,^c)**2+)*inv_squared_c)
        else
          tmp1=adiabs(ix^d)*wprim(ix^d,rho_)**gammas(ix^d)+half*((^c&wprim(ix^d,b^c_)**2+)+(^c&ef(ix^d,^c)**2+)*inv_squared_c)
        end if
        ! m1
        {^ifonec
        w(ix^d,m1_)=w(ix^d,m1_)+two*tmp1*invr
        }
        {^noonec
        w(ix^d,m1_)=w(ix^d,m1_)+invr*&
           (two*tmp1+(^ce&wprim(ix^d,rho_)*wprim(ix^d,m^ce_)**2-&
            wprim(ix^d,b^ce_)**2-ef(ix^d,^ce)**2*inv_squared_c+))
        }
        ! b1
        if(mhd_glm) then
          w(ix^d,b1_)=w(ix^d,b1_)+invr*2.0d0*wprim(ix^d,psi_)
        end if
        {^ifoned
        cot=0.d0
        }
        {^nooned
        cot=1.d0/tan(x(ix^d,2))
        }
        {^iftwoc
        ! m2
        w(ix^d,m2_)=w(ix^d,m2_)+invr*(tmp1*cot-wprim(ix^d,rho_)*wprim(ix^d,m1_)*wprim(ix^d,m2_)&
            +wprim(ix^d,b1_)*wprim(ix^d,b2_)+ef(ix^d,1)*ef(ix^d,2)*inv_squared_c)
        ! b2
        if(.not.stagger_grid) then
          tmp=wprim(ix^d,m1_)*wprim(ix^d,b2_)-wprim(ix^d,m2_)*wprim(ix^d,b1_)
          if(mhd_glm) then
            tmp=tmp+wprim(ix^d,psi_)*cot
          end if
          w(ix^d,b2_)=w(ix^d,b2_)+tmp*invr
        end if
        }
 
        {^ifthreec
        ! m2
        w(ix^d,m2_)=w(ix^d,m2_)+invr*(tmp1*cot-wprim(ix^d,rho_)*wprim(ix^d,m1_)*wprim(ix^d,m2_) &
            +wprim(ix^d,b1_)*wprim(ix^d,b2_)+ef(ix^d,1)*ef(ix^d,2)*inv_squared_c&
            +(wprim(ix^d,rho_)*wprim(ix^d,m3_)**2&
            -wprim(ix^d,b3_)**2-ef(ix^d,3)**2*inv_squared_c)*cot)
        ! b2
        if(.not.stagger_grid) then
          tmp=wprim(ix^d,m1_)*wprim(ix^d,b2_)-wprim(ix^d,m2_)*wprim(ix^d,b1_)
          if(mhd_glm) then
            tmp=tmp+wprim(ix^d,psi_)*cot
          end if
          w(ix^d,b2_)=w(ix^d,b2_)+tmp*invr
        end if
        ! m3
        w(ix^d,m3_)=w(ix^d,m3_)+invr*&
            (-wprim(ix^d,m3_)*wprim(ix^d,m1_)*wprim(ix^d,rho_) &
             +wprim(ix^d,b3_)*wprim(ix^d,b1_) &
             +ef(ix^d,3)*ef(ix^d,1)*inv_squared_c&
           +(-wprim(ix^d,m2_)*wprim(ix^d,m3_)*wprim(ix^d,rho_) &
             +wprim(ix^d,b2_)*wprim(ix^d,b3_)&
             +ef(ix^d,2)*ef(ix^d,3)*inv_squared_c)*cot)
        ! b3
        if(.not.stagger_grid) then
          w(ix^d,b3_)=w(ix^d,b3_)+invr*&
             (wprim(ix^d,m1_)*wprim(ix^d,b3_) &
             -wprim(ix^d,m3_)*wprim(ix^d,b1_) &
            -(wprim(ix^d,m3_)*wprim(ix^d,b2_) &
             -wprim(ix^d,m2_)*wprim(ix^d,b3_))*cot)
        end if
        }
     {end do\}
    end select
 
    if (mhd_rotating_frame) then
       call rotating_frame_add_source(qdt,dtfactor,ixi^l,ixo^l,wprim,w,x)
    end if
 
  end subroutine mhd_add_source_geom_semirelati
 
  ! Add geometrical source terms to w
  ! Geometric sources to momentum and induction
  ! for those cases where any kind of splitting (B0field or has_equi_rho_and_p) is active
  ! This implies that there is an energy equation included for sure
  ! B0field impacts terms in induction equation and geometric sources for them
  ! both flags affect the terms in momentum equation, in three variants (TF, TT, FT)
  ! NOTE: Hall terms in induction not handled yet
  subroutine mhd_add_source_geom_split(qdt,dtfactor,ixI^L,ixO^L,wCT,wprim,w,x)
    use mod_global_parameters
    use mod_geometry
    use mod_rotating_frame, only: rotating_frame_add_source
    use mod_usr_methods, only: usr_set_adiab, usr_set_gamma
 
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(in)    :: qdt, dtfactor,x(ixi^s,1:ndim)
    double precision, intent(inout) :: wct(ixi^s,1:nw),wprim(ixi^s,1:nw),w(ixi^s,1:nw)
 
    double precision :: tmp,tmp1,tmp2,invr,cot
    double precision :: adiabs(ixi^s), gammas(ixi^s)
    integer          :: ix^d
    integer :: mr_,mphi_ ! Polar var. names
    integer :: br_,bphi_
 
    if(.not.mhd_energy) then
      if(associated(usr_set_adiab)) then
        call usr_set_adiab(wprim,x,ixi^l,ixo^l,adiabs)
      else
        adiabs=mhd_adiab
      end if
      if(associated(usr_set_gamma)) then
        call usr_set_gamma(wprim,x,ixi^l,ixo^l,gammas)
      else
        gammas=eos%gamma
      end if
    end if
 
    mr_=mom(1); mphi_=mom(1)-1+phi_  ! Polar var. names
    br_=mag(1); bphi_=mag(1)-1+phi_
 
 
    select case (coordinate)
    case (cylindrical)
     {do ix^db=ixomin^db,ixomax^db\}
        ! include dt in invr, invr is always used with qdt
        if(local_timestep) then
          invr=block%dt(ix^d) * dtfactor/x(ix^d,1)
        else
          invr=qdt/x(ix^d,1)
        end if
        if(mhd_energy) then
          tmp=wprim(ix^d,p_)+half*(^c&wprim(ix^d,b^c_)**2+)
        else
          tmp=adiabs(ix^d)*wprim(ix^d,rho_)**gammas(ix^d)+half*(^c&wprim(ix^d,b^c_)**2+)
        end if
        if(b0field) tmp=tmp+(^c&block%B0(ix^d,^c,0)*wprim(ix^d,b^c_)+)
        if(phi_>0) then
          w(ix^d,mr_)=w(ix^d,mr_)+invr*(tmp-&
                    wprim(ix^d,bphi_)**2+wprim(ix^d,mphi_)*wct(ix^d,mphi_))
          if(b0field) then
            w(ix^d,mr_)=w(ix^d,mr_)+invr*(-block%B0(ix^d,phi_,0)*wprim(ix^d,bphi_)-wprim(ix^d,bphi_)*block%B0(ix^d,phi_,0))
          endif
          w(ix^d,mphi_)=w(ix^d,mphi_)+invr*(&
                   -wct(ix^d,mphi_)*wprim(ix^d,mr_) &
                   +wprim(ix^d,bphi_)*wprim(ix^d,br_))
          if(b0field) then
            w(ix^d,mphi_)=w(ix^d,mphi_)+invr*(block%B0(ix^d,phi_,0)*wprim(ix^d,br_)+wprim(ix^d,bphi_)*block%B0(ix^d,r_,0))
          endif
          if(.not.stagger_grid) then
            w(ix^d,bphi_)=w(ix^d,bphi_)+invr*&
                     (wprim(ix^d,bphi_)*wprim(ix^d,mr_) &
                     -wprim(ix^d,br_)*wprim(ix^d,mphi_))
            if(b0field) then
              w(ix^d,bphi_)=w(ix^d,bphi_)+invr*&
                     (block%B0(ix^d,phi_,0)*wprim(ix^d,mr_) &
                     -block%B0(ix^d,r_,0)*wprim(ix^d,mphi_))
            endif
          end if
        else
          w(ix^d,mr_)=w(ix^d,mr_)+invr*tmp
        end if
        if(mhd_glm) w(ix^d,br_)=w(ix^d,br_)+wprim(ix^d,psi_)*invr
     {end do\}
    case (spherical)
     {do ix^db=ixomin^db,ixomax^db\}
        ! include dt in invr, invr is always used with qdt
        if(local_timestep) then
          invr=block%dt(ix^d) * dtfactor/x(ix^d,1)
        else
          invr=qdt/x(ix^d,1)
        end if
        tmp1=wprim(ix^d,p_)+half*(^c&wprim(ix^d,b^c_)**2+)
        if(b0field) tmp2=(^c&block%B0(ix^d,^c,0)*wprim(ix^d,b^c_)+)
        ! m1
        {^ifonec
        w(ix^d,mom(1))=w(ix^d,mom(1))+two*tmp1*invr
        if(b0field) w(ix^d,mom(1))=w(ix^d,mom(1))+two*tmp2*invr
        }
        {^noonec
        if(b0field) then
          w(ix^d,mom(1))=w(ix^d,mom(1))+invr*&
           (two*(tmp1+tmp2)+(^ce&wprim(ix^d,m^ce_)*wct(ix^d,m^ce_)-wprim(ix^d,b^ce_)**2+)- &
            (^ce&two*block%B0(ix^d,^ce,0)*wprim(ix^d,b^ce_)+))
        else
          w(ix^d,mom(1))=w(ix^d,mom(1))+invr*&
           (two*tmp1+(^ce&wprim(ix^d,m^ce_)*wct(ix^d,m^ce_)-wprim(ix^d,b^ce_)**2+))
        end if
        }
        ! b1
        if(mhd_glm) then
          w(ix^d,mag(1))=w(ix^d,mag(1))+invr*2.0d0*wprim(ix^d,psi_)
        end if
        {^ifoned
        cot=0.d0
        }
        {^nooned
        cot=1.d0/tan(x(ix^d,2))
        }
        {^iftwoc
        ! m2
        if(b0field) then
          w(ix^d,mom(2))=w(ix^d,mom(2))+invr*((tmp1+tmp2)*cot-wprim(ix^d,m1_)*wct(ix^d,m2_)&
            +wprim(ix^d,b1_)*wprim(ix^d,b2_)+block%B0(ix^d,1,0)*wprim(ix^d,b2_)&
            +wprim(ix^d,b1_)*block%B0(ix^d,2,0))
        else
          w(ix^d,mom(2))=w(ix^d,mom(2))+invr*(tmp1*cot-wprim(ix^d,m1_)*wct(ix^d,m2_)&
            +wprim(ix^d,b1_)*wprim(ix^d,b2_))
        end if
        ! b2
        if(.not.stagger_grid) then
          if(b0field) then
            tmp=wprim(ix^d,m1_)*wprim(ix^d,b2_)-wprim(ix^d,m2_)*wprim(ix^d,b1_)&
             +wprim(ix^d,m1_)*block%B0(ix^d,2,0)-wprim(ix^d,m2_)*block%B0(ix^d,1,0)
          else
            tmp=wprim(ix^d,m1_)*wprim(ix^d,b2_)-wprim(ix^d,m2_)*wprim(ix^d,b1_)
          end if
          if(mhd_glm) then
            tmp=tmp+wprim(ix^d,psi_)*cot
          end if
          w(ix^d,mag(2))=w(ix^d,mag(2))+tmp*invr
        end if
        }
        {^ifthreec
        ! m2
        if(b0field) then
          w(ix^d,mom(2))=w(ix^d,mom(2))+invr*((tmp1+tmp2)*cot-wprim(ix^d,m1_)*wct(ix^d,m2_)&
            +wprim(ix^d,b1_)*wprim(ix^d,b2_)+block%B0(ix^d,1,0)*wprim(ix^d,b2_)&
            +wprim(ix^d,b1_)*block%B0(ix^d,2,0)&
            +(wprim(ix^d,m3_)*wct(ix^d,m3_)-wprim(ix^d,b3_)**2-two*block%B0(ix^d,3,0)*wprim(ix^d,b3_))*cot)
        else
          w(ix^d,mom(2))=w(ix^d,mom(2))+invr*(tmp1*cot-wprim(ix^d,m1_)*wct(ix^d,m2_)&
            +wprim(ix^d,b1_)*wprim(ix^d,b2_)&
            +(wprim(ix^d,m3_)*wct(ix^d,m3_)-wprim(ix^d,b3_)**2)*cot)
        end if
        ! b2
        if(.not.stagger_grid) then
          if(b0field) then
            tmp=wprim(ix^d,m1_)*wprim(ix^d,b2_)-wprim(ix^d,m2_)*wprim(ix^d,b1_)&
             +wprim(ix^d,m1_)*block%B0(ix^d,2,0)-wprim(ix^d,m2_)*block%B0(ix^d,1,0)
          else
            tmp=wprim(ix^d,m1_)*wprim(ix^d,b2_)-wprim(ix^d,m2_)*wprim(ix^d,b1_)
          end if
          if(mhd_glm) then
            tmp=tmp+wprim(ix^d,psi_)*cot
          end if
          w(ix^d,mag(2))=w(ix^d,mag(2))+tmp*invr
        end if
        ! m3
        if(b0field) then
          w(ix^d,mom(3))=w(ix^d,mom(3))-invr*&
               (wprim(ix^d,m3_)*wct(ix^d,m1_) &
               -wprim(ix^d,b3_)*wprim(ix^d,b1_) &
            +block%B0(ix^d,1,0)*wprim(ix^d,b3_) &
            +wprim(ix^d,b1_)*block%B0(ix^d,3,0) &
              +(wprim(ix^d,m2_)*wct(ix^d,m3_) &
               -wprim(ix^d,b2_)*wprim(ix^d,b3_) &
            +block%B0(ix^d,2,0)*wprim(ix^d,b3_) &
            +wprim(ix^d,b2_)*block%B0(ix^d,3,0))*cot)
        else
          w(ix^d,mom(3))=w(ix^d,mom(3))-invr*&
               (wprim(ix^d,m3_)*wct(ix^d,m1_) &
               -wprim(ix^d,b3_)*wprim(ix^d,b1_) &
              +(wprim(ix^d,m2_)*wct(ix^d,m3_) &
               -wprim(ix^d,b2_)*wprim(ix^d,b3_))*cot)
        end if
        ! b3
        if(.not.stagger_grid) then
          if(b0field) then
            w(ix^d,mag(3))=w(ix^d,mag(3))+invr*&
               (wprim(ix^d,m1_)*wprim(ix^d,b3_) &
               -wprim(ix^d,m3_)*wprim(ix^d,b1_) &
            +wprim(ix^d,m1_)*block%B0(ix^d,3,0) &
            -wprim(ix^d,m3_)*block%B0(ix^d,1,0) &
              -(wprim(ix^d,m3_)*wprim(ix^d,b2_) &
               -wprim(ix^d,m2_)*wprim(ix^d,b3_) &
            +wprim(ix^d,m3_)*block%B0(ix^d,2,0) &
            -wprim(ix^d,m2_)*block%B0(ix^d,3,0))*cot)
          else
            w(ix^d,mag(3))=w(ix^d,mag(3))+invr*&
               (wprim(ix^d,m1_)*wprim(ix^d,b3_) &
               -wprim(ix^d,m3_)*wprim(ix^d,b1_) &
              -(wprim(ix^d,m3_)*wprim(ix^d,b2_) &
               -wprim(ix^d,m2_)*wprim(ix^d,b3_))*cot)
          end if
        end if
        }
     {end do\}
    end select
 
    if (mhd_rotating_frame) then
       call rotating_frame_add_source(qdt,dtfactor,ixi^l,ixo^l,wprim,w,x)
    end if
 
  end subroutine mhd_add_source_geom_split
 
  !> Compute 2 times total magnetic energy
  function mhd_mag_en_all(w, ixI^L, ixO^L) result(mge)
    use mod_global_parameters
    integer, intent(in)           :: ixi^l, ixo^l
    double precision, intent(in)  :: w(ixi^s, nw)
    double precision              :: mge(ixo^s)
 
    if (b0field) then
      mge = sum((w(ixo^s, mag(:))+block%B0(ixo^s,:,b0i))**2, dim=ndim+1)
    else
      mge = sum(w(ixo^s, mag(:))**2, dim=ndim+1)
    end if
  end function mhd_mag_en_all
 
  subroutine mhd_getv_hall(w,x,ixI^L,ixO^L,vHall,partial)
    use mod_global_parameters
    use mod_geometry
 
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(in)    :: w(ixi^s,nw)
    double precision, intent(in)    :: x(ixi^s,1:ndim)
    double precision, intent(inout) :: vhall(ixi^s,1:ndir)
    logical, intent(in), optional :: partial
 
    double precision :: current(ixi^s,7-2*ndir:3)
    double precision :: rho(ixi^s)
    integer          :: idir, idirmin, ix^d
    logical          :: use_partial
 
    use_partial=.false.
    if(present(partial)) use_partial=partial
    call mhd_get_rho(w,x,ixi^l,ixo^l,rho)
    if(.not.use_partial)then
       ! Calculate current density and idirmin, including J0 when split
       call get_current(w,ixi^l,ixo^l,idirmin,current)
    else
       if(slab_uniform) then
         ! fourth order CD in cartesian
         call curlvector(w(ixi^s,mag(1:ndir)),ixi^l,ixo^l,current,idirmin,7-2*ndir,ndir,.true.)
       else
         call curlvector(w(ixi^s,mag(1:ndir)),ixi^l,ixo^l,current,idirmin,7-2*ndir,ndir)
       endif
    endif
    do idir = idirmin, ndir
      {do ix^db=ixomin^db,ixomax^db\}
         vhall(ix^d,idir)=-mhd_etah*current(ix^d,idir)/rho(ix^d)
      {end do\}
    end do
 
  end subroutine mhd_getv_hall
 
  subroutine mhd_modify_wlr(ixI^L,ixO^L,qt,wLC,wRC,wLp,wRp,s,idir)
    use mod_global_parameters
    use mod_usr_methods
    integer, intent(in)             :: ixi^l, ixo^l, idir
    double precision, intent(in)    :: qt
    double precision, intent(inout) :: wlc(ixi^s,1:nw), wrc(ixi^s,1:nw)
    double precision, intent(inout) :: wlp(ixi^s,1:nw), wrp(ixi^s,1:nw)
    type(state)                     :: s
 
    double precision                :: db(ixo^s), dpsi(ixo^s)
    integer :: ix^d
 
    if(stagger_grid) then
     {do ix^db=ixomin^db,ixomax^db\}
        wlc(ix^d,mag(idir))=s%ws(ix^d,idir)
        wrc(ix^d,mag(idir))=s%ws(ix^d,idir)
        wlp(ix^d,mag(idir))=s%ws(ix^d,idir)
        wrp(ix^d,mag(idir))=s%ws(ix^d,idir)
     {end do\}
    else
      ! Solve the Riemann problem for the linear 2x2 system for normal
      ! B-field and GLM_Psi according to Dedner 2002:
      ! This implements eq. (42) in Dedner et al. 2002 JcP 175
      ! Gives the Riemann solution on the interface
      ! for the normal B component and Psi in the GLM-MHD system.
      ! 23/04/2013 Oliver Porth
     {do ix^db=ixomin^db,ixomax^db\}
        db(ix^d)=wrp(ix^d,mag(idir))-wlp(ix^d,mag(idir))
        dpsi(ix^d)=wrp(ix^d,psi_)-wlp(ix^d,psi_)
        wlp(ix^d,mag(idir))=half*(wrp(ix^d,mag(idir))+wlp(ix^d,mag(idir))-dpsi(ix^d)/cmax_global)
        wlp(ix^d,psi_)=half*(wrp(ix^d,psi_)+wlp(ix^d,psi_)-db(ix^d)*cmax_global)
        wrp(ix^d,mag(idir))=wlp(ix^d,mag(idir))
        wrp(ix^d,psi_)=wlp(ix^d,psi_)
        if(total_energy) then
          wrc(ix^d,e_)=wrc(ix^d,e_)-half*wrc(ix^d,mag(idir))**2
          wlc(ix^d,e_)=wlc(ix^d,e_)-half*wlc(ix^d,mag(idir))**2
        end if
        wrc(ix^d,mag(idir))=wlp(ix^d,mag(idir))
        wrc(ix^d,psi_)=wlp(ix^d,psi_)
        wlc(ix^d,mag(idir))=wlp(ix^d,mag(idir))
        wlc(ix^d,psi_)=wlp(ix^d,psi_)
        ! modify total energy according to the change of magnetic field
        if(total_energy) then
          wrc(ix^d,e_)=wrc(ix^d,e_)+half*wrc(ix^d,mag(idir))**2
          wlc(ix^d,e_)=wlc(ix^d,e_)+half*wlc(ix^d,mag(idir))**2
        end if
     {end do\}
    end if
 
    if(associated(usr_set_wlr)) call usr_set_wlr(ixi^l,ixo^l,qt,wlc,wrc,wlp,wrp,s,idir)
 
  end subroutine mhd_modify_wlr
 
  subroutine mhd_boundary_adjust(igrid,psb)
    use mod_global_parameters
    integer, intent(in) :: igrid
    type(state), target :: psb(max_blocks)
 
    integer :: ib, idims, iside, ixo^l, i^d
 
    block=>ps(igrid)
    ^d&dxlevel(^d)=rnode(rpdx^d_,igrid);
    do idims=1,ndim
       ! to avoid using as yet unknown corner info in more than 1D, we
       ! fill only interior mesh ranges of the ghost cell ranges at first,
       ! and progressively enlarge the ranges to include corners later
       do iside=1,2
          i^d=kr(^d,idims)*(2*iside-3);
          if (neighbor_type(i^d,igrid)/=1) cycle
          ib=(idims-1)*2+iside
          if(.not.boundary_divbfix(ib)) cycle
          if(any(typeboundary(:,ib)==bc_special)) then
            ! MF nonlinear force-free B field extrapolation and data driven
            ! require normal B of the first ghost cell layer to be untouched by
            ! fixdivB=0 process, set boundary_divbfix_skip(iB)=1 in par file
            select case (idims)
            {case (^d)
               if (iside==2) then
                  ! maximal boundary
                  ixomin^dd=ixghi^d+1-nghostcells+boundary_divbfix_skip(2*^d)^d%ixOmin^dd=ixglo^dd;
                  ixomax^dd=ixghi^dd;
               else
                  ! minimal boundary
                  ixomin^dd=ixglo^dd;
                  ixomax^dd=ixglo^d-1+nghostcells-boundary_divbfix_skip(2*^d-1)^d%ixOmax^dd=ixghi^dd;
               end if \}
            end select
            call fixdivb_boundary(ixg^ll,ixo^l,psb(igrid)%w,psb(igrid)%x,ib)
          end if
       end do
    end do
 
  end subroutine mhd_boundary_adjust
 
  subroutine fixdivb_boundary(ixG^L,ixO^L,w,x,iB)
    use mod_global_parameters
 
    integer, intent(in) :: ixg^l,ixo^l,ib
    double precision, intent(inout) :: w(ixg^s,1:nw)
    double precision, intent(in) :: x(ixg^s,1:ndim)
 
    double precision :: dx1x2,dx1x3,dx2x1,dx2x3,dx3x1,dx3x2
    integer :: ix^d,ixf^l
 
    select case(ib)
     case(1)
       ! 2nd order CD for divB=0 to set normal B component better
      !  if(total_energy) call eos%to_primitive(ixG^L,ixO^L,w,x)
       if(total_energy) call eos%to_primitive(ixg^l,ixo^l,w,x)
       {^iftwod
       ixfmin1=ixomin1+1
       ixfmax1=ixomax1+1
       ixfmin2=ixomin2+1
       ixfmax2=ixomax2-1
       if(slab_uniform) then
         dx1x2=dxlevel(1)/dxlevel(2)
         do ix1=ixfmax1,ixfmin1,-1
           w(ix1-1,ixfmin2:ixfmax2,mag(1))=w(ix1+1,ixfmin2:ixfmax2,mag(1)) &
            +dx1x2*(w(ix1,ixfmin2+1:ixfmax2+1,mag(2))-&
                    w(ix1,ixfmin2-1:ixfmax2-1,mag(2)))
         enddo
       else
         do ix1=ixfmax1,ixfmin1,-1
           w(ix1-1,ixfmin2:ixfmax2,mag(1))=( (w(ix1+1,ixfmin2:ixfmax2,mag(1))+&
             w(ix1,ixfmin2:ixfmax2,mag(1)))*block%surfaceC(ix1,ixfmin2:ixfmax2,1)&
           +(w(ix1,ixfmin2+1:ixfmax2+1,mag(2))+w(ix1,ixfmin2:ixfmax2,mag(2)))*&
             block%surfaceC(ix1,ixfmin2:ixfmax2,2)&
           -(w(ix1,ixfmin2:ixfmax2,mag(2))+w(ix1,ixfmin2-1:ixfmax2-1,mag(2)))*&
             block%surfaceC(ix1,ixfmin2-1:ixfmax2-1,2) )&
            /block%surfaceC(ix1-1,ixfmin2:ixfmax2,1)-w(ix1,ixfmin2:ixfmax2,mag(1))
         end do
       end if
       }
       {^ifthreed
       ixfmin1=ixomin1+1
       ixfmax1=ixomax1+1
       ixfmin2=ixomin2+1
       ixfmax2=ixomax2-1
       ixfmin3=ixomin3+1
       ixfmax3=ixomax3-1
       if(slab_uniform) then
         dx1x2=dxlevel(1)/dxlevel(2)
         dx1x3=dxlevel(1)/dxlevel(3)
         do ix1=ixfmax1,ixfmin1,-1
           w(ix1-1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))=&
                     w(ix1+1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1)) &
             +dx1x2*(w(ix1,ixfmin2+1:ixfmax2+1,ixfmin3:ixfmax3,mag(2))-&
                     w(ix1,ixfmin2-1:ixfmax2-1,ixfmin3:ixfmax3,mag(2))) &
             +dx1x3*(w(ix1,ixfmin2:ixfmax2,ixfmin3+1:ixfmax3+1,mag(3))-&
                     w(ix1,ixfmin2:ixfmax2,ixfmin3-1:ixfmax3-1,mag(3)))
         end do
       else
         do ix1=ixfmax1,ixfmin1,-1
           w(ix1-1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))=&
          ( (w(ix1+1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))+&
             w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1)))*&
             block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,1)&
           +(w(ix1,ixfmin2+1:ixfmax2+1,ixfmin3:ixfmax3,mag(2))+&
             w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(2)))*&
             block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,2)&
           -(w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(2))+&
             w(ix1,ixfmin2-1:ixfmax2-1,ixfmin3:ixfmax3,mag(2)))*&
             block%surfaceC(ix1,ixfmin2-1:ixfmax2-1,ixfmin3:ixfmax3,2)&
           +(w(ix1,ixfmin2:ixfmax2,ixfmin3+1:ixfmax3+1,mag(3))+&
             w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(3)))*&
             block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,3)&
           -(w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(3))+&
             w(ix1,ixfmin2:ixfmax2,ixfmin3-1:ixfmax3-1,mag(3)))*&
             block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3-1:ixfmax3-1,3) )&
            /block%surfaceC(ix1-1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,1)-&
             w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))
         end do
       end if
       }
      !  if(total_energy) call eos%to_conserved(ixG^L,ixO^L,w,x)
       if(total_energy) call eos%to_conserved(ixg^l,ixo^l,w,x)
     case(2)
      !  if(total_energy) call eos%to_primitive(ixG^L,ixO^L,w,x)
       if(total_energy) call eos%to_primitive(ixg^l,ixo^l,w,x)
       {^iftwod
       ixfmin1=ixomin1-1
       ixfmax1=ixomax1-1
       ixfmin2=ixomin2+1
       ixfmax2=ixomax2-1
       if(slab_uniform) then
         dx1x2=dxlevel(1)/dxlevel(2)
         do ix1=ixfmin1,ixfmax1
           w(ix1+1,ixfmin2:ixfmax2,mag(1))=w(ix1-1,ixfmin2:ixfmax2,mag(1)) &
            -dx1x2*(w(ix1,ixfmin2+1:ixfmax2+1,mag(2))-&
                    w(ix1,ixfmin2-1:ixfmax2-1,mag(2)))
         enddo
       else
         do ix1=ixfmin1,ixfmax1
           w(ix1+1,ixfmin2:ixfmax2,mag(1))=( (w(ix1-1,ixfmin2:ixfmax2,mag(1))+&
             w(ix1,ixfmin2:ixfmax2,mag(1)))*block%surfaceC(ix1-1,ixfmin2:ixfmax2,1)&
           -(w(ix1,ixfmin2+1:ixfmax2+1,mag(2))+w(ix1,ixfmin2:ixfmax2,mag(2)))*&
             block%surfaceC(ix1,ixfmin2:ixfmax2,2)&
           +(w(ix1,ixfmin2:ixfmax2,mag(2))+w(ix1,ixfmin2-1:ixfmax2-1,mag(2)))*&
             block%surfaceC(ix1,ixfmin2-1:ixfmax2-1,2) )&
            /block%surfaceC(ix1,ixfmin2:ixfmax2,1)-w(ix1,ixfmin2:ixfmax2,mag(1))
         end do
       end if
       }
       {^ifthreed
       ixfmin1=ixomin1-1
       ixfmax1=ixomax1-1
       ixfmin2=ixomin2+1
       ixfmax2=ixomax2-1
       ixfmin3=ixomin3+1
       ixfmax3=ixomax3-1
       if(slab_uniform) then
         dx1x2=dxlevel(1)/dxlevel(2)
         dx1x3=dxlevel(1)/dxlevel(3)
         do ix1=ixfmin1,ixfmax1
           w(ix1+1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))=&
                     w(ix1-1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1)) &
             -dx1x2*(w(ix1,ixfmin2+1:ixfmax2+1,ixfmin3:ixfmax3,mag(2))-&
                     w(ix1,ixfmin2-1:ixfmax2-1,ixfmin3:ixfmax3,mag(2))) &
             -dx1x3*(w(ix1,ixfmin2:ixfmax2,ixfmin3+1:ixfmax3+1,mag(3))-&
                     w(ix1,ixfmin2:ixfmax2,ixfmin3-1:ixfmax3-1,mag(3)))
         end do
       else
         do ix1=ixfmin1,ixfmax1
           w(ix1+1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))=&
          ( (w(ix1-1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))+&
             w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1)))*&
             block%surfaceC(ix1-1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,1)&
           -(w(ix1,ixfmin2+1:ixfmax2+1,ixfmin3:ixfmax3,mag(2))+&
             w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(2)))*&
             block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,2)&
           +(w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(2))+&
             w(ix1,ixfmin2-1:ixfmax2-1,ixfmin3:ixfmax3,mag(2)))*&
             block%surfaceC(ix1,ixfmin2-1:ixfmax2-1,ixfmin3:ixfmax3,2)&
           -(w(ix1,ixfmin2:ixfmax2,ixfmin3+1:ixfmax3+1,mag(3))+&
             w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(3)))*&
             block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,3)&
           +(w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(3))+&
             w(ix1,ixfmin2:ixfmax2,ixfmin3-1:ixfmax3-1,mag(3)))*&
             block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3-1:ixfmax3-1,3) )&
            /block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,1)-&
             w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))
         end do
       end if
       }
      !  if(total_energy) call eos%to_conserved(ixG^L,ixO^L,w,x)
       if(total_energy) call eos%to_conserved(ixg^l,ixo^l,w,x)
     case(3)
      !  if(total_energy) call eos%to_primitive(ixG^L,ixO^L,w,x)
       if(total_energy) call eos%to_primitive(ixg^l,ixo^l,w,x)
       {^iftwod
       ixfmin1=ixomin1+1
       ixfmax1=ixomax1-1
       ixfmin2=ixomin2+1
       ixfmax2=ixomax2+1
       if(slab_uniform) then
         dx2x1=dxlevel(2)/dxlevel(1)
         do ix2=ixfmax2,ixfmin2,-1
           w(ixfmin1:ixfmax1,ix2-1,mag(2))=w(ixfmin1:ixfmax1,ix2+1,mag(2)) &
            +dx2x1*(w(ixfmin1+1:ixfmax1+1,ix2,mag(1))-&
                    w(ixfmin1-1:ixfmax1-1,ix2,mag(1)))
         enddo
       else
         do ix2=ixfmax2,ixfmin2,-1
           w(ixfmin1:ixfmax1,ix2-1,mag(2))=( (w(ixfmin1:ixfmax1,ix2+1,mag(2))+&
             w(ixfmin1:ixfmax1,ix2,mag(2)))*block%surfaceC(ixfmin1:ixfmax1,ix2,2)&
           +(w(ixfmin1+1:ixfmax1+1,ix2,mag(1))+w(ixfmin1:ixfmax1,ix2,mag(1)))*&
             block%surfaceC(ixfmin1:ixfmax1,ix2,1)&
           -(w(ixfmin1:ixfmax1,ix2,mag(1))+w(ixfmin1-1:ixfmax1-1,ix2,mag(1)))*&
             block%surfaceC(ixfmin1-1:ixfmax1-1,ix2,1) )&
            /block%surfaceC(ixfmin1:ixfmax1,ix2-1,2)-w(ixfmin1:ixfmax1,ix2,mag(2))
         end do
       end if
       }
       {^ifthreed
       ixfmin1=ixomin1+1
       ixfmax1=ixomax1-1
       ixfmin3=ixomin3+1
       ixfmax3=ixomax3-1
       ixfmin2=ixomin2+1
       ixfmax2=ixomax2+1
       if(slab_uniform) then
         dx2x1=dxlevel(2)/dxlevel(1)
         dx2x3=dxlevel(2)/dxlevel(3)
         do ix2=ixfmax2,ixfmin2,-1
           w(ixfmin1:ixfmax1,ix2-1,ixfmin3:ixfmax3,mag(2))=w(ixfmin1:ixfmax1,&
             ix2+1,ixfmin3:ixfmax3,mag(2)) &
             +dx2x1*(w(ixfmin1+1:ixfmax1+1,ix2,ixfmin3:ixfmax3,mag(1))-&
                     w(ixfmin1-1:ixfmax1-1,ix2,ixfmin3:ixfmax3,mag(1))) &
             +dx2x3*(w(ixfmin1:ixfmax1,ix2,ixfmin3+1:ixfmax3+1,mag(3))-&
                     w(ixfmin1:ixfmax1,ix2,ixfmin3-1:ixfmax3-1,mag(3)))
         end do
       else
         do ix2=ixfmax2,ixfmin2,-1
           w(ixfmin1:ixfmax1,ix2-1,ixfmin3:ixfmax3,mag(2))=&
          ( (w(ixfmin1:ixfmax1,ix2+1,ixfmin3:ixfmax3,mag(2))+&
             w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(2)))*&
             block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,2)&
           +(w(ixfmin1+1:ixfmax1+1,ix2,ixfmin3:ixfmax3,mag(1))+&
             w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(1)))*&
             block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,1)&
           -(w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(1))+&
             w(ixfmin1-1:ixfmax1-1,ix2,ixfmin3:ixfmax3,mag(1)))*&
             block%surfaceC(ixfmin1-1:ixfmax1-1,ix2,ixfmin3:ixfmax3,1)&
           +(w(ixfmin1:ixfmax1,ix2,ixfmin3+1:ixfmax3+1,mag(3))+&
             w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(3)))*&
             block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,3)&
           -(w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(3))+&
             w(ixfmin1:ixfmax1,ix2,ixfmin3-1:ixfmax3-1,mag(3)))*&
             block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3-1:ixfmax3-1,3) )&
            /block%surfaceC(ixfmin1:ixfmax1,ix2-1,ixfmin3:ixfmax3,2)-&
             w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(2))
         end do
       end if
       }
      !  if(total_energy) call eos%to_conserved(ixG^L,ixO^L,w,x)
       if(total_energy) call eos%to_conserved(ixg^l,ixo^l,w,x)
     case(4)
      !  if(total_energy) call eos%to_primitive(ixG^L,ixO^L,w,x)
       if(total_energy) call eos%to_primitive(ixg^l,ixo^l,w,x)
       {^iftwod
       ixfmin1=ixomin1+1
       ixfmax1=ixomax1-1
       ixfmin2=ixomin2-1
       ixfmax2=ixomax2-1
       if(slab_uniform) then
         dx2x1=dxlevel(2)/dxlevel(1)
         do ix2=ixfmin2,ixfmax2
           w(ixfmin1:ixfmax1,ix2+1,mag(2))=w(ixfmin1:ixfmax1,ix2-1,mag(2)) &
            -dx2x1*(w(ixfmin1+1:ixfmax1+1,ix2,mag(1))-&
                    w(ixfmin1-1:ixfmax1-1,ix2,mag(1)))
         end do
       else
         do ix2=ixfmin2,ixfmax2
           w(ixfmin1:ixfmax1,ix2+1,mag(2))=( (w(ixfmin1:ixfmax1,ix2-1,mag(2))+&
             w(ixfmin1:ixfmax1,ix2,mag(2)))*block%surfaceC(ixfmin1:ixfmax1,ix2-1,2)&
           -(w(ixfmin1+1:ixfmax1+1,ix2,mag(1))+w(ixfmin1:ixfmax1,ix2,mag(1)))*&
             block%surfaceC(ixfmin1:ixfmax1,ix2,1)&
           +(w(ixfmin1:ixfmax1,ix2,mag(1))+w(ixfmin1-1:ixfmax1-1,ix2,mag(1)))*&
             block%surfaceC(ixfmin1-1:ixfmax1-1,ix2,1) )&
            /block%surfaceC(ixfmin1:ixfmax1,ix2,2)-w(ixfmin1:ixfmax1,ix2,mag(2))
         end do
       end if
       }
       {^ifthreed
       ixfmin1=ixomin1+1
       ixfmax1=ixomax1-1
       ixfmin3=ixomin3+1
       ixfmax3=ixomax3-1
       ixfmin2=ixomin2-1
       ixfmax2=ixomax2-1
       if(slab_uniform) then
         dx2x1=dxlevel(2)/dxlevel(1)
         dx2x3=dxlevel(2)/dxlevel(3)
         do ix2=ixfmin2,ixfmax2
           w(ixfmin1:ixfmax1,ix2+1,ixfmin3:ixfmax3,mag(2))=w(ixfmin1:ixfmax1,&
             ix2-1,ixfmin3:ixfmax3,mag(2)) &
             -dx2x1*(w(ixfmin1+1:ixfmax1+1,ix2,ixfmin3:ixfmax3,mag(1))-&
                     w(ixfmin1-1:ixfmax1-1,ix2,ixfmin3:ixfmax3,mag(1))) &
             -dx2x3*(w(ixfmin1:ixfmax1,ix2,ixfmin3+1:ixfmax3+1,mag(3))-&
                     w(ixfmin1:ixfmax1,ix2,ixfmin3-1:ixfmax3-1,mag(3)))
         end do
       else
         do ix2=ixfmin2,ixfmax2
           w(ixfmin1:ixfmax1,ix2+1,ixfmin3:ixfmax3,mag(2))=&
          ( (w(ixfmin1:ixfmax1,ix2-1,ixfmin3:ixfmax3,mag(2))+&
             w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(2)))*&
             block%surfaceC(ixfmin1:ixfmax1,ix2-1,ixfmin3:ixfmax3,2)&
           -(w(ixfmin1+1:ixfmax1+1,ix2,ixfmin3:ixfmax3,mag(1))+&
             w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(1)))*&
             block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,1)&
           +(w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(1))+&
             w(ixfmin1-1:ixfmax1-1,ix2,ixfmin3:ixfmax3,mag(1)))*&
             block%surfaceC(ixfmin1-1:ixfmax1-1,ix2,ixfmin3:ixfmax3,1)&
           -(w(ixfmin1:ixfmax1,ix2,ixfmin3+1:ixfmax3+1,mag(3))+&
             w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(3)))*&
             block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,3)&
           +(w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(3))+&
             w(ixfmin1:ixfmax1,ix2,ixfmin3-1:ixfmax3-1,mag(3)))*&
             block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3-1:ixfmax3-1,3) )&
            /block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,2)-&
             w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(2))
         end do
       end if
       }
      !  if(total_energy) call eos%to_conserved(ixG^L,ixO^L,w,x)
       if(total_energy) call eos%to_conserved(ixg^l,ixo^l,w,x)
     {^ifthreed
     case(5)
      !  if(total_energy) call eos%to_primitive(ixG^L,ixO^L,w,x)
       if(total_energy) call eos%to_primitive(ixg^l,ixo^l,w,x)
       ixfmin1=ixomin1+1
       ixfmax1=ixomax1-1
       ixfmin2=ixomin2+1
       ixfmax2=ixomax2-1
       ixfmin3=ixomin3+1
       ixfmax3=ixomax3+1
       if(slab_uniform) then
         dx3x1=dxlevel(3)/dxlevel(1)
         dx3x2=dxlevel(3)/dxlevel(2)
         do ix3=ixfmax3,ixfmin3,-1
           w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3-1,mag(3))=w(ixfmin1:ixfmax1,&
             ixfmin2:ixfmax2,ix3+1,mag(3)) &
             +dx3x1*(w(ixfmin1+1:ixfmax1+1,ixfmin2:ixfmax2,ix3,mag(1))-&
                     w(ixfmin1-1:ixfmax1-1,ixfmin2:ixfmax2,ix3,mag(1))) &
             +dx3x2*(w(ixfmin1:ixfmax1,ixfmin2+1:ixfmax2+1,ix3,mag(2))-&
                     w(ixfmin1:ixfmax1,ixfmin2-1:ixfmax2-1,ix3,mag(2)))
         end do
       else
         do ix3=ixfmax3,ixfmin3,-1
           w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3-1,mag(3))=&
          ( (w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3+1,mag(3))+&
             w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(3)))*&
             block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,3)&
           +(w(ixfmin1+1:ixfmax1+1,ixfmin2:ixfmax2,ix3,mag(1))+&
             w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(1)))*&
             block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,1)&
           -(w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(1))+&
             w(ixfmin1-1:ixfmax1-1,ixfmin2:ixfmax2,ix3,mag(1)))*&
             block%surfaceC(ixfmin1-1:ixfmax1-1,ixfmin2:ixfmax2,ix3,1)&
           +(w(ixfmin1:ixfmax1,ixfmin2+1:ixfmax2+1,ix3,mag(2))+&
             w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(2)))*&
             block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,2)&
           -(w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(2))+&
             w(ixfmin1:ixfmax1,ixfmin2-1:ixfmax2-1,ix3,mag(2)))*&
             block%surfaceC(ixfmin1:ixfmax1,ixfmin2-1:ixfmax2-1,ix3,2) )&
            /block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3-1,3)-&
             w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(3))
         end do
       end if
      !  if(total_energy) call eos%to_conserved(ixG^L,ixO^L,w,x)
       if(total_energy) call eos%to_conserved(ixg^l,ixo^l,w,x)
     case(6)
      !  if(total_energy) call eos%to_primitive(ixG^L,ixO^L,w,x)
       if(total_energy) call eos%to_primitive(ixg^l,ixo^l,w,x)
       ixfmin1=ixomin1+1
       ixfmax1=ixomax1-1
       ixfmin2=ixomin2+1
       ixfmax2=ixomax2-1
       ixfmin3=ixomin3-1
       ixfmax3=ixomax3-1
       if(slab_uniform) then
         dx3x1=dxlevel(3)/dxlevel(1)
         dx3x2=dxlevel(3)/dxlevel(2)
         do ix3=ixfmin3,ixfmax3
           w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3+1,mag(3))=w(ixfmin1:ixfmax1,&
             ixfmin2:ixfmax2,ix3-1,mag(3)) &
             -dx3x1*(w(ixfmin1+1:ixfmax1+1,ixfmin2:ixfmax2,ix3,mag(1))-&
                     w(ixfmin1-1:ixfmax1-1,ixfmin2:ixfmax2,ix3,mag(1))) &
             -dx3x2*(w(ixfmin1:ixfmax1,ixfmin2+1:ixfmax2+1,ix3,mag(2))-&
                     w(ixfmin1:ixfmax1,ixfmin2-1:ixfmax2-1,ix3,mag(2)))
         end do
       else
         do ix3=ixfmin3,ixfmax3
           w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3+1,mag(3))=&
          ( (w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3-1,mag(3))+&
             w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(3)))*&
             block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3-1,3)&
           -(w(ixfmin1+1:ixfmax1+1,ixfmin2:ixfmax2,ix3,mag(1))+&
             w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(1)))*&
             block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,1)&
           +(w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(1))+&
             w(ixfmin1-1:ixfmax1-1,ixfmin2:ixfmax2,ix3,mag(1)))*&
             block%surfaceC(ixfmin1-1:ixfmax1-1,ixfmin2:ixfmax2,ix3,1)&
           -(w(ixfmin1:ixfmax1,ixfmin2+1:ixfmax2+1,ix3,mag(2))+&
             w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(2)))*&
             block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,2)&
           +(w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(2))+&
             w(ixfmin1:ixfmax1,ixfmin2-1:ixfmax2-1,ix3,mag(2)))*&
             block%surfaceC(ixfmin1:ixfmax1,ixfmin2-1:ixfmax2-1,ix3,2) )&
            /block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,3)-&
             w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(3))
         end do
       end if
      !  if(total_energy) call eos%to_conserved(ixG^L,ixO^L,w,x)
       if(total_energy) call eos%to_conserved(ixg^l,ixo^l,w,x)
     }
     case default
       call mpistop("Special boundary is not defined for this region")
    end select
 
  end subroutine fixdivb_boundary
 
  {^nooned
  subroutine mhd_clean_divb_multigrid(qdt, qt, active)
    use mod_forest
    use mod_global_parameters
    use mod_multigrid_coupling
    use mod_geometry
 
    double precision, intent(in) :: qdt    !< Current time step
    double precision, intent(in) :: qt     !< Current time
    logical, intent(inout)       :: active !< Output if the source is active
 
    integer                      :: id
    integer, parameter           :: max_its      = 50
    double precision             :: residual_it(max_its), max_divb
    double precision             :: tmp(ixg^t), grad(ixg^t, ndim)
    double precision             :: res
    double precision, parameter  :: max_residual = 1d-3
    double precision, parameter  :: residual_reduction = 1d-10
    integer                      :: iigrid, igrid
    integer                      :: n, nc, lvl, ix^l, ixc^l, idim
    type(tree_node), pointer     :: pnode
 
    mg%operator_type = mg_laplacian
 
    ! Set boundary conditions
    do n = 1, 2*ndim
       idim = (n+1)/2
       select case (typeboundary(mag(idim), n))
       case (bc_symm)
          ! d/dx B = 0, take phi = 0
          mg%bc(n, mg_iphi)%bc_type = mg_bc_dirichlet
          mg%bc(n, mg_iphi)%bc_value = 0.0_dp
       case (bc_asymm)
          ! B = 0, so grad(phi) = 0
          mg%bc(n, mg_iphi)%bc_type = mg_bc_neumann
          mg%bc(n, mg_iphi)%bc_value = 0.0_dp
       case (bc_cont)
          mg%bc(n, mg_iphi)%bc_type = mg_bc_dirichlet
          mg%bc(n, mg_iphi)%bc_value = 0.0_dp
       case (bc_special)
          ! Assume Dirichlet boundary conditions, derivative zero
          mg%bc(n, mg_iphi)%bc_type = mg_bc_dirichlet
          mg%bc(n, mg_iphi)%bc_value = 0.0_dp
       case (bc_periodic)
          ! Nothing to do here
       case default
          write(*,*) "mhd_clean_divb_multigrid warning: unknown boundary type"
          mg%bc(n, mg_iphi)%bc_type = mg_bc_dirichlet
          mg%bc(n, mg_iphi)%bc_value = 0.0_dp
       end select
    end do
 
    ix^l=ixm^ll^ladd1;
    max_divb = 0.0d0
 
    ! Store divergence of B as right-hand side
    do iigrid = 1, igridstail
       igrid =  igrids(iigrid);
       pnode => igrid_to_node(igrid, mype)%node
       id    =  pnode%id
       lvl   =  mg%boxes(id)%lvl
       nc    =  mg%box_size_lvl(lvl)
 
       ! Geometry subroutines expect this to be set
       block => ps(igrid)
       ^d&dxlevel(^d)=rnode(rpdx^d_,igrid);
 
       call get_divb(ps(igrid)%w(ixg^t, 1:nw), ixg^ll, ixm^ll, tmp, &
            mhd_divb_nth)
       mg%boxes(id)%cc({1:nc}, mg_irhs) = tmp(ixm^t)
       max_divb = max(max_divb, maxval(abs(tmp(ixm^t))))
    end do
 
    ! Solve laplacian(phi) = divB
    if(stagger_grid) then
      call mpi_allreduce(mpi_in_place, max_divb, 1, mpi_double_precision, &
           mpi_max, icomm, ierrmpi)
 
      if (mype == 0) print *, "Performing multigrid divB cleaning"
      if (mype == 0) print *, "iteration vs residual"
      ! Solve laplacian(phi) = divB
      do n = 1, max_its
         call mg_fas_fmg(mg, n>1, max_res=residual_it(n))
         if (mype == 0) write(*, "(I4,E11.3)") n, residual_it(n)
         if (residual_it(n) < residual_reduction * max_divb) exit
      end do
      if (mype == 0 .and. n > max_its) then
         print *, "divb_multigrid warning: not fully converged"
         print *, "current amplitude of divb: ", residual_it(max_its)
         print *, "multigrid smallest grid: ", &
              mg%domain_size_lvl(:, mg%lowest_lvl)
         print *, "note: smallest grid ideally has <= 8 cells"
         print *, "multigrid dx/dy/dz ratio: ", mg%dr(:, 1)/mg%dr(1, 1)
         print *, "note: dx/dy/dz should be similar"
      end if
    else
      do n = 1, max_its
         call mg_fas_vcycle(mg, max_res=res)
         if (res < max_residual) exit
      end do
      if (res > max_residual) call mpistop("divb_multigrid: no convergence")
    end if
 
 
    ! Correct the magnetic field
    do iigrid = 1, igridstail
       igrid = igrids(iigrid);
       pnode => igrid_to_node(igrid, mype)%node
       id    =  pnode%id
 
       ! Geometry subroutines expect this to be set
       block => ps(igrid)
       ^d&dxlevel(^d)=rnode(rpdx^d_,igrid);
 
       ! Compute the gradient of phi
       tmp(ix^s) = mg%boxes(id)%cc({:,}, mg_iphi)
 
       if(stagger_grid) then
         do idim =1, ndim
           ixcmin^d=ixmlo^d-kr(idim,^d);
           ixcmax^d=ixmhi^d;
           call gradientf(tmp,ps(igrid)%x,ixg^ll,ixc^l,idim,grad(ixg^t,idim))
           ! Apply the correction B* = B - gradient(phi)
           ps(igrid)%ws(ixc^s,idim)=ps(igrid)%ws(ixc^s,idim)-grad(ixc^s,idim)
         end do
         ! store cell-center magnetic energy
         tmp(ixm^t) = sum(ps(igrid)%w(ixm^t, mag(1:ndim))**2, dim=ndim+1)
         ! change cell-center magnetic field
         call mhd_face_to_center(ixm^ll,ps(igrid))
       else
         do idim = 1, ndim
            call gradient(tmp,ixg^ll,ixm^ll,idim,grad(ixg^t, idim))
         end do
         ! store cell-center magnetic energy
         tmp(ixm^t) = sum(ps(igrid)%w(ixm^t, mag(1:ndim))**2, dim=ndim+1)
         ! Apply the correction B* = B - gradient(phi)
         ps(igrid)%w(ixm^t, mag(1:ndim)) = &
              ps(igrid)%w(ixm^t, mag(1:ndim)) - grad(ixm^t, :)
       end if
 
       if(total_energy) then
         ! Determine magnetic energy difference
         tmp(ixm^t) = 0.5_dp * (sum(ps(igrid)%w(ixm^t, &
              mag(1:ndim))**2, dim=ndim+1) - tmp(ixm^t))
         ! Keep thermal pressure the same
         ps(igrid)%w(ixm^t, e_) = ps(igrid)%w(ixm^t, e_) + tmp(ixm^t)
       end if
    end do
 
    active = .true.
 
  end subroutine mhd_clean_divb_multigrid
  }
 
  !> get electric field through averaging neighors to update faces in CT
  subroutine mhd_update_faces_average(ixI^L,ixO^L,qt,qdt,wp,fC,fE,sCT,s,vcts)
    use mod_global_parameters
    use mod_usr_methods
 
    integer, intent(in)                :: ixi^l, ixo^l
    double precision, intent(in)       :: qt,qdt
    ! cell-center primitive variables
    double precision, intent(in)       :: wp(ixi^s,1:nw)
    type(state)                        :: sct, s
    type(ct_velocity)                  :: vcts
    double precision, intent(in)       :: fc(ixi^s,1:nwflux,1:ndim)
    double precision, intent(inout)    :: fe(ixi^s,sdim:3)
 
    double precision                   :: circ(ixi^s,1:ndim)
    ! non-ideal electric field on cell edges
    double precision, dimension(ixI^S,sdim:3) :: e_resi, e_ambi
    integer                            :: ix^d,ixc^l,ixa^l,i1kr^d,i2kr^d
    integer                            :: idim1,idim2,idir,iwdim1,iwdim2
 
    associate(bfaces=>s%ws,x=>s%x)
 
    ! Calculate contribution to FEM of each edge,
    ! that is, estimate value of line integral of
    ! electric field in the positive idir direction.
 
    ! if there is resistivity, get eta J
    if(mhd_eta/=zero) call get_resistive_electric_field(ixi^l,ixo^l,wp,sct,s,e_resi)
 
    ! if there is ambipolar diffusion, get E_ambi
    if(mhd_ambipolar_exp) call get_ambipolar_electric_field(ixi^l,ixo^l,sct%w,x,e_ambi)
 
    do idim1=1,ndim
      iwdim1 = mag(idim1)
      i1kr^d=kr(idim1,^d);
      do idim2=1,ndim
        iwdim2 = mag(idim2)
        i2kr^d=kr(idim2,^d);
        do idir=sdim,3! Direction of line integral
          ! Allow only even permutations
          if (lvc(idim1,idim2,idir)==1) then
            ixcmax^d=ixomax^d;
            ixcmin^d=ixomin^d+kr(idir,^d)-1;
            ! average cell-face electric field to cell edges
           {do ix^db=ixcmin^db,ixcmax^db\}
              fe(ix^d,idir)=quarter*&
                (fc(ix^d,iwdim1,idim2)+fc({ix^d+i1kr^d},iwdim1,idim2)&
                -fc(ix^d,iwdim2,idim1)-fc({ix^d+i2kr^d},iwdim2,idim1))
              ! add resistive electric field at cell edges E=-vxB+eta J
              if(mhd_eta/=zero) fe(ix^d,idir)=fe(ix^d,idir)+e_resi(ix^d,idir)
              ! add ambipolar electric field
              if(mhd_ambipolar_exp) fe(ix^d,idir)=fe(ix^d,idir)+e_ambi(ix^d,idir)
 
              ! times time step and edge length
              fe(ix^d,idir)=fe(ix^d,idir)*qdt*s%dsC(ix^d,idir)
           {end do\}
          end if
        end do
      end do
    end do
 
    ! allow user to change inductive electric field, especially for boundary driven applications
    if(associated(usr_set_electric_field)) &
      call usr_set_electric_field(ixi^l,ixo^l,qt,qdt,fe,sct)
 
    circ(ixi^s,1:ndim)=zero
 
    ! Calculate circulation on each face
    do idim1=1,ndim ! Coordinate perpendicular to face
      ixcmax^d=ixomax^d;
      ixcmin^d=ixomin^d-kr(idim1,^d);
      do idim2=1,ndim
        ixa^l=ixc^l-kr(idim2,^d);
        do idir=sdim,3 ! Direction of line integral
          ! Assemble indices
          if(lvc(idim1,idim2,idir)==1) then
            ! Add line integrals in direction idir
            circ(ixc^s,idim1)=circ(ixc^s,idim1)&
                             +(fe(ixc^s,idir)&
                              -fe(ixa^s,idir))
          else if(lvc(idim1,idim2,idir)==-1) then
            ! Add line integrals in direction idir
            circ(ixc^s,idim1)=circ(ixc^s,idim1)&
                             -(fe(ixc^s,idir)&
                              -fe(ixa^s,idir))
          end if
        end do
      end do
     {do ix^db=ixcmin^db,ixcmax^db\}
        ! Divide by the area of the face to get dB/dt
        if(s%surfaceC(ix^d,idim1) > smalldouble) then
          ! Time update cell-face magnetic field component
          bfaces(ix^d,idim1)=bfaces(ix^d,idim1)-circ(ix^d,idim1)/s%surfaceC(ix^d,idim1)
        end if
     {end do\}
    end do
 
    end associate
 
  end subroutine mhd_update_faces_average
 
  !> update faces using UCT contact mode by Gardiner and Stone 2005 JCP 205, 509
  subroutine mhd_update_faces_contact(ixI^L,ixO^L,qt,qdt,wp,fC,fE,sCT,s,vcts)
    use mod_global_parameters
    use mod_usr_methods
    use mod_geometry
 
    integer, intent(in)                :: ixi^l, ixo^l
    double precision, intent(in)       :: qt, qdt
    ! cell-center primitive variables
    double precision, intent(in)       :: wp(ixi^s,1:nw)
    type(state)                        :: sct, s
    type(ct_velocity)                  :: vcts
    double precision, intent(in)       :: fc(ixi^s,1:nwflux,1:ndim)
    double precision, intent(inout)    :: fe(ixi^s,sdim:3)
 
    double precision                   :: circ(ixi^s,1:ndim)
    ! electric field at cell centers
    double precision                   :: ecc(ixi^s,sdim:3)
    double precision                   :: ein(ixi^s,sdim:3)
    ! gradient of E at left and right side of a cell face
    double precision                   :: el(ixi^s),er(ixi^s)
    ! gradient of E at left and right side of a cell corner
    double precision                   :: elc,erc
    ! non-ideal electric field on cell edges
    double precision, dimension(ixI^S,sdim:3) :: e_resi, e_ambi
    ! current on cell edges
    double precision :: jce(ixi^s,sdim:3)
    ! location at cell faces
    double precision :: xs(ixgs^t,1:ndim)
    double precision :: gradi(ixgs^t)
    integer :: ixc^l,ixa^l
    integer :: idim1,idim2,idir,iwdim1,iwdim2,ix^d,i1kr^d,i2kr^d
 
    associate(bfaces=>s%ws,x=>s%x,w=>s%w,vnorm=>vcts%vnorm,wcts=>sct%ws)
 
    ! if there is resistivity, get eta J
    if(mhd_eta/=zero) call get_resistive_electric_field(ixi^l,ixo^l,wp,sct,s,e_resi)
 
    ! if there is ambipolar diffusion, get E_ambi
    if(mhd_ambipolar_exp) call get_ambipolar_electric_field(ixi^l,ixo^l,sct%w,x,e_ambi)
 
    if(b0field) then
     {do ix^db=iximin^db,iximax^db\}
        ! Calculate electric field at cell centers
       {^ifthreed
        ecc(ix^d,1)=(wp(ix^d,b2_)+block%B0(ix^d,2,0))*wp(ix^d,m3_)-(wp(ix^d,b3_)+block%B0(ix^d,3,0))*wp(ix^d,m2_)
        ecc(ix^d,2)=(wp(ix^d,b3_)+block%B0(ix^d,3,0))*wp(ix^d,m1_)-(wp(ix^d,b1_)+block%B0(ix^d,1,0))*wp(ix^d,m3_)
        ecc(ix^d,3)=(wp(ix^d,b1_)+block%B0(ix^d,1,0))*wp(ix^d,m2_)-(wp(ix^d,b2_)+block%B0(ix^d,2,0))*wp(ix^d,m1_)
       }
       {^iftwod
        ecc(ix^d,3)=wp(ix^d,b1_)*wp(ix^d,m2_)-wp(ix^d,b2_)*wp(ix^d,m1_)
       }
       {^ifoned
        ecc(ix^d,3)=0.d0
       }
     {end do\}
    else
     {do ix^db=iximin^db,iximax^db\}
        ! Calculate electric field at cell centers
       {^ifthreed
        ecc(ix^d,1)=wp(ix^d,b2_)*wp(ix^d,m3_)-wp(ix^d,b3_)*wp(ix^d,m2_)
        ecc(ix^d,2)=wp(ix^d,b3_)*wp(ix^d,m1_)-wp(ix^d,b1_)*wp(ix^d,m3_)
        ecc(ix^d,3)=wp(ix^d,b1_)*wp(ix^d,m2_)-wp(ix^d,b2_)*wp(ix^d,m1_)
       }
       {^iftwod
        ecc(ix^d,3)=wp(ix^d,b1_)*wp(ix^d,m2_)-wp(ix^d,b2_)*wp(ix^d,m1_)
       }
       {^ifoned
        ecc(ix^d,3)=0.d0
       }
     {end do\}
    end if
 
    ! Calculate contribution to FEM of each edge,
    ! that is, estimate value of line integral of
    ! electric field in the positive idir direction.
    ! evaluate electric field along cell edges according to equation (41)
    do idim1=1,ndim
      iwdim1 = mag(idim1)
      i1kr^d=kr(idim1,^d);
      do idim2=1,ndim
        iwdim2 = mag(idim2)
        i2kr^d=kr(idim2,^d);
        do idir=sdim,3 ! Direction of line integral
          ! Allow only even permutations
          if (lvc(idim1,idim2,idir)==1) then
            ixcmax^d=ixomax^d;
            ixcmin^d=ixomin^d+kr(idir,^d)-1;
            ! Assemble indices
            ! average cell-face electric field to cell edges
           {do ix^db=ixcmin^db,ixcmax^db\}
              fe(ix^d,idir)=quarter*&
              (fc(ix^d,iwdim1,idim2)+fc({ix^d+i1kr^d},iwdim1,idim2)&
              -fc(ix^d,iwdim2,idim1)-fc({ix^d+i2kr^d},iwdim2,idim1))
              if(numerical_resistive_heating) ein(ix^d,idir)=fe(ix^d,idir)
           {end do\}
            ! add slope in idim2 direction from equation (50)
            ixamin^d=ixcmin^d;
            ixamax^d=ixcmax^d+i1kr^d;
           {do ix^db=ixamin^db,ixamax^db\}
              el(ix^d)=fc(ix^d,iwdim1,idim2)-ecc(ix^d,idir)
              er(ix^d)=fc(ix^d,iwdim1,idim2)-ecc({ix^d+i2kr^d},idir)
           {end do\}
           {!dir$ ivdep
            do ix^db=ixcmin^db,ixcmax^db\}
              if(vnorm(ix^d,idim1)>0.d0) then
                elc=el(ix^d)
              else if(vnorm(ix^d,idim1)<0.d0) then
                elc=el({ix^d+i1kr^d})
              else
                elc=0.5d0*(el(ix^d)+el({ix^d+i1kr^d}))
              end if
              if(vnorm({ix^d+i2kr^d},idim1)>0.d0) then
                erc=er(ix^d)
              else if(vnorm({ix^d+i2kr^d},idim1)<0.d0) then
                erc=er({ix^d+i1kr^d})
              else
                erc=0.5d0*(er(ix^d)+er({ix^d+i1kr^d}))
              end if
              fe(ix^d,idir)=fe(ix^d,idir)+0.25d0*(elc+erc)
           {end do\}
 
            ! add slope in idim1 direction from equation (50)
            ixamin^d=ixcmin^d;
            ixamax^d=ixcmax^d+i2kr^d;
           {do ix^db=ixamin^db,ixamax^db\}
              el(ix^d)=-fc(ix^d,iwdim2,idim1)-ecc(ix^d,idir)
              er(ix^d)=-fc(ix^d,iwdim2,idim1)-ecc({ix^d+i1kr^d},idir)
           {end do\}
           {!dir$ ivdep
            do ix^db=ixcmin^db,ixcmax^db\}
              if(vnorm(ix^d,idim2)>0.d0) then
                elc=el(ix^d)
              else if(vnorm(ix^d,idim2)<0.d0) then
                elc=el({ix^d+i2kr^d})
              else
                elc=0.5d0*(el(ix^d)+el({ix^d+i2kr^d}))
              end if
              if(vnorm({ix^d+i1kr^d},idim2)>0.d0) then
                erc=er(ix^d)
              else if(vnorm({ix^d+i1kr^d},idim2)<0.d0) then
                erc=er({ix^d+i2kr^d})
              else
                erc=0.5d0*(er(ix^d)+er({ix^d+i2kr^d}))
              end if
              fe(ix^d,idir)=fe(ix^d,idir)+0.25d0*(elc+erc)
              ! difference between average and upwind interpolated E
              if(numerical_resistive_heating) ein(ix^d,idir)=fe(ix^d,idir)-ein(ix^d,idir)
              ! add resistive electric field at cell edges E=-vxB+eta J
              if(mhd_eta/=zero) fe(ix^d,idir)=fe(ix^d,idir)+e_resi(ix^d,idir)
              ! add ambipolar electric field
              if(mhd_ambipolar_exp) fe(ix^d,idir)=fe(ix^d,idir)+e_ambi(ix^d,idir)
 
              ! times time step and edge length
              fe(ix^d,idir)=fe(ix^d,idir)*qdt*s%dsC(ix^d,idir)
           {end do\}
          end if
        end do
      end do
    end do
 
    if(numerical_resistive_heating) then
      ! add upwind diffused magnetic energy back to energy
      ! calculate current density at cell edges
      jce=0.d0
      do idim1=1,ndim
        do idim2=1,ndim
          do idir=sdim,3
            if (lvc(idim1,idim2,idir)==0) cycle
            ixcmax^d=ixomax^d;
            ixcmin^d=ixomin^d+kr(idir,^d)-1;
            ixamax^d=ixcmax^d-kr(idir,^d)+1;
            ixamin^d=ixcmin^d;
            ! current at transverse faces
            xs(ixa^s,:)=x(ixa^s,:)
            xs(ixa^s,idim2)=x(ixa^s,idim2)+half*s%dx(ixa^s,idim2)
            call gradientf(wcts(ixgs^t,idim2),xs,ixgs^ll,ixc^l,idim1,gradi)
            if (lvc(idim1,idim2,idir)==1) then
              jce(ixc^s,idir)=jce(ixc^s,idir)+gradi(ixc^s)
            else
              jce(ixc^s,idir)=jce(ixc^s,idir)-gradi(ixc^s)
            end if
          end do
        end do
      end do
      do idir=sdim,3
        ixcmax^d=ixomax^d;
        ixcmin^d=ixomin^d+kr(idir,^d)-1;
        ! E dot J on cell edges
        ein(ixc^s,idir)=ein(ixc^s,idir)*jce(ixc^s,idir)
        ! average from cell edge to cell center
       {^ifthreed
        if(idir==1) then
         {do ix^db=ixomin^db,ixomax^db\}
            jce(ix^d,idir)=0.25d0*(ein(ix^d,idir)+ein(ix1,ix2-1,ix3,idir)+ein(ix1,ix2,ix3-1,idir)&
                          +ein(ix1,ix2-1,ix3-1,idir))
            if(jce(ix^d,idir)<0.d0) jce(ix^d,idir)=0.d0
            w(ix^d,e_)=w(ix^d,e_)+qdt*jce(ix^d,idir)
         {end do\}
        else if(idir==2) then
         {do ix^db=ixomin^db,ixomax^db\}
            jce(ix^d,idir)=0.25d0*(ein(ix^d,idir)+ein(ix1-1,ix2,ix3,idir)+ein(ix1,ix2,ix3-1,idir)&
                          +ein(ix1-1,ix2,ix3-1,idir))
            if(jce(ix^d,idir)<0.d0) jce(ix^d,idir)=0.d0
            w(ix^d,e_)=w(ix^d,e_)+qdt*jce(ix^d,idir)
         {end do\}
        else
         {do ix^db=ixomin^db,ixomax^db\}
            jce(ix^d,idir)=0.25d0*(ein(ix^d,idir)+ein(ix1-1,ix2,ix3,idir)+ein(ix1,ix2-1,ix3,idir)&
                          +ein(ix1-1,ix2-1,ix3,idir))
            if(jce(ix^d,idir)<0.d0) jce(ix^d,idir)=0.d0
            w(ix^d,e_)=w(ix^d,e_)+qdt*jce(ix^d,idir)
         {end do\}
        end if
       }
       {^iftwod
        !idir=3
       {do ix^db=ixomin^db,ixomax^db\}
          jce(ix^d,idir)=0.25d0*(ein(ix^d,idir)+ein(ix1-1,ix2,idir)+ein(ix1,ix2-1,idir)&
                        +ein(ix1-1,ix2-1,idir))
          if(jce(ix^d,idir)<0.d0) jce(ix^d,idir)=0.d0
          w(ix^d,e_)=w(ix^d,e_)+qdt*jce(ix^d,idir)
       {end do\}
       }
        ! save additional numerical resistive heating to an extra variable
       !! if(nwextra>0) then
       !!   block%w(ixO^S,nw)=block%w(ixO^S,nw)+jce(ixO^S,idir)
       !! end if
      end do
    end if
 
    ! allow user to change inductive electric field, especially for boundary driven applications
    if(associated(usr_set_electric_field)) &
      call usr_set_electric_field(ixi^l,ixo^l,qt,qdt,fe,sct)
 
    circ(ixi^s,1:ndim)=zero
 
    ! Calculate circulation on each face
    do idim1=1,ndim ! Coordinate perpendicular to face
      ixcmax^d=ixomax^d;
      ixcmin^d=ixomin^d-kr(idim1,^d);
      do idim2=1,ndim
        ixa^l=ixc^l-kr(idim2,^d);
        do idir=sdim,3 ! Direction of line integral
          ! Assemble indices
          if(lvc(idim1,idim2,idir)==1) then
            ! Add line integrals in direction idir
            circ(ixc^s,idim1)=circ(ixc^s,idim1)&
                             +(fe(ixc^s,idir)&
                              -fe(ixa^s,idir))
          else if(lvc(idim1,idim2,idir)==-1) then
            ! Add line integrals in direction idir
            circ(ixc^s,idim1)=circ(ixc^s,idim1)&
                             -(fe(ixc^s,idir)&
                              -fe(ixa^s,idir))
          end if
        end do
      end do
     {do ix^db=ixcmin^db,ixcmax^db\}
        ! Divide by the area of the face to get dB/dt
        if(s%surfaceC(ix^d,idim1) > smalldouble) then
          ! Time update cell-face magnetic field component
          bfaces(ix^d,idim1)=bfaces(ix^d,idim1)-circ(ix^d,idim1)/s%surfaceC(ix^d,idim1)
        end if
     {end do\}
    end do
 
    end associate
 
  end subroutine mhd_update_faces_contact
 
  !> update faces
  subroutine mhd_update_faces_hll(ixI^L,ixO^L,qt,qdt,wp,fC,fE,sCT,s,vcts)
    use mod_global_parameters
    use mod_usr_methods
    use mod_constrained_transport
 
    integer, intent(in)                :: ixi^l, ixo^l
    double precision, intent(in)       :: qt, qdt
    ! cell-center primitive variables
    double precision, intent(in)       :: wp(ixi^s,1:nw)
    type(state)                        :: sct, s
    type(ct_velocity)                  :: vcts
    double precision, intent(in)       :: fc(ixi^s,1:nwflux,1:ndim)
    double precision, intent(inout)    :: fe(ixi^s,sdim:3)
 
    double precision                   :: vtill(ixi^s,2)
    double precision                   :: vtilr(ixi^s,2)
    double precision                   :: bfacetot(ixi^s,ndim)
    double precision                   :: btill(ixi^s,ndim)
    double precision                   :: btilr(ixi^s,ndim)
    double precision                   :: cp(ixi^s,2)
    double precision                   :: cm(ixi^s,2)
    double precision                   :: circ(ixi^s,1:ndim)
    ! non-ideal electric field on cell edges
    double precision, dimension(ixI^S,sdim:3) :: e_resi, e_ambi
    integer                            :: hxc^l,ixc^l,ixcp^l,jxc^l,ixcm^l
    integer                            :: idim1,idim2,idir,ix^d
 
    associate(bfaces=>s%ws,bfacesct=>sct%ws,x=>s%x,vbarc=>vcts%vbarC,cbarmin=>vcts%cbarmin,&
      cbarmax=>vcts%cbarmax)
 
    ! Calculate contribution to FEM of each edge,
    ! that is, estimate value of line integral of
    ! electric field in the positive idir direction.
 
    ! Loop over components of electric field
 
    ! idir: electric field component we need to calculate
    ! idim1: directions in which we already performed the reconstruction
    ! idim2: directions in which we perform the reconstruction
 
    ! if there is resistivity, get eta J
    if(mhd_eta/=zero) call get_resistive_electric_field(ixi^l,ixo^l,wp,sct,s,e_resi)
 
    ! if there is ambipolar diffusion, get E_ambi
    if(mhd_ambipolar_exp) call get_ambipolar_electric_field(ixi^l,ixo^l,sct%w,x,e_ambi)
 
    do idir=sdim,3
      ! Indices
      ! idir: electric field component
      ! idim1: one surface
      ! idim2: the other surface
      ! cyclic permutation: idim1,idim2,idir=1,2,3
      ! Velocity components on the surface
      ! follow cyclic premutations:
      ! Sx(1),Sx(2)=y,z ; Sy(1),Sy(2)=z,x ; Sz(1),Sz(2)=x,y
 
      ixcmax^d=ixomax^d;
      ixcmin^d=ixomin^d-1+kr(idir,^d);
 
      ! Set indices and directions
      idim1=mod(idir,3)+1
      idim2=mod(idir+1,3)+1
 
      jxc^l=ixc^l+kr(idim1,^d);
      ixcp^l=ixc^l+kr(idim2,^d);
 
      ! Reconstruct transverse transport velocities
      call reconstruct(ixi^l,ixc^l,idim2,vbarc(ixi^s,idim1,1),&
               vtill(ixi^s,2),vtilr(ixi^s,2))
 
      call reconstruct(ixi^l,ixc^l,idim1,vbarc(ixi^s,idim2,2),&
               vtill(ixi^s,1),vtilr(ixi^s,1))
 
      ! Reconstruct magnetic fields
      ! Eventhough the arrays are larger, reconstruct works with
      ! the limits ixG.
      if(b0field) then
        bfacetot(ixi^s,idim1)=bfacesct(ixi^s,idim1)+block%B0(ixi^s,idim1,idim1)
        bfacetot(ixi^s,idim2)=bfacesct(ixi^s,idim2)+block%B0(ixi^s,idim2,idim2)
      else
        bfacetot(ixi^s,idim1)=bfacesct(ixi^s,idim1)
        bfacetot(ixi^s,idim2)=bfacesct(ixi^s,idim2)
      end if
      call reconstruct(ixi^l,ixc^l,idim2,bfacetot(ixi^s,idim1),&
               btill(ixi^s,idim1),btilr(ixi^s,idim1))
 
      call reconstruct(ixi^l,ixc^l,idim1,bfacetot(ixi^s,idim2),&
               btill(ixi^s,idim2),btilr(ixi^s,idim2))
 
      ! Take the maximum characteristic
 
      cm(ixc^s,1)=max(cbarmin(ixcp^s,idim1),cbarmin(ixc^s,idim1))
      cp(ixc^s,1)=max(cbarmax(ixcp^s,idim1),cbarmax(ixc^s,idim1))
 
      cm(ixc^s,2)=max(cbarmin(jxc^s,idim2),cbarmin(ixc^s,idim2))
      cp(ixc^s,2)=max(cbarmax(jxc^s,idim2),cbarmax(ixc^s,idim2))
     
 
      ! Calculate eletric field
      fe(ixc^s,idir)=-(cp(ixc^s,1)*vtill(ixc^s,1)*btill(ixc^s,idim2) &
                     + cm(ixc^s,1)*vtilr(ixc^s,1)*btilr(ixc^s,idim2) &
                     - cp(ixc^s,1)*cm(ixc^s,1)*(btilr(ixc^s,idim2)-btill(ixc^s,idim2)))&
                     /(cp(ixc^s,1)+cm(ixc^s,1)) &
                     +(cp(ixc^s,2)*vtill(ixc^s,2)*btill(ixc^s,idim1) &
                     + cm(ixc^s,2)*vtilr(ixc^s,2)*btilr(ixc^s,idim1) &
                     - cp(ixc^s,2)*cm(ixc^s,2)*(btilr(ixc^s,idim1)-btill(ixc^s,idim1)))&
                     /(cp(ixc^s,2)+cm(ixc^s,2))
 
      ! add resistive electric field at cell edges E=-vxB+eta J
      if(mhd_eta/=zero) fe(ixc^s,idir)=fe(ixc^s,idir)+e_resi(ixc^s,idir)
      ! add ambipolar electric field
      if(mhd_ambipolar_exp) fe(ixc^s,idir)=fe(ixc^s,idir)+e_ambi(ixc^s,idir)
 
      fe(ixc^s,idir)=qdt*s%dsC(ixc^s,idir)*fe(ixc^s,idir)
 
      if (.not.slab) then
        where(abs(x(ixc^s,r_)+half*dxlevel(r_)).lt.1.0d-9)
          fe(ixc^s,idir)=zero
        end where
      end if
 
    end do
 
    ! allow user to change inductive electric field, especially for boundary driven applications
    if(associated(usr_set_electric_field)) &
      call usr_set_electric_field(ixi^l,ixo^l,qt,qdt,fe,sct)
 
    circ(ixi^s,1:ndim)=zero
 
    ! Calculate circulation on each face: interal(fE dot dl)
    do idim1=1,ndim ! Coordinate perpendicular to face
      ixcmax^d=ixomax^d;
      ixcmin^d=ixomin^d-kr(idim1,^d);
      do idim2=1,ndim
        do idir=sdim,3 ! Direction of line integral
          ! Assemble indices
          if(lvc(idim1,idim2,idir)/=0) then
            hxc^l=ixc^l-kr(idim2,^d);
            ! Add line integrals in direction idir
            circ(ixc^s,idim1)=circ(ixc^s,idim1)&
                             +lvc(idim1,idim2,idir)&
                             *(fe(ixc^s,idir)&
                              -fe(hxc^s,idir))
          end if
        end do
      end do
     {do ix^db=ixcmin^db,ixcmax^db\}
        ! Divide by the area of the face to get dB/dt
        if(s%surfaceC(ix^d,idim1) > smalldouble) then
          ! Time update cell-face magnetic field component
          bfaces(ix^d,idim1)=bfaces(ix^d,idim1)-circ(ix^d,idim1)/s%surfaceC(ix^d,idim1)
        end if
     {end do\}
    end do
 
    end associate
  end subroutine mhd_update_faces_hll
 
  !> calculate eta J at cell edges
  subroutine get_resistive_electric_field(ixI^L,ixO^L,wp,sCT,s,jce)
    use mod_global_parameters
    use mod_usr_methods
    use mod_geometry
 
    integer, intent(in)                :: ixi^l, ixo^l
    ! cell-center primitive variables
    double precision, intent(in)       :: wp(ixi^s,1:nw)
    type(state), intent(in)            :: sct, s
    ! current on cell edges
    double precision :: jce(ixi^s,sdim:3)
 
    ! current on cell centers
    double precision :: jcc(ixi^s,7-2*ndir:3)
    ! location at cell faces
    double precision :: xs(ixgs^t,1:ndim)
    ! resistivity
    double precision :: eta(ixi^s)
    double precision :: gradi(ixgs^t)
    integer :: ix^d,ixc^l,ixa^l,ixb^l,idir,idirmin,idim1,idim2
 
    associate(x=>s%x,dx=>s%dx,w=>s%w,wct=>sct%w,wcts=>sct%ws)
    ! calculate current density at cell edges
    jce=0.d0
    do idim1=1,ndim
      do idim2=1,ndim
        do idir=sdim,3
          if (lvc(idim1,idim2,idir)==0) cycle
          ixcmax^d=ixomax^d;
          ixcmin^d=ixomin^d+kr(idir,^d)-1;
          ixbmax^d=ixcmax^d-kr(idir,^d)+1;
          ixbmin^d=ixcmin^d;
          ! current at transverse faces
          xs(ixb^s,:)=x(ixb^s,:)
          xs(ixb^s,idim2)=x(ixb^s,idim2)+half*dx(ixb^s,idim2)
          call gradientf(wcts(ixgs^t,idim2),xs,ixgs^ll,ixc^l,idim1,gradi,2)
          if (lvc(idim1,idim2,idir)==1) then
            jce(ixc^s,idir)=jce(ixc^s,idir)+gradi(ixc^s)
          else
            jce(ixc^s,idir)=jce(ixc^s,idir)-gradi(ixc^s)
          end if
        end do
      end do
    end do
    ! get resistivity
    if(mhd_eta>zero)then
      jce(ixi^s,:)=jce(ixi^s,:)*mhd_eta
    else
      ixa^l=ixo^l^ladd1;
      call get_current(wct,ixi^l,ixa^l,idirmin,jcc)
      call usr_special_resistivity(wp,ixi^l,ixa^l,idirmin,x,jcc,eta)
      ! calculate eta on cell edges
      do idir=sdim,3
        ixcmax^d=ixomax^d;
        ixcmin^d=ixomin^d+kr(idir,^d)-1;
        jcc(ixc^s,idir)=0.d0
       {do ix^db=0,1\}
          if({ ix^d==1 .and. ^d==idir | .or.}) cycle
          ixamin^d=ixcmin^d+ix^d;
          ixamax^d=ixcmax^d+ix^d;
          jcc(ixc^s,idir)=jcc(ixc^s,idir)+eta(ixa^s)
       {end do\}
        jcc(ixc^s,idir)=jcc(ixc^s,idir)*0.25d0
        jce(ixc^s,idir)=jce(ixc^s,idir)*jcc(ixc^s,idir)
      end do
    end if
 
    end associate
  end subroutine get_resistive_electric_field
 
  !> get ambipolar electric field on cell edges
  subroutine get_ambipolar_electric_field(ixI^L,ixO^L,w,x,fE)
    use mod_global_parameters
 
    integer, intent(in)                :: ixi^l, ixo^l
    double precision, intent(in)       :: w(ixi^s,1:nw)
    double precision, intent(in)       :: x(ixi^s,1:ndim)
    double precision, intent(out)      :: fe(ixi^s,sdim:3)
 
    double precision :: jxbxb(ixi^s,1:3)
    integer :: idir,ixa^l,ixc^l,ix^d
 
    ixa^l=ixo^l^ladd1;
    call mhd_get_jxbxb(w,x,ixi^l,ixa^l,jxbxb)
    ! calculate electric field on cell edges from cell centers
    do idir=sdim,3
      ! set ambipolar electric field in jxbxb: E=nuA * jxbxb, where nuA=-etaA/rho^2
      ! E_ambi(ixA^S,i) = -(mhd_eta_ambi/w(ixA^S, rho_)**2) * jxbxb(ixA^S,i)
      call multiplyambicoef(ixi^l,ixa^l,jxbxb(ixi^s,idir),w,x)
      ixcmax^d=ixomax^d;
      ixcmin^d=ixomin^d+kr(idir,^d)-1;
      fe(ixc^s,idir)=0.d0
     {do ix^db=0,1\}
        if({ ix^d==1 .and. ^d==idir | .or.}) cycle
        ixamin^d=ixcmin^d+ix^d;
        ixamax^d=ixcmax^d+ix^d;
        fe(ixc^s,idir)=fe(ixc^s,idir)+jxbxb(ixa^s,idir)
     {end do\}
      fe(ixc^s,idir)=fe(ixc^s,idir)*0.25d0
    end do
 
  end subroutine get_ambipolar_electric_field
 
  !> calculate cell-center values from face-center values
  subroutine mhd_face_to_center(ixO^L,s)
    use mod_global_parameters
    ! Non-staggered interpolation range
    integer, intent(in) :: ixo^l
    type(state) :: s
 
    integer :: ix^d
 
    ! calculate cell-center values from face-center values in 2nd order
    ! because the staggered arrays have an additional place to the left.
    ! Interpolate to cell barycentre using arithmetic average
    ! This might be done better later, to make the method less diffusive.
   {!dir$ ivdep
    do ix^db=ixomin^db,ixomax^db\}
      {^ifthreed
      s%w(ix^d,b1_)=half/s%surface(ix^d,1)*(s%ws(ix^d,1)*s%surfaceC(ix^d,1)&
        +s%ws(ix1-1,ix2,ix3,1)*s%surfaceC(ix1-1,ix2,ix3,1))
      s%w(ix^d,b2_)=half/s%surface(ix^d,2)*(s%ws(ix^d,2)*s%surfaceC(ix^d,2)&
        +s%ws(ix1,ix2-1,ix3,2)*s%surfaceC(ix1,ix2-1,ix3,2))
      s%w(ix^d,b3_)=half/s%surface(ix^d,3)*(s%ws(ix^d,3)*s%surfaceC(ix^d,3)&
        +s%ws(ix1,ix2,ix3-1,3)*s%surfaceC(ix1,ix2,ix3-1,3))
      }
      {^iftwod
      s%w(ix^d,b1_)=half/s%surface(ix^d,1)*(s%ws(ix^d,1)*s%surfaceC(ix^d,1)&
        +s%ws(ix1-1,ix2,1)*s%surfaceC(ix1-1,ix2,1))
      s%w(ix^d,b2_)=half/s%surface(ix^d,2)*(s%ws(ix^d,2)*s%surfaceC(ix^d,2)&
        +s%ws(ix1,ix2-1,2)*s%surfaceC(ix1,ix2-1,2))
      }
   {end do\}
 
    ! calculate cell-center values from face-center values in 4th order
    !do idim=1,ndim
    !  gxO^L=ixO^L-2*kr(idim,^D);
    !  hxO^L=ixO^L-kr(idim,^D);
    !  jxO^L=ixO^L+kr(idim,^D);
 
    !  ! Interpolate to cell barycentre using fourth order central formula
    !  w(ixO^S,mag(idim))=(0.0625d0/s%surface(ixO^S,idim))*&
    !         ( -ws(gxO^S,idim)*s%surfaceC(gxO^S,idim) &
    !     +9.0d0*ws(hxO^S,idim)*s%surfaceC(hxO^S,idim) &
    !     +9.0d0*ws(ixO^S,idim)*s%surfaceC(ixO^S,idim) &
    !           -ws(jxO^S,idim)*s%surfaceC(jxO^S,idim) )
    !end do
 
    ! calculate cell-center values from face-center values in 6th order
    !do idim=1,ndim
    !  fxO^L=ixO^L-3*kr(idim,^D);
    !  gxO^L=ixO^L-2*kr(idim,^D);
    !  hxO^L=ixO^L-kr(idim,^D);
    !  jxO^L=ixO^L+kr(idim,^D);
    !  kxO^L=ixO^L+2*kr(idim,^D);
 
    !  ! Interpolate to cell barycentre using sixth order central formula
    !  w(ixO^S,mag(idim))=(0.00390625d0/s%surface(ixO^S,idim))* &
    !     (  +3.0d0*ws(fxO^S,idim)*s%surfaceC(fxO^S,idim) &
    !       -25.0d0*ws(gxO^S,idim)*s%surfaceC(gxO^S,idim) &
    !      +150.0d0*ws(hxO^S,idim)*s%surfaceC(hxO^S,idim) &
    !      +150.0d0*ws(ixO^S,idim)*s%surfaceC(ixO^S,idim) &
    !       -25.0d0*ws(jxO^S,idim)*s%surfaceC(jxO^S,idim) &
    !        +3.0d0*ws(kxO^S,idim)*s%surfaceC(kxO^S,idim) )
    !end do
 
  end subroutine mhd_face_to_center
 
  !> calculate magnetic field from vector potential
  subroutine b_from_vector_potential(ixIs^L, ixI^L, ixO^L, ws, x)
    use mod_global_parameters
    use mod_constrained_transport
 
    integer, intent(in)                :: ixis^l, ixi^l, ixo^l
    double precision, intent(inout)    :: ws(ixis^s,1:nws)
    double precision, intent(in)       :: x(ixi^s,1:ndim)
 
    double precision                   :: adummy(ixis^s,1:3)
 
    call b_from_vector_potentiala(ixis^l, ixi^l, ixo^l, ws, x, adummy)
 
  end subroutine b_from_vector_potential
 
end module mod_mhd_phys