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_physics
 
  implicit none
  private
 
  !> Whether an energy equation is used
  logical, public, protected              :: mhd_energy = .true.
 
  !> Whether thermal conduction is used
  logical, public, protected              :: mhd_thermal_conduction = .false.
  !> type of fluid for thermal conduction
  type(tc_fluid), public, allocatable     :: tc_fl
  type(te_fluid), public, allocatable     :: te_fl_mhd
 
  !> Whether radiative cooling is added
  logical, public, protected              :: mhd_radiative_cooling = .false.
  !> type of fluid for radiative cooling
  type(rc_fluid), public, allocatable     :: rc_fl
 
  !> Whether viscosity is added
  logical, public, protected              :: mhd_viscosity = .false.
 
  !> Whether gravity is added
  logical, public, protected              :: mhd_gravity = .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
 
  !> Height of the mask used in the TRAC method
  double precision, public, protected     :: mhd_trac_mask = 0.d0
 
  !> Distance between two adjacent traced magnetic field lines (in finest cell size)
  integer, public, protected              :: mhd_trac_finegrid=4
 
  !> Whether auxiliary internal energy is solved
  logical, public, protected              :: mhd_solve_eaux = .false.
 
  !> Whether internal energy is solved instead of total energy
  logical, public, protected              :: mhd_internal_e = .false.
 
  !TODO this does not work with the splitting: check mhd_check_w_hde and mhd_handle_small_values_hde
  !> 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.
 
  !> 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
 
  !TODO this does not work with the splitting: check mhd_check_w_semirelati and mhd_handle_small_values_semirelati
  !> Whether semirelativistic MHD equations (Gombosi 2002 JCP) are solved
  logical, public, protected              :: mhd_semirelativistic = .false.
 
  !> Whether boris simplified semirelativistic MHD equations (Gombosi 2002 JCP) are solved
  logical, public, protected              :: mhd_boris_simplification = .false.
 
  !> Reduced speed of light for semirelativistic MHD
  double precision, public, protected     :: mhd_reduced_c = const_c
 
  !> Whether CAK radiation line force is activated
  logical, public, protected              :: mhd_cak_force = .false.
 
  !> MHD fourth order
  logical, public, protected              :: mhd_4th_order = .false.
 
  !> whether split off equilibrium density
  logical, public :: has_equi_rho0 = .false.
  !> whether split off equilibrium thermal pressure
  logical, public :: has_equi_pe0 = .false.
  logical, public :: mhd_equi_thermal = .false.
 
  !> equi vars indices in the state%equi_vars array
  integer, public :: equi_rho0_ = -1
  integer, public :: equi_pe0_ = -1
 
  !> whether dump full variables (when splitting is used) in a separate dat file
  logical, public, protected              :: mhd_dump_full_vars = .false.
 
  !> 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(:)
 
  !> Index of the energy density (-1 if not present)
  integer, public, protected              :: e_
 
  !> Index of the gas pressure (-1 if not present) should equal e_
  integer, public, protected              :: p_
 
  !> Indices of the magnetic field
  integer, allocatable, public, protected :: mag(:)
 
  !> Indices of the GLM psi
  integer, public, protected :: psi_
 
  !> Indices of auxiliary internal energy
  integer, public, protected :: eaux_
  integer, public, protected :: paux_
 
  !> 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 adiabatic index
  double precision, public                :: mhd_gamma = 5.d0/3.0d0
 
  !> 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
 
  !> TODO: what is this?
  double precision, public                :: mhd_etah = 0.0d0
 
  !> The MHD ambipolar coefficient
  double precision, public                :: mhd_eta_ambi = 0.0d0
 
  !> The small_est allowed energy
  double precision, protected             :: small_e
 
  !> The number of waves
  integer :: nwwave=8
 
  !> 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'
 
  !> Whether divB is computed with a fourth order approximation
  logical, public, protected :: mhd_divb_4thorder = .false.
 
  !> Method type in a integer for good performance
  integer :: type_divb
 
  !> Coefficient of diffusive divB cleaning
  double precision :: divbdiff     = 0.8d0
 
  !> Update all equations due to divB cleaning
  character(len=std_len) ::    typedivbdiff = 'all'
 
  !> Use a compact way to add resistivity
  logical :: compactres   = .false.
 
  !> Add divB wave in Roe solver
  logical, public :: divbwave     = .true.
 
  !> clean initial divB
  logical, public :: clean_initial_divb     = .false.
 
  !> Helium abundance over Hydrogen
  double precision, public, protected  :: he_abundance=0.1d0
  !> 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
  ! remove the below flag  and assume default value = .false.
  ! when eq state properly implemented everywhere
  ! and not anymore through units
  logical, public, protected :: eq_state_units = .true.
 
  !> To control divB=0 fix for boundary
  logical, public, protected :: boundary_divbfix(2*^nd)=.true.
 
  !> To skip * layer of ghost cells during divB=0 fix for boundary
  integer, public, protected :: boundary_divbfix_skip(2*^nd)=0
 
  !> B0 field is force-free
  logical, public, protected :: b0field_forcefree=.true.
 
  !> Whether an total energy equation is used
  logical :: total_energy = .true.
 
  !> Whether unsplit semirelativistic MHD is solved
  logical :: unsplit_semirelativistic=.false.
 
  !> Whether gravity work is included in energy equation
  logical :: gravity_energy
 
  !> gamma minus one and its inverse
  double precision :: gamma_1, inv_gamma_1
 
  !> inverse of squared speed of light c0 and reduced speed of light c
  double precision :: inv_squared_c0, inv_squared_c
 
  ! 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
 
  !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
 
    function fun_kin_en(w, ixI^L, ixO^L, inv_rho) result(ke)
      use mod_global_parameters, only: nw, ndim,block
      integer, intent(in)           :: ixI^L, ixO^L
      double precision, intent(in)  :: w(ixI^S, nw)
      double precision              :: ke(ixO^S)
      double precision, intent(in), optional :: inv_rho(ixO^S)
    end function fun_kin_en
 
  end interface
 
  procedure(mask_subroutine), pointer  :: usr_mask_ambipolar => null()
  procedure(sub_get_pthermal), pointer  :: usr_rfactor => null()
  procedure(sub_convert), pointer      :: mhd_to_primitive  => null()
  procedure(sub_convert), pointer      :: mhd_to_conserved  => null()
  procedure(sub_small_values), pointer :: mhd_handle_small_values => null()
  procedure(sub_get_pthermal), pointer :: mhd_get_pthermal  => null()
  procedure(sub_get_v), pointer        :: mhd_get_v         => null()
  procedure(fun_kin_en), pointer       :: mhd_kin_en        => null()
  ! Public methods
  public :: usr_mask_ambipolar
  public :: usr_rfactor
  public :: mhd_phys_init
  public :: mhd_kin_en
  public :: mhd_get_pthermal
  public :: mhd_get_v
  public :: mhd_get_rho
  public :: mhd_get_v_idim
  public :: mhd_to_conserved
  public :: mhd_to_primitive
  public :: mhd_get_csound2
  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
  {^nooned
  public :: mhd_clean_divb_multigrid
  }
 
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_gamma, 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_viscosity, mhd_4th_order, typedivbfix, source_split_divb, divbdiff,&
      typedivbdiff, type_ct, compactres, divbwave, he_abundance, &
      h_ion_fr, he_ion_fr, he_ion_fr2, eq_state_units, si_unit, b0field ,mhd_dump_full_vars,&
      b0field_forcefree, bdip, bquad, boct, busr, mhd_particles,&
      particles_eta, particles_etah,has_equi_rho0, has_equi_pe0,mhd_equi_thermal,&
      boundary_divbfix, boundary_divbfix_skip, mhd_divb_4thorder, mhd_semirelativistic,&
      mhd_boris_simplification, mhd_reduced_c, clean_initial_divb, mhd_solve_eaux, mhd_internal_e, &
      mhd_hydrodynamic_e, mhd_trac, mhd_trac_type, mhd_trac_mask, mhd_trac_finegrid, mhd_cak_force
 
    do n = 1, size(files)
       open(unitpar, file=trim(files(n)), status="old")
       read(unitpar, mhd_list, end=111)
111    close(unitpar)
    end do
 
  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, parameter                  :: n_par = 1
    double precision                    :: values(n_par)
    character(len=name_len)             :: names(n_par)
    integer, dimension(MPI_STATUS_SIZE) :: st
    integer                             :: er
 
    call mpi_file_write(fh, n_par, 1, mpi_integer, st, er)
 
    names(1) = "gamma"
    values(1) = mhd_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_angmomfix(fC,x,wnew,ixI^L,ixO^L,idim)
    use mod_global_parameters
    double precision, intent(in)       :: x(ixI^S,1:ndim)
    double precision, intent(inout)    :: fC(ixI^S,1:nwflux,1:ndim),  wnew(ixI^S,1:nw)
    integer, intent(in)                :: ixI^L, ixO^L
    integer, intent(in)                :: idim
    integer                            :: hxO^L, kxC^L, iw
    double precision                   :: inv_volume(ixI^S)
 
    call mpistop("to do")
 
  end subroutine mhd_angmomfix
 
  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_particles, only: particles_init, particles_eta, particles_etah
    use mod_magnetofriction, only: magnetofriction_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
    {^nooned
    use mod_multigrid_coupling
    }
 
    integer :: itr, idir
 
    call mhd_read_params(par_files)
 
    if(mhd_internal_e) then
      if(mhd_solve_eaux) then
        mhd_solve_eaux=.false.
        if(mype==0) write(*,*) 'WARNING: set mhd_solve_eaux=F when mhd_internal_e=T'
      end if
      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
    end if
 
    if(mhd_semirelativistic) then
      unsplit_semirelativistic=.true.
      if(mhd_internal_e) then
        mhd_internal_e=.false.
        if(mype==0) write(*,*) 'WARNING: set mhd_internal_e=F when mhd_semirelativistic=T'
      end if
      if(mhd_hydrodynamic_e) then
        ! use split semirelativistic MHD
        unsplit_semirelativistic=.false.
      end if
      if(mhd_boris_simplification) then
        mhd_boris_simplification=.false.
        if(mype==0) write(*,*) 'WARNING: set mhd_boris_simplification=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_solve_eaux) then
        mhd_solve_eaux=.false.
        if(mype==0) write(*,*) 'WARNING: set mhd_solve_eaux=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_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
    end if
 
    physics_type = "mhd"
    phys_energy=mhd_energy
    phys_internal_e=mhd_internal_e
    phys_solve_eaux=mhd_solve_eaux
    phys_trac=mhd_trac
    phys_trac_type=mhd_trac_type
 
    phys_gamma = mhd_gamma
 
    if(mhd_energy.and..not.mhd_internal_e.and..not.mhd_hydrodynamic_e) then
      total_energy=.true.
    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
    phys_trac_mask=mhd_trac_mask
 
    if(mhd_solve_eaux) prolongprimitive=.true.
 
    ! set default gamma for polytropic/isothermal process
    use_particles=mhd_particles
    if(ndim==1) typedivbfix='none'
    select case (typedivbfix)
    case ('none')
       type_divb = divb_none
    {^nooned
    case ('multigrid')
       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)
 
    ! 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)
 
    !  set auxiliary internal energy variable
    if(mhd_energy .and. mhd_solve_eaux) then
      eaux_ = var_set_internal_energy()
      paux_ = eaux_
    else
      eaux_ = -1
      paux_ = -1
    end if
 
    if (mhd_glm) then
      psi_ = var_set_fluxvar('psi', 'psi', need_bc=.false.)
    else
      psi_ = -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
 
    ! set number of variables which need update ghostcells
    nwgc=nwflux
 
    ! 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_rho0) then
      number_equi_vars = number_equi_vars + 1
      equi_rho0_ = number_equi_vars
      iw_equi_rho = equi_rho0_
    endif
    if(has_equi_pe0) then
      number_equi_vars = number_equi_vars + 1
      equi_pe0_ = number_equi_vars
      iw_equi_p = equi_pe0_
    endif
    ! determine number of stagger variables
    if(stagger_grid) nws=ndim
 
    nvector      = 2 ! No. vector vars
    allocate(iw_vector(nvector))
    iw_vector(1) = mom(1) - 1   ! TODO: why like this?
    iw_vector(2) = mag(1) - 1   ! TODO: why like this?
 
    ! 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 eaux and 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_dt              => mhd_get_dt
    if(mhd_semirelativistic) then
      phys_get_cmax            => mhd_get_cmax_semirelati
    else
      phys_get_cmax            => mhd_get_cmax_origin
    end if
    phys_get_a2max           => mhd_get_a2max
    phys_get_tcutoff         => mhd_get_tcutoff
    phys_get_h_speed         => mhd_get_h_speed
    if(has_equi_rho0) 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
    if(has_equi_rho0) then
      phys_to_primitive        => mhd_to_primitive_split_rho
      mhd_to_primitive         => mhd_to_primitive_split_rho
      phys_to_conserved        => mhd_to_conserved_split_rho
      mhd_to_conserved         => mhd_to_conserved_split_rho
    else if(mhd_internal_e) then
      phys_to_primitive        => mhd_to_primitive_inte
      mhd_to_primitive         => mhd_to_primitive_inte
      phys_to_conserved        => mhd_to_conserved_inte
      mhd_to_conserved         => mhd_to_conserved_inte
    else if(unsplit_semirelativistic) then
      phys_to_primitive        => mhd_to_primitive_semirelati
      mhd_to_primitive         => mhd_to_primitive_semirelati
      phys_to_conserved        => mhd_to_conserved_semirelati
      mhd_to_conserved         => mhd_to_conserved_semirelati
    else if(mhd_hydrodynamic_e) then
      phys_to_primitive        => mhd_to_primitive_hde
      mhd_to_primitive         => mhd_to_primitive_hde
      phys_to_conserved        => mhd_to_conserved_hde
      mhd_to_conserved         => mhd_to_conserved_hde
    else
      phys_to_primitive        => mhd_to_primitive_origin
      mhd_to_primitive         => mhd_to_primitive_origin
      phys_to_conserved        => mhd_to_conserved_origin
      mhd_to_conserved         => mhd_to_conserved_origin
    end if
    if(unsplit_semirelativistic) then
      phys_get_flux            => mhd_get_flux_semirelati
    else
      if(b0field.or.has_equi_rho0.or.has_equi_pe0) then
        phys_get_flux            => mhd_get_flux_split
      else if(mhd_hydrodynamic_e) then
        phys_get_flux            => mhd_get_flux_hde
      else
        phys_get_flux            => mhd_get_flux
      end if
    end if
    if(mhd_boris_simplification) then
      phys_get_v                 => mhd_get_v_boris
      mhd_get_v                  => mhd_get_v_boris
      mhd_kin_en                 => mhd_kin_en_boris
    else
      phys_get_v                 => mhd_get_v_origin
      mhd_get_v                  => mhd_get_v_origin
      mhd_kin_en                 => mhd_kin_en_origin
    end if
    if(b0field.or.has_equi_rho0) 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
    phys_angmomfix           => mhd_angmomfix
    if(unsplit_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
      phys_get_pthermal        => mhd_get_pthermal_semirelati
      mhd_get_pthermal         => mhd_get_pthermal_semirelati
    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
      phys_get_pthermal        => mhd_get_pthermal_hde
      mhd_get_pthermal         => mhd_get_pthermal_hde
    else
      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
      phys_get_pthermal        => mhd_get_pthermal_origin
      mhd_get_pthermal         => mhd_get_pthermal_origin
    end if
    phys_energy_synchro      => mhd_energy_synchro
    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
 
    ! if using ct stagger grid, boundary divb=0 is not done here
    if(stagger_grid) then
      phys_get_ct_velocity => mhd_get_ct_velocity
      phys_update_faces => mhd_update_faces
      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) phys_clean_divb => mhd_clean_divb_multigrid
    }
 
    ! Whether diagonal ghost cells are required for the physics
    if(type_divb < divb_linde) phys_req_diagonal = .false.
 
    ! derive units from basic units
    call mhd_physical_units()
 
    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_radiative_cooling) then
      call mpistop("radiative cooling needs mhd_energy=T")
    end if
 
    ! resistive MHD needs diagonal ghost cells
    if(mhd_eta/=0.d0) phys_req_diagonal = .true.
 
    ! initialize thermal conduction module
    if (mhd_thermal_conduction) then
      phys_req_diagonal = .true.
 
      call sts_init()
      call tc_init_params(mhd_gamma)
 
      allocate(tc_fl)
      call tc_get_mhd_params(tc_fl,tc_params_read_mhd)
      call add_sts_method(mhd_get_tc_dt_mhd,mhd_sts_set_source_tc_mhd,e_,1,e_,1,.false.)
      if(phys_internal_e) then
        if(has_equi_pe0 .and. has_equi_rho0) then
          tc_fl%get_temperature_from_conserved => mhd_get_temperature_from_eint_with_equi
        else
          tc_fl%get_temperature_from_conserved => mhd_get_temperature_from_eint
        end if
      else if(mhd_hydrodynamic_e) then
        tc_fl%get_temperature_from_conserved => mhd_get_temperature_from_hde
      else
        if(has_equi_pe0 .and. has_equi_rho0) then
          tc_fl%get_temperature_from_conserved => mhd_get_temperature_from_etot_with_equi
        else
          tc_fl%get_temperature_from_conserved => mhd_get_temperature_from_etot
        end if
      end if
      if(mhd_solve_eaux) then
        call set_conversion_methods_to_head(mhd_e_to_ei_aux, mhd_ei_to_e_aux)
      else if(unsplit_semirelativistic) then
        call set_conversion_methods_to_head(mhd_e_to_ei_semirelati, mhd_ei_to_e_semirelati)
      else if(mhd_hydrodynamic_e) then
        call set_conversion_methods_to_head(mhd_e_to_ei_hde, mhd_ei_to_e_hde)
      else if(.not. mhd_internal_e) then
        call set_conversion_methods_to_head(mhd_e_to_ei, mhd_ei_to_e)
      end if
      if(has_equi_pe0 .and. has_equi_rho0) then
        tc_fl%get_temperature_from_eint => mhd_get_temperature_from_eint_with_equi
        if(mhd_equi_thermal) then
          tc_fl%has_equi = .true.
          tc_fl%get_temperature_equi => mhd_get_temperature_equi
          tc_fl%get_rho_equi => mhd_get_rho_equi
        else
          tc_fl%has_equi = .false.
        endif
      else
        tc_fl%get_temperature_from_eint => mhd_get_temperature_from_eint
      endif
      call set_error_handling_to_head(mhd_tc_handle_small_e)
      tc_fl%get_rho => mhd_get_rho
      tc_fl%e_ = e_
      tc_fl%Tcoff_ = tcoff_
    end if
 
    ! Initialize radiative cooling module
    if (mhd_radiative_cooling) then
      call radiative_cooling_init_params(mhd_gamma,he_abundance)
      allocate(rc_fl)
      call radiative_cooling_init(rc_fl,rc_params_read)
      rc_fl%get_rho => mhd_get_rho
      rc_fl%get_pthermal => mhd_get_pthermal
      rc_fl%e_ = e_
      rc_fl%eaux_ = eaux_
      rc_fl%Tcoff_ = tcoff_
      if(associated(usr_rfactor)) then
        rc_fl%get_var_Rfactor => usr_rfactor
      endif
      if(has_equi_pe0 .and. has_equi_rho0 .and. mhd_equi_thermal) then
        rc_fl%has_equi = .true.
        rc_fl%get_rho_equi => mhd_get_rho_equi
        rc_fl%get_pthermal_equi => mhd_get_pe_equi
      else
        rc_fl%has_equi = .false.
      end if
    end if
    allocate(te_fl_mhd)
    te_fl_mhd%get_rho=> mhd_get_rho
    te_fl_mhd%get_pthermal=> mhd_get_pthermal
    te_fl_mhd%Rfactor = rr
    if(associated(usr_rfactor)) then
      te_fl_mhd%get_var_Rfactor => usr_rfactor
    endif
{^ifthreed
    phys_te_images => mhd_te_images
}
    ! Initialize viscosity module
    if (mhd_viscosity) call viscosity_init(phys_wider_stencil,phys_req_diagonal)
 
    ! Initialize gravity module
    if(mhd_gravity) then
      call gravity_init()
    end if
 
    ! Initialize particles module
    if(mhd_particles) then
      call particles_init()
      if (particles_eta  < zero) particles_eta = mhd_eta
      if (particles_etah < zero) particles_eta = mhd_etah
      phys_req_diagonal = .true.
      if(mype==0) then
         write(*,*) '*****Using particles:        with mhd_eta, mhd_etah :', mhd_eta, mhd_etah
         write(*,*) '*****Using particles: particles_eta, particles_etah :', particles_eta, particles_etah
      end if
    end if
 
    ! initialize magnetofriction module
    if(mhd_magnetofriction) then
      phys_req_diagonal = .true.
      call magnetofriction_init()
    end if
 
    ! For Hall, we need one more reconstructed layer since currents are computed
    ! in mhd_get_flux: assuming one additional ghost layer (two for FOURTHORDER) was
    ! added in nghostcells.
    if(mhd_hall) then
      phys_req_diagonal = .true.
      if(mhd_4th_order) then
        phys_wider_stencil = 2
      else
        phys_wider_stencil = 1
      end if
    end if
 
    if(mhd_ambipolar) then
      phys_req_diagonal = .true.
      if(mhd_ambipolar_sts) then
        call sts_init()
        if(mhd_internal_e) then
          call add_sts_method(get_ambipolar_dt,sts_set_source_ambipolar,mag(1),&
               ndir,mag(1),ndir,.true.)
        else
          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 (two for FOURTHORDER) was
        ! added in nghostcells.
        if(mhd_4th_order) then
          phys_wider_stencil = 2
        else
          phys_wider_stencil = 1
        end if
      end if
    end if
 
    ! Initialize CAK radiation force module
    if (mhd_cak_force) call cak_init(mhd_gamma)
 
  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 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
 
  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
 
  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
 
    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
    type(tc_fluid), intent(inout) :: fl
 
    integer                      :: n
 
    ! list parameters
    logical :: tc_perpendicular=.true.
    logical :: tc_saturate=.false.
    double precision :: tc_k_para=0d0
    double precision :: tc_k_perp=0d0
    character(len=std_len)  :: tc_slope_limiter="MC"
 
    namelist /tc_list/ tc_perpendicular, tc_saturate, tc_slope_limiter, tc_k_para, tc_k_perp
 
    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_k_para = tc_k_para
    fl%tc_k_perp = tc_k_perp
    fl%tc_slope_limiter = tc_slope_limiter
  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
    integer                      :: n
    ! list parameters
    integer :: ncool = 4000
    double precision :: cfrac=0.1d0
  
    !> Name of cooling curve
    character(len=std_len)  :: coolcurve='JCcorona'
  
    !> Name of cooling method
    character(len=std_len)  :: coolmethod='exact'
  
    !> Fixed temperature not lower than tlow
    logical    :: Tfix=.false.
  
    !> Lower limit of temperature
    double precision   :: tlow=bigdouble
  
    !> Add cooling source in a split way (.true.) or un-split way (.false.)
    logical    :: rc_split=.false.
 
 
    namelist /rc_list/ coolcurve, coolmethod, ncool, cfrac, tlow, tfix, rc_split
 
    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%coolmethod=coolmethod
    fl%tlow=tlow
    fl%Tfix=tfix
    fl%rc_split=rc_split
    fl%cfrac=cfrac
 
  end subroutine rc_params_read
!! end rad cool
 
  !> 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)
    double precision   :: rho(ixi^s)
 
    call  mhd_get_rho(w,x,ixi^l,ixo^l,rho(ixi^s))
    wnew(ixo^s,rho_) = rho(ixo^s)
    wnew(ixo^s,mom(:)) =  w(ixo^s,mom(:))
 
    if (b0field) then
      ! add background magnetic field B0 to B
      wnew(ixo^s,mag(:))=w(ixo^s,mag(:))+block%B0(ixo^s,:,0)
    else
      wnew(ixo^s,mag(:))=w(ixo^s,mag(:))
    end if
 
    if(mhd_energy) then
      wnew(ixo^s,e_) = w(ixo^s,e_)
      if(has_equi_pe0) then
        wnew(ixo^s,e_) = wnew(ixo^s,e_) + block%equi_vars(ixo^s,equi_pe0_,0)* inv_gamma_1
      end if
      if(b0field .and. .not. mhd_internal_e) 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_convert, only: add_convert_method
 
    ! after user parameter setting
    gamma_1=mhd_gamma-1.d0
    if (.not. mhd_energy) then
       if (mhd_gamma <= 0.0d0) call mpistop ("Error: mhd_gamma <= 0")
       if (mhd_adiab < 0.0d0) call mpistop ("Error: mhd_adiab < 0")
       small_pressure = mhd_adiab*small_density**mhd_gamma
    else
       if (mhd_gamma <= 0.0d0 .or. mhd_gamma == 1.0d0) &
            call mpistop ("Error: mhd_gamma <= 0 or mhd_gamma == 1")
       inv_gamma_1=1.d0/gamma_1
       small_e = small_pressure * inv_gamma_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(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
  end subroutine mhd_check_params
 
  subroutine mhd_physical_units()
    use mod_global_parameters
    double precision :: mp,kB,miu0,c_lightspeed
    double precision :: a,b
    ! Derive scaling units
    if(si_unit) then
      mp=mp_si
      kb=kb_si
      miu0=miu0_si
      c_lightspeed=c_si
    else
      mp=mp_cgs
      kb=kb_cgs
      miu0=4.d0*dpi ! G^2 cm^2 dyne^-1
      c_lightspeed=const_c
    end if
    if(eq_state_units) then
      a = 1d0 + 4d0 * he_abundance
      b = 1d0 + h_ion_fr + he_abundance*(he_ion_fr*(he_ion_fr2 + 1d0)+1d0)
      rr = 1d0
    else
      a = 1d0
      b = 1d0
      rr = (1d0 + h_ion_fr + he_abundance*(he_ion_fr*(he_ion_fr2 + 1d0)+1d0))/(1d0 + 4d0 * he_abundance)
    endif
    if(unit_density/=1.d0) then
      unit_numberdensity=unit_density/(a*mp)
    else
      ! unit of numberdensity is independent by default
      unit_density=a*mp*unit_numberdensity
    end if
    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)
    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)
    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)
    else
      ! unit of temperature is independent by default
      unit_pressure=b*unit_numberdensity*kb*unit_temperature
      unit_velocity=sqrt(unit_pressure/unit_density)
      unit_magneticfield=sqrt(miu0*unit_pressure)
    end if
    if(unit_time/=1.d0) then
      unit_length=unit_time*unit_velocity
    else
      ! unit of length is independent by default
      unit_time=unit_length/unit_velocity
    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.or.mhd_boris_simplification) 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
    end if
 
  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
    integer, intent(in) :: ixI^L, ixO^L
    double precision, intent(in) :: w(ixI^S,nw)
    double precision :: tmp(ixO^S),b2(ixO^S),b(ixO^S,1:ndir),Ba(ixO^S,1:ndir)
    double precision :: v(ixO^S,1:ndir),gamma2(ixO^S),inv_rho(ixO^S)
    logical, intent(inout) :: flag(ixI^S,1:nw)
 
    integer :: idir, jdir, kdir
 
    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(b0field) then
          ba(ixo^s,1:ndir)=w(ixo^s,mag(1:ndir))+block%B0(ixo^s,1:ndir,b0i)
        else
          ba(ixo^s,1:ndir)=w(ixo^s,mag(1:ndir))
        end if
        inv_rho(ixo^s) = 1d0/w(ixo^s,rho_)
        b2(ixo^s)=sum(ba(ixo^s,:)**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
        do idir=1,ndir
          b(ixo^s,idir)=ba(ixo^s,idir)*tmp(ixo^s)
        end do
        tmp(ixo^s)=sum(b(ixo^s,:)*w(ixo^s,mom(:)),dim=ndim+1)
        ! Va^2/c^2
        b2(ixo^s)=b2(ixo^s)*inv_rho(ixo^s)*inv_squared_c
        ! equation (15)
        gamma2(ixo^s)=1.d0/(1.d0+b2(ixo^s))
        ! Convert momentum to velocity
        do idir = 1, ndir
           v(ixo^s,idir) = gamma2*(w(ixo^s, mom(idir))+b2*b(ixo^s,idir)*tmp)*inv_rho
        end do
        ! E=Bxv
        b=0.d0
        do idir=1,ndir; do jdir=1,ndir; do kdir=1,ndir
          if(lvc(idir,jdir,kdir)==1)then
            b(ixo^s,idir)=b(ixo^s,idir)+ba(ixo^s,jdir)*v(ixo^s,kdir)
          else if(lvc(idir,jdir,kdir)==-1)then
            b(ixo^s,idir)=b(ixo^s,idir)-ba(ixo^s,jdir)*v(ixo^s,kdir)
          end if
        end do; end do; end do
        ! Calculate internal e = e-eK-eB-eE
        tmp(ixo^s)=w(ixo^s,e_)&
                   -half*(sum(v(ixo^s,:)**2,dim=ndim+1)*w(ixo^s,rho_)&
                   +sum(w(ixo^s,mag(:))**2,dim=ndim+1)&
                   +sum(b(ixo^s,:)**2,dim=ndim+1)*inv_squared_c)
        where(tmp(ixo^s) < small_e) flag(ixo^s,e_) = .true.
      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)
    double precision :: tmp(ixI^S)
    logical, intent(inout) :: flag(ixI^S,1:nw)
 
    flag=.false.
    if(has_equi_rho0) then
      tmp(ixo^s) = w(ixo^s,rho_) + block%equi_vars(ixo^s,equi_rho0_,0)
    else
      tmp(ixo^s) = w(ixo^s,rho_)
    endif
    where(tmp(ixo^s) < small_density) flag(ixo^s,rho_) = .true.
 
    if(mhd_energy) then
      if(primitive) then
        tmp(ixo^s) = w(ixo^s,e_)
        if(has_equi_pe0) then
          tmp(ixo^s) = tmp(ixo^s)+block%equi_vars(ixo^s,equi_pe0_,0)
        endif
        where(tmp(ixo^s) < small_pressure) flag(ixo^s,e_) = .true.
      else
        if(mhd_internal_e) then
          tmp(ixo^s)=w(ixo^s,e_)
          if(has_equi_pe0) then
            tmp(ixo^s) = tmp(ixo^s)+block%equi_vars(ixo^s,equi_pe0_,0)*inv_gamma_1
          endif
          where(tmp(ixo^s) < small_e) flag(ixo^s,e_) = .true.
        else
          tmp(ixo^s)=w(ixo^s,e_)-&
              mhd_kin_en(w,ixi^l,ixo^l)-mhd_mag_en(w,ixi^l,ixo^l)
          if(has_equi_pe0) then
            tmp(ixo^s) = tmp(ixo^s)+block%equi_vars(ixo^s,equi_pe0_,0)*inv_gamma_1
          endif
          where(tmp(ixo^s) < small_e) flag(ixo^s,e_) = .true.
        end if
      end if
    end if
 
  end subroutine mhd_check_w_origin
 
  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)
    double precision :: tmp(ixI^S)
    logical, intent(inout) :: 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,e_) < small_pressure) flag(ixo^s,e_) = .true.
      else
        tmp(ixo^s)=w(ixo^s,e_)-mhd_kin_en(w,ixi^l,ixo^l)
        where(tmp(ixo^s) < small_e) flag(ixo^s,e_) = .true.
      end if
    end if
 
  end subroutine mhd_check_w_hde
 
  !> Transform primitive variables into conservative ones
  subroutine mhd_to_conserved_origin(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)
 
    double precision :: inv_gamma2(ixO^S)
    integer                         :: idir
 
    !if (fix_small_values) then
    !  call mhd_handle_small_values(.true., w, x, ixI^L, ixO^L, 'mhd_to_conserved')
    !end if
 
    ! Calculate total energy from pressure, kinetic and magnetic energy
    if(mhd_energy) then
      w(ixo^s,e_)=w(ixo^s,p_)*inv_gamma_1&
                 +half*sum(w(ixo^s,mom(:))**2,dim=ndim+1)*w(ixo^s,rho_)&
                 +mhd_mag_en(w, ixi^l, ixo^l)
      if(mhd_solve_eaux) w(ixo^s,eaux_)=w(ixo^s,paux_)*inv_gamma_1
    end if
 
    if(mhd_boris_simplification) then
      inv_gamma2=1.d0+sum(w(ixo^s,mag(:))**2,dim=ndim+1)/w(ixo^s,rho_)*inv_squared_c
      ! Convert velocity to momentum
      do idir = 1, ndir
        w(ixo^s, mom(idir)) = inv_gamma2*w(ixo^s,rho_)*w(ixo^s, mom(idir))
      end do
    else
      ! Convert velocity to momentum
      do idir = 1, ndir
        w(ixo^s, mom(idir)) = w(ixo^s,rho_)*w(ixo^s, mom(idir))
      end do
    end if
  end subroutine mhd_to_conserved_origin
 
  !> Transform primitive variables into conservative ones
  subroutine mhd_to_conserved_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                         :: idir
 
    !if (fix_small_values) then
    !  call mhd_handle_small_values(.true., w, x, ixI^L, ixO^L, 'mhd_to_conserved')
    !end if
 
    ! Calculate total energy from pressure, kinetic and magnetic energy
    if(mhd_energy) then
      w(ixo^s,e_)=w(ixo^s,p_)*inv_gamma_1&
                 +half*sum(w(ixo^s,mom(:))**2,dim=ndim+1)*w(ixo^s,rho_)
    end if
 
    ! Convert velocity to momentum
    do idir = 1, ndir
      w(ixo^s, mom(idir)) = w(ixo^s,rho_)*w(ixo^s, mom(idir))
    end do
  end subroutine mhd_to_conserved_hde
 
  !> Transform primitive variables into conservative ones
  subroutine mhd_to_conserved_inte(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)
 
    double precision :: inv_gamma2(ixO^S)
    integer                         :: idir
 
    !if (fix_small_values) then
    !  call mhd_handle_small_values(.true., w, x, ixI^L, ixO^L, 'mhd_to_conserved')
    !end if
 
    ! Calculate total energy from pressure, kinetic and magnetic energy
    if(mhd_energy) then
      w(ixo^s,e_)=w(ixo^s,p_)*inv_gamma_1
    end if
 
    if(mhd_boris_simplification) then
      inv_gamma2=1.d0+sum(w(ixo^s,mag(:))**2,dim=ndim+1)/w(ixo^s,rho_)*inv_squared_c
      ! Convert velocity to momentum
      do idir = 1, ndir
        w(ixo^s, mom(idir)) = inv_gamma2*w(ixo^s,rho_)*w(ixo^s, mom(idir))
      end do
    else
      ! Convert velocity to momentum
      do idir = 1, ndir
        w(ixo^s, mom(idir)) = w(ixo^s,rho_)*w(ixo^s, mom(idir))
      end do
    end if
  end subroutine mhd_to_conserved_inte
 
  !> Transform primitive variables into conservative ones
  subroutine mhd_to_conserved_split_rho(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                         :: idir
    double precision                :: rho(ixI^S)
 
    !if (fix_small_values) then
    !  call mhd_handle_small_values(.true., w, x, ixI^L, ixO^L, 'mhd_to_conserved')
    !end if
 
    rho(ixo^s) = w(ixo^s,rho_) + block%equi_vars(ixo^s,equi_rho0_,b0i)
    ! Calculate total energy from pressure, kinetic and magnetic energy
    if(mhd_energy) then
      if(mhd_internal_e) then
        w(ixo^s,e_)=w(ixo^s,p_)*inv_gamma_1
      else
        w(ixo^s,e_)=w(ixo^s,p_)*inv_gamma_1&
                   +half*sum(w(ixo^s,mom(:))**2,dim=ndim+1)*rho(ixo^s)&
                   +mhd_mag_en(w, ixi^l, ixo^l)
        if(mhd_solve_eaux) w(ixo^s,eaux_)=w(ixo^s,paux_)*inv_gamma_1
      end if
    end if
 
    ! Convert velocity to momentum
    do idir = 1, ndir
       w(ixo^s, mom(idir)) = rho(ixo^s) * w(ixo^s, mom(idir))
    end do
  end subroutine mhd_to_conserved_split_rho
 
  !> Transform primitive variables into conservative ones
  subroutine mhd_to_conserved_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)
 
    double precision :: E(ixO^S,1:ndir), B(ixO^S,1:ndir), S(ixO^S,1:ndir),tmp(ixO^S), b2(ixO^S)
    integer                         :: idir, jdir, kdir
 
    !if (fix_small_values) then
    !  call mhd_handle_small_values(.true., w, x, ixI^L, ixO^L, 'mhd_to_conserved')
    !end if
 
    if(b0field) then
      b(ixo^s,1:ndir)=w(ixo^s,mag(1:ndir))+block%B0(ixo^s,1:ndir,b0i)
    else
      b(ixo^s,1:ndir)=w(ixo^s,mag(1:ndir))
    end if
    ! Calculate total energy from pressure, kinetic and magnetic energy
    if(mhd_energy) then
      e=0.d0
      do idir=1,ndir; do jdir=1,ndir; do kdir=1,ndir
        if(lvc(idir,jdir,kdir)==1)then
          e(ixo^s,idir)=e(ixo^s,idir)+b(ixo^s,jdir)*w(ixo^s,mom(kdir))
        else if(lvc(idir,jdir,kdir)==-1)then
          e(ixo^s,idir)=e(ixo^s,idir)-b(ixo^s,jdir)*w(ixo^s,mom(kdir))
        end if
      end do; end do; end do
      ! equation (9)
      w(ixo^s,e_)=w(ixo^s,p_)*inv_gamma_1&
                 +half*(sum(w(ixo^s,mom(:))**2,dim=ndim+1)*w(ixo^s,rho_)&
                 +sum(w(ixo^s,mag(:))**2,dim=ndim+1)&
                 +sum(e(ixo^s,:)**2,dim=ndim+1)*inv_squared_c)
    end if
 
    ! Convert velocity to momentum
    do idir = 1, ndir
       w(ixo^s, mom(idir)) = w(ixo^s,rho_) * w(ixo^s, mom(idir))
    end do
    !b2(ixO^S)=sum(w(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
    !do idir=1,ndir
    !  b(ixO^S,idir)=w(ixO^S,mag(idir))*tmp(ixO^S)
    !end do
    !tmp(ixO^S)=sum(b(ixO^S,:)*w(ixO^S,mom(:)),dim=ndim+1)
    !do idir = 1, ndir
    !   w(ixO^S, mom(idir)) = w(ixO^S, mom(idir))+b2(ixO^S)/w(ixO^S,rho_)*inv_squared_c*(w(ixO^S, mom(idir))-b(ixO^S,idir)*tmp(ixO^S))
    !end do
    ! equation (5) Poynting vector
    s=0.d0
    do idir=1,ndir; do jdir=1,ndir; do kdir=1,ndir
      if(lvc(idir,jdir,kdir)==1)then
        s(ixo^s,idir)=s(ixo^s,idir)+e(ixo^s,jdir)*b(ixo^s,kdir)
      else if(lvc(idir,jdir,kdir)==-1)then
        s(ixo^s,idir)=s(ixo^s,idir)-e(ixo^s,jdir)*b(ixo^s,kdir)
      end if
    end do; end do; end do
    ! equation (9)
    do idir = 1, ndir
       w(ixo^s, mom(idir)) = w(ixo^s, mom(idir))+s(ixo^s,idir)*inv_squared_c
    end do
  end subroutine mhd_to_conserved_semirelati
 
  !> Transform conservative variables into primitive ones
  subroutine mhd_to_primitive_origin(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)
 
    double precision                :: inv_rho(ixO^S), gamma2(ixO^S)
    integer                         :: idir
 
    if (fix_small_values) then
      ! fix small values preventing NaN numbers in the following converting
      call mhd_handle_small_values(.false., w, x, ixi^l, ixo^l, 'mhd_to_primitive_origin')
    end if
 
    inv_rho(ixo^s) = 1d0/w(ixo^s,rho_)
 
    ! Calculate pressure = (gamma-1) * (e-ek-eb)
    if(mhd_energy) then
      w(ixo^s,p_)=gamma_1*(w(ixo^s,e_)&
                  -mhd_kin_en(w,ixi^l,ixo^l,inv_rho)&
                  -mhd_mag_en(w,ixi^l,ixo^l))
      if(mhd_solve_eaux) w(ixo^s,paux_)=w(ixo^s,eaux_)*gamma_1
    end if
 
    if(mhd_boris_simplification) then
      gamma2=1.d0/(1.d0+sum(w(ixo^s,mag(:))**2,dim=ndim+1)*inv_rho*inv_squared_c)
      ! Convert momentum to velocity
      do idir = 1, ndir
         w(ixo^s, mom(idir)) = w(ixo^s, mom(idir))*inv_rho*gamma2
      end do
    else
      ! Convert momentum to velocity
      do idir = 1, ndir
         w(ixo^s, mom(idir)) = w(ixo^s, mom(idir))*inv_rho
      end do
    end if
 
  end subroutine mhd_to_primitive_origin
 
  !> Transform conservative variables into primitive ones
  subroutine mhd_to_primitive_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)
 
    double precision                :: inv_rho(ixO^S)
    integer                         :: idir
 
    if (fix_small_values) then
      ! fix small values preventing NaN numbers in the following converting
      call mhd_handle_small_values(.false., w, x, ixi^l, ixo^l, 'mhd_to_primitive_hde')
    end if
 
    inv_rho(ixo^s) = 1d0/w(ixo^s,rho_)
 
    ! Calculate pressure = (gamma-1) * (e-ek)
    if(mhd_energy) then
      w(ixo^s,p_)=gamma_1*(w(ixo^s,e_)-mhd_kin_en(w,ixi^l,ixo^l,inv_rho))
    end if
 
    ! Convert momentum to velocity
    do idir = 1, ndir
       w(ixo^s, mom(idir)) = w(ixo^s, mom(idir))*inv_rho
    end do
 
  end subroutine mhd_to_primitive_hde
 
  !> Transform conservative variables into primitive ones
  subroutine mhd_to_primitive_inte(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)
 
    double precision                :: inv_rho(ixO^S), gamma2(ixO^S)
    integer                         :: idir
 
    if (fix_small_values) then
      ! fix small values preventing NaN numbers in the following converting
      call mhd_handle_small_values(.false., w, x, ixi^l, ixo^l, 'mhd_to_primitive_inte')
    end if
 
    inv_rho(ixo^s) = 1d0/w(ixo^s,rho_)
 
    ! Calculate pressure = (gamma-1) * e_internal
    if(mhd_energy) then
      w(ixo^s,p_)=w(ixo^s,e_)*gamma_1
    end if
 
    if(mhd_boris_simplification) then
      gamma2=1.d0/(1.d0+sum(w(ixo^s,mag(:))**2,dim=ndim+1)*inv_rho*inv_squared_c)
      ! Convert momentum to velocity
      do idir = 1, ndir
         w(ixo^s, mom(idir)) = w(ixo^s, mom(idir))*inv_rho*gamma2
      end do
    else
      ! Convert momentum to velocity
      do idir = 1, ndir
         w(ixo^s, mom(idir)) = w(ixo^s, mom(idir))*inv_rho
      end do
    end if
 
  end subroutine mhd_to_primitive_inte
 
  !> Transform conservative variables into primitive ones
  subroutine mhd_to_primitive_split_rho(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)
    double precision                :: inv_rho(ixO^S)
    integer                         :: idir
 
    if (fix_small_values) then
      ! fix small values preventing NaN numbers in the following converting
      call mhd_handle_small_values(.false., w, x, ixi^l, ixo^l, 'mhd_to_primitive_split_rho')
    end if
 
    inv_rho(ixo^s) = 1d0/(w(ixo^s,rho_) + block%equi_vars(ixo^s,equi_rho0_,b0i))
 
    ! Calculate pressure = (gamma-1) * (e-ek-eb)
    if(mhd_energy) then
      if(mhd_internal_e) then
        w(ixo^s,p_)=w(ixo^s,e_)*gamma_1
      else
        w(ixo^s,p_)=gamma_1*(w(ixo^s,e_)&
                    -mhd_kin_en(w,ixi^l,ixo^l,inv_rho)&
                    -mhd_mag_en(w,ixi^l,ixo^l))
        if(mhd_solve_eaux) w(ixo^s,paux_)=w(ixo^s,eaux_)*gamma_1
      end if
    end if
    
    ! Convert momentum to velocity
    do idir = 1, ndir
       w(ixo^s, mom(idir)) = w(ixo^s, mom(idir))*inv_rho
    end do
 
  end subroutine mhd_to_primitive_split_rho
 
  !> Transform conservative variables into primitive ones
  subroutine mhd_to_primitive_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)
 
    double precision                :: inv_rho(ixO^S)
    double precision :: b(ixO^S,1:ndir), Ba(ixO^S,1:ndir),tmp(ixO^S), b2(ixO^S), gamma2(ixO^S)
    integer                         :: idir, jdir, kdir
 
    if (fix_small_values) then
      ! fix small values preventing NaN numbers in the following converting
      call mhd_handle_small_values_semirelati(.false., w, x, ixi^l, ixo^l, 'mhd_to_primitive_semirelati')
    end if
 
    if(b0field) then
      ba(ixo^s,1:ndir)=w(ixo^s,mag(1:ndir))+block%B0(ixo^s,1:ndir,b0i)
    else
      ba(ixo^s,1:ndir)=w(ixo^s,mag(1:ndir))
    end if
 
    inv_rho(ixo^s) = 1d0/w(ixo^s,rho_)
 
    b2(ixo^s)=sum(ba(ixo^s,:)**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
    do idir=1,ndir
      b(ixo^s,idir)=ba(ixo^s,idir)*tmp(ixo^s)
    end do
    tmp(ixo^s)=sum(b(ixo^s,:)*w(ixo^s,mom(:)),dim=ndim+1)
 
    ! Va^2/c^2
    b2(ixo^s)=b2(ixo^s)*inv_rho(ixo^s)*inv_squared_c
    ! equation (15)
    gamma2(ixo^s)=1.d0/(1.d0+b2(ixo^s))
    ! Convert momentum to velocity
    do idir = 1, ndir
       w(ixo^s, mom(idir)) = gamma2*(w(ixo^s, mom(idir))+b2*b(ixo^s,idir)*tmp)*inv_rho
    end do
 
    if(mhd_energy) then
      ! E=Bxv
      b=0.d0
      do idir=1,ndir; do jdir=1,ndir; do kdir=1,ndir
        if(lvc(idir,jdir,kdir)==1)then
          b(ixo^s,idir)=b(ixo^s,idir)+ba(ixo^s,jdir)*w(ixo^s,mom(kdir))
        else if(lvc(idir,jdir,kdir)==-1)then
          b(ixo^s,idir)=b(ixo^s,idir)-ba(ixo^s,jdir)*w(ixo^s,mom(kdir))
        end if
      end do; end do; end do
      ! Calculate pressure = (gamma-1) * (e-eK-eB-eE)
      w(ixo^s,p_)=gamma_1*(w(ixo^s,e_)&
                 -half*(sum(w(ixo^s,mom(:))**2,dim=ndim+1)*w(ixo^s,rho_)&
                 +sum(w(ixo^s,mag(:))**2,dim=ndim+1)&
                 +sum(b(ixo^s,:)**2,dim=ndim+1)*inv_squared_c))
    end if
 
  end subroutine mhd_to_primitive_semirelati
 
  !> 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)
 
    ! Calculate total energy from internal, kinetic and magnetic energy
    w(ixi^s,e_)=w(ixi^s,e_)&
               +mhd_kin_en(w,ixi^l,ixi^l)&
               +mhd_mag_en(w,ixi^l,ixi^l)
 
  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)
 
    ! Calculate hydrodynamic energy from internal and kinetic
    w(ixi^s,e_)=w(ixi^s,e_)+mhd_kin_en(w,ixi^l,ixi^l)
 
  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(ixi^s,p_)=w(ixi^s,e_)*gamma_1
    call mhd_to_conserved_semirelati(ixi^l,ixi^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)
 
    ! Calculate ei = e - ek - eb
    w(ixi^s,e_)=w(ixi^s,e_)&
                -mhd_kin_en(w,ixi^l,ixi^l)&
                -mhd_mag_en(w,ixi^l,ixi^l)
 
    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
 
  !> 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)
 
    ! Calculate ei = e - ek
    w(ixi^s,e_)=w(ixi^s,e_)-mhd_kin_en(w,ixi^l,ixi^l)
 
    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 mhd_to_primitive_semirelati(ixi^l,ixi^l,w,x)
    w(ixi^s,e_)=w(ixi^s,p_)*inv_gamma_1
 
  end subroutine mhd_e_to_ei_semirelati
 
  !> Update eaux and transform internal energy to total energy
  subroutine mhd_ei_to_e_aux(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(ixi^s,eaux_)=w(ixi^s,e_)
    ! Calculate total energy from internal, kinetic and magnetic energy
    w(ixi^s,e_)=w(ixi^s,e_)&
               +mhd_kin_en(w,ixi^l,ixi^l)&
               +mhd_mag_en(w,ixi^l,ixi^l)
 
  end subroutine mhd_ei_to_e_aux
 
  !> Transform total energy to internal energy via eaux as internal energy
  subroutine mhd_e_to_ei_aux(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(ixi^s,e_)=w(ixi^s,eaux_)
 
  end subroutine mhd_e_to_ei_aux
 
  subroutine mhd_energy_synchro(ixI^L,ixO^L,w,x)
    use mod_global_parameters
    integer, intent(in) :: ixI^L,ixO^L
    double precision, intent(in) :: x(ixI^S,1:ndim)
    double precision, intent(inout) :: w(ixI^S,1:nw)
 
    double precision :: pth1(ixI^S),pth2(ixI^S),alfa(ixI^S),beta(ixI^S)
    double precision, parameter :: beta_low=0.005d0,beta_high=0.05d0
 
!    double precision :: vtot(ixI^S),cs2(ixI^S),mach(ixI^S)
!    double precision, parameter :: mach_low=20.d0,mach_high=200.d0
 
    ! get magnetic energy
    alfa(ixo^s)=mhd_mag_en(w,ixi^l,ixo^l)
    pth1(ixo^s)=gamma_1*(w(ixo^s,e_)-mhd_kin_en(w,ixi^l,ixo^l)-alfa(ixo^s))
    pth2(ixo^s)=w(ixo^s,eaux_)*gamma_1
    ! get plasma beta
    beta(ixo^s)=min(pth1(ixo^s),pth2(ixo^s))/alfa(ixo^s)
 
    ! whether Mach number should be another criterion ?
!    vtot(ixO^S)=sum(w(ixO^S,mom(:))**2,dim=ndim+1)
!    call mhd_get_csound2(w,x,ixI^L,ixO^L,cs2)
!    mach(ixO^S)=sqrt(vtot(ixO^S)/cs2(ixO^S))/w(ixO^S,rho_)
    where(beta(ixo^s) .ge. beta_high)
!    where(beta(ixO^S) .ge. beta_high .and. mach(ixO^S) .le. mach_low)
      w(ixo^s,eaux_)=pth1(ixo^s)*inv_gamma_1
    else where(beta(ixo^s) .le. beta_low)
!    else where(beta(ixO^S) .le. beta_low .or. mach(ixO^S) .ge. mach_high)
      w(ixo^s,e_)=w(ixo^s,e_)-pth1(ixo^s)*inv_gamma_1+w(ixo^s,eaux_)
    else where
      alfa(ixo^s)=dlog(beta(ixo^s)/beta_low)/dlog(beta_high/beta_low)
!      alfa(ixO^S)=min(dlog(beta(ixO^S)/beta_low)/dlog(beta_high/beta_low),
!                      dlog(mach_high(ixO^S)/mach(ixO^S))/dlog(mach_high/mach_low))
      w(ixo^s,eaux_)=(pth2(ixo^s)*(one-alfa(ixo^s))&
                     +pth1(ixo^s)*alfa(ixo^s))*inv_gamma_1
      w(ixo^s,e_)=w(ixo^s,e_)-pth1(ixo^s)*inv_gamma_1+w(ixo^s,eaux_)
    end where
  end subroutine mhd_energy_synchro
 
  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 :: pressure(ixI^S), inv_rho(ixI^S), b2(ixI^S), tmp(ixI^S), gamma2(ixI^S)
    double precision :: b(ixI^S,1:ndir), v(ixI^S,1:ndir), Ba(ixI^S,1:ndir)
    integer :: idir, jdir, kdir, ix^D
    logical :: flag(ixI^S,1:nw)
 
    if(small_values_method == "ignore") return
 
    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(b0field) then
          ba(ixi^s,1:ndir)=w(ixi^s,mag(1:ndir))+block%B0(ixi^s,1:ndir,b0i)
        else
          ba(ixi^s,1:ndir)=w(ixi^s,mag(1:ndir))
        end if
        inv_rho(ixi^s) = 1d0/w(ixi^s,rho_)
        b2(ixi^s)=sum(ba(ixi^s,:)**2,dim=ndim+1)
        tmp(ixi^s)=sqrt(b2(ixi^s))
        where(tmp(ixi^s)>smalldouble)
          tmp(ixi^s)=1.d0/tmp(ixi^s)
        else where
          tmp(ixi^s)=0.d0
        end where
        do idir=1,ndir
          b(ixi^s,idir)=ba(ixi^s,idir)*tmp(ixi^s)
        end do
        tmp(ixi^s)=sum(b(ixi^s,:)*w(ixi^s,mom(:)),dim=ndim+1)
        ! Va^2/c^2
        b2(ixi^s)=b2(ixi^s)*inv_rho(ixi^s)*inv_squared_c
        ! equation (15)
        gamma2(ixi^s)=1.d0/(1.d0+b2(ixi^s))
        ! Convert momentum to velocity
        do idir = 1, ndir
           v(ixi^s,idir) = gamma2*(w(ixi^s, mom(idir))+b2*b(ixi^s,idir)*tmp(ixi^s))*inv_rho(ixi^s)
        end do
        ! E=Bxv
        b=0.d0
        do idir=1,ndir; do jdir=1,ndir; do kdir=1,ndir
          if(lvc(idir,jdir,kdir)==1)then
            b(ixi^s,idir)=b(ixi^s,idir)+ba(ixi^s,jdir)*v(ixi^s,kdir)
          else if(lvc(idir,jdir,kdir)==-1)then
            b(ixi^s,idir)=b(ixi^s,idir)-ba(ixi^s,jdir)*v(ixi^s,kdir)
          end if
        end do; end do; end do
        ! Calculate pressure p = (gamma-1) e-eK-eB-eE
        pressure(ixi^s)=gamma_1*(w(ixi^s,e_)&
                   -half*(sum(v(ixi^s,:)**2,dim=ndim+1)*w(ixi^s,rho_)&
                   +sum(w(ixi^s,mag(:))**2,dim=ndim+1)&
                   +sum(b(ixi^s,:)**2,dim=ndim+1)*inv_squared_c))
        where(pressure(ixo^s) < small_pressure) flag(ixo^s,p_) = .true.
      end if
    end if
 
    if(any(flag)) then
      select case (small_values_method)
      case ("replace")
        where(flag(ixo^s,rho_)) w(ixo^s,rho_) = small_density
 
        if(mhd_energy) then
          if(primitive) then
            where(flag(ixo^s,e_)) w(ixo^s,p_) = small_pressure
          else
            {do ix^db=ixomin^db,ixomax^db\}
              if(flag(ix^d,e_)) then
                w(ix^d,e_)=small_pressure*inv_gamma_1+half*(sum(v(ix^d,:)**2)*w(ix^d,rho_)&
                           +sum(w(ix^d,mag(:))**2)+sum(b(ix^d,:)**2)*inv_squared_c)
              end if
            {end do\}
          end if
        end if
      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(ixi^s,e_)=pressure(ixi^s)
            call small_values_average(ixi^l, ixo^l, w, x, flag, p_)
            w(ixi^s,e_)=w(ixi^s,p_)*inv_gamma_1&
                       +half*(sum(v(ixi^s,:)**2,dim=ndim+1)*w(ixi^s,rho_)&
                       +sum(w(ixi^s,mag(:))**2,dim=ndim+1)&
                       +sum(b(ixi^s,:)**2,dim=ndim+1)*inv_squared_c)
          end if
        end if
      case default
        call small_values_error(w, x, ixi^l, ixo^l, flag, subname)
      end select
    end if
  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 :: idir
    logical :: flag(ixI^S,1:nw)
    double precision :: tmp2(ixI^S)
 
    if(small_values_method == "ignore") return
 
    call phys_check_w(primitive, ixi^l, ixo^l, w, flag)
 
    if(any(flag)) then
      select case (small_values_method)
      case ("replace")
        if(has_equi_rho0) then
          where(flag(ixo^s,rho_)) w(ixo^s,rho_) = &
                    small_density-block%equi_vars(ixo^s,equi_rho0_,0)
        else
          where(flag(ixo^s,rho_)) w(ixo^s,rho_) = small_density
        endif
        do idir = 1, ndir
          if(small_values_fix_iw(mom(idir))) then
            where(flag(ixo^s,rho_)) w(ixo^s, mom(idir)) = 0.0d0
          end if
        end do
 
        if(mhd_energy) then
          if(primitive) then
           if(has_equi_pe0) then
            tmp2(ixo^s) = small_pressure - &
              block%equi_vars(ixo^s,equi_pe0_,0)
           else
            tmp2(ixo^s) = small_pressure
           endif
           where(flag(ixo^s,e_)) w(ixo^s,p_) = tmp2(ixo^s)
          else
            ! conserved
            if(has_equi_pe0) then
              tmp2(ixo^s) = small_e - &
                block%equi_vars(ixo^s,equi_pe0_,0)*inv_gamma_1
            else
              tmp2(ixo^s) = small_e
            endif
            if(mhd_internal_e) then
              where(flag(ixo^s,e_))
                w(ixo^s,e_)=tmp2(ixo^s)
              end where
            else
              where(flag(ixo^s,e_))
                w(ixo^s,e_) = tmp2(ixo^s)+&
                   mhd_kin_en(w,ixi^l,ixo^l)+&
                   mhd_mag_en(w,ixi^l,ixo^l)
              end where
              if(mhd_solve_eaux) then
                where(flag(ixo^s,e_))
                  w(ixo^s,eaux_)=tmp2(ixo^s)
                end where
              end if
            end if
          end if
        end if
      case ("average")
        if(primitive)then
          call small_values_average(ixi^l, ixo^l, w, x, flag, rho_)
          if(mhd_energy) then
            call small_values_average(ixi^l, ixo^l, w, x, flag, p_)
          end if
        else
          ! do averaging of density
          call small_values_average(ixi^l, ixo^l, w, x, flag, rho_)
          if(mhd_energy) then
             ! do averaging of internal energy
            if(.not.mhd_internal_e) then
              w(ixi^s,e_)=w(ixi^s,e_)&
                          -mhd_kin_en(w,ixi^l,ixi^l)&
                          -mhd_mag_en(w,ixi^l,ixi^l)
            end if
            call small_values_average(ixi^l, ixo^l, w, x, flag, e_)
             ! convert back
            if(.not.mhd_internal_e) then
              w(ixi^s,e_)=w(ixi^s,e_)&
                          +mhd_kin_en(w,ixi^l,ixi^l)&
                          +mhd_mag_en(w,ixi^l,ixi^l)
            end if
            ! eaux
            if(mhd_solve_eaux) then
              call small_values_average(ixi^l, ixo^l, w, x, flag, paux_)
            end if
          end if
        endif
      case default
        if(.not.primitive) then
          !convert w to primitive
          ! Calculate pressure = (gamma-1) * (e-ek-eb)
          if(mhd_energy) then
            if(mhd_internal_e) then
              w(ixo^s,p_)=w(ixo^s,e_)*gamma_1
            else
              w(ixo^s,p_)=gamma_1*(w(ixo^s,e_)&
                          -mhd_kin_en(w,ixi^l,ixo^l)&
                          -mhd_mag_en(w,ixi^l,ixo^l))
              if(mhd_solve_eaux) w(ixo^s,paux_)=w(ixo^s,eaux_)*gamma_1
            end if
          end if
          ! Convert momentum to velocity
          if(has_equi_rho0) then
            tmp2(ixo^s) = w(ixo^s,rho_) + block%equi_vars(ixo^s,equi_rho0_,0)
          else
            tmp2(ixo^s) = w(ixo^s,rho_)
          endif
          do idir = 1, ndir
             w(ixo^s, mom(idir)) = w(ixo^s, mom(idir))/tmp2(ixo^s)
          end do
        end if
        call small_values_error(w, x, ixi^l, ixo^l, flag, subname)
      end select
    end if
  end subroutine mhd_handle_small_values_origin
 
  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 :: idir
    logical :: flag(ixI^S,1:nw)
    double precision :: tmp2(ixI^S)
 
    if(small_values_method == "ignore") return
 
    call phys_check_w(primitive, ixi^l, ixo^l, w, flag)
 
    if(any(flag)) then
      select case (small_values_method)
      case ("replace")
        where(flag(ixo^s,rho_)) w(ixo^s,rho_) = small_density
        do idir = 1, ndir
          if(small_values_fix_iw(mom(idir))) then
            where(flag(ixo^s,rho_)) w(ixo^s, mom(idir)) = 0.0d0
          end if
        end do
 
        if(mhd_energy) then
          where(flag(ixo^s,e_))
            w(ixo^s,e_) = small_e+mhd_kin_en(w,ixi^l,ixo^l)
          end where
        end if
      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
            ! do averaging of internal energy
            w(ixi^s,e_)=w(ixi^s,e_)-mhd_kin_en(w,ixi^l,ixi^l)
            call small_values_average(ixi^l, ixo^l, w, x, flag, e_)
            ! convert back
            w(ixi^s,e_)=w(ixi^s,e_)+mhd_kin_en(w,ixi^l,ixi^l)
          end if
        end if
      case default
        if(.not.primitive) then
          !convert w to primitive
          ! Calculate pressure = (gamma-1) * (e-ek)
          if(mhd_energy) then
            w(ixo^s,p_)=gamma_1*(w(ixo^s,e_)-mhd_kin_en(w,ixi^l,ixo^l))
          end if
          ! Convert momentum to velocity
          do idir = 1, ndir
             w(ixo^s, mom(idir)) = w(ixo^s, mom(idir))/w(ixo^s,rho_)
          end do
        end if
        call small_values_error(w, x, ixi^l, ixo^l, flag, subname)
      end select
    end if
 
  end subroutine mhd_handle_small_values_hde
 
  !> Calculate v vector
  subroutine mhd_get_v_origin(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_origin
 
  !> Calculate v vector
  subroutine mhd_get_v_boris(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), gamma2(ixO^S)
    integer :: idir
 
    call mhd_get_rho(w,x,ixi^l,ixo^l,rho)
 
    rho(ixo^s)=1.d0/rho(ixo^s)
    gamma2=1.d0/(1.d0+sum(w(ixo^s,mag(:))**2,dim=ndim+1)*rho(ixo^s)*inv_squared_c)
    ! Convert momentum to velocity
    do idir = 1, ndir
       v(ixo^s, idir) = w(ixo^s, mom(idir))*rho(ixo^s)*gamma2
    end do
 
  end subroutine mhd_get_v_boris
 
  !> Calculate v component
  subroutine mhd_get_v_idim(w,x,ixI^L,ixO^L,idim,v)
    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) :: v(ixi^s)
 
    double precision              :: rho(ixi^s)
 
    call mhd_get_rho(w,x,ixi^l,ixo^l,rho)
 
    if(mhd_boris_simplification) then
      v(ixo^s) = w(ixo^s, mom(idim)) / rho(ixo^s) &
       /(1.d0+sum(w(ixo^s,mag(:))**2,dim=ndim+1)/rho(ixo^s)*inv_squared_c)
    else
      v(ixo^s) = w(ixo^s, mom(idim)) / rho(ixo^s)
    end if
 
  end subroutine mhd_get_v_idim
 
  !> 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 :: vel(ixI^S)
 
    call mhd_get_csound(w,x,ixi^l,ixo^l,idim,cmax)
    call mhd_get_v_idim(w,x,ixi^l,ixo^l,idim,vel)
 
    cmax(ixo^s)=abs(vel(ixo^s))+cmax(ixo^s)
 
  end subroutine mhd_get_cmax_origin
 
  !> 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 :: wprim(ixI^S,nw)
    double precision :: csound(ixO^S), AvMinCs2(ixO^S), idim_Alfven_speed2(ixO^S)
    double precision :: inv_rho(ixO^S), Alfven_speed2(ixO^S), gamma2(ixO^S), B(ixO^S,1:ndir)
 
    if(b0field) then
      b(ixo^s,1:ndir)=w(ixo^s,mag(1:ndir))+block%B0(ixo^s,1:ndir,b0i)
    else
      b(ixo^s,1:ndir)=w(ixo^s,mag(1:ndir))
    end if
    inv_rho = 1.d0/w(ixo^s,rho_)
 
    alfven_speed2=sum(b(ixo^s,:)**2,dim=ndim+1)*inv_rho
    gamma2 = 1.0d0/(1.d0+alfven_speed2*inv_squared_c)
 
    wprim=w
    call mhd_to_primitive(ixi^l,ixo^l,wprim,x)
    cmax(ixo^s)=1.d0-gamma2*wprim(ixo^s,mom(idim))**2*inv_squared_c
    ! equation (69)
    alfven_speed2=alfven_speed2*cmax(ixo^s)
 
    ! squared sound speed
    if(mhd_energy) then
      csound=mhd_gamma*wprim(ixo^s,p_)*inv_rho
    else
      csound=mhd_gamma*mhd_adiab*w(ixo^s,rho_)**gamma_1
    end if
 
    idim_alfven_speed2=b(ixo^s,idim)**2*inv_rho
 
    ! Va_hat^2+a_hat^2 equation (57)
    alfven_speed2=alfven_speed2+csound*(1.d0+idim_alfven_speed2*inv_squared_c)
 
    avmincs2=(gamma2*alfven_speed2)**2-4.0d0*gamma2*csound*idim_alfven_speed2*cmax(ixo^s)
 
    where(avmincs2<zero)
       avmincs2=zero
    end where
 
    ! equation (68) fast magnetosonic wave speed
    csound = sqrt(half*(gamma2*alfven_speed2+sqrt(avmincs2)))
    cmax(ixo^s)=gamma2*abs(wprim(ixo^s,mom(idim)))+csound
 
  end subroutine mhd_get_cmax_semirelati
 
  subroutine mhd_get_a2max(w,x,ixI^L,ixO^L,a2max)
    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) :: a2max(ndim)
    double precision :: a2(ixI^S,ndim,nw)
    integer :: gxO^L,hxO^L,jxO^L,kxO^L,i,j
 
    a2=zero
    do i = 1,ndim
      !> 4th order
      hxo^l=ixo^l-kr(i,^d);
      gxo^l=hxo^l-kr(i,^d);
      jxo^l=ixo^l+kr(i,^d);
      kxo^l=jxo^l+kr(i,^d);
      a2(ixo^s,i,1:nw)=abs(-w(kxo^s,1:nw)+16.d0*w(jxo^s,1:nw)&
         -30.d0*w(ixo^s,1:nw)+16.d0*w(hxo^s,1:nw)-w(gxo^s,1:nw))
      a2max(i)=maxval(a2(ixo^s,i,1:nw))/12.d0/dxlevel(i)**2
    end do
  end subroutine mhd_get_a2max
 
  !> 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
    integer, intent(in) :: ixI^L,ixO^L
    double precision, intent(in) :: x(ixI^S,1:ndim)
    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 :: tmp1(ixI^S),Te(ixI^S),lts(ixI^S)
    double precision, dimension(ixI^S,1:ndir) :: bunitvec
    double precision, dimension(ixI^S,1:ndim) :: gradT
    double precision :: Bdir(ndim)
    double precision :: ltrc,ltrp,altr(ixI^S)
    integer :: idims,jxO^L,hxO^L,ixA^D,ixB^D
    integer :: jxP^L,hxP^L,ixP^L
    logical :: lrlt(ixI^S)
 
    ! reuse lts as rhoc
    call mhd_get_rho(w,x,ixi^l,ixi^l,lts)
    if(mhd_internal_e) then
      tmp1(ixi^s)=w(ixi^s,e_)*gamma_1
    else
      call phys_get_pthermal(w,x,ixi^l,ixi^l,tmp1)
    end if
    te(ixi^s)=tmp1(ixi^s)/lts(ixi^s)
    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)
      hxo^l=ixo^l-1;
      jxo^l=ixo^l+1;
      lts(ixo^s)=0.5d0*abs(te(jxo^s)-te(hxo^s))/te(ixo^s)
      lrlt=.false.
      where(lts(ixo^s) > trac_delta)
        lrlt(ixo^s)=.true.
      end where
      if(any(lrlt(ixo^s))) then
        tco_local=maxval(te(ixo^s), mask=lrlt(ixo^s))
      end if
    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,tmp1)
        gradt(ixo^s,idims)=tmp1(ixo^s)
      end do
      ! B vector
      if(b0field) then
        bunitvec(ixo^s,:)=w(ixo^s,iw_mag(:))+block%B0(ixo^s,:,0)
      else
        bunitvec(ixo^s,:)=w(ixo^s,iw_mag(:))
      end if
      if(mhd_trac_type .gt. 1) then
        ! B direction at cell center
        bdir=zero
        {do ixa^d=0,1\}
          ixb^d=(ixomin^d+ixomax^d-1)/2+ixa^d;
          bdir(1:ndim)=bdir(1:ndim)+bunitvec(ixb^d,1:ndim)
        {end do\}
        if(sum(bdir(:)**2) .gt. zero) then
          bdir(1:ndim)=bdir(1:ndim)/dsqrt(sum(bdir(:)**2))
        end if
        block%special_values(3:ndim+2)=bdir(1:ndim)
      end if
      tmp1(ixo^s)=dsqrt(sum(bunitvec(ixo^s,:)**2,dim=ndim+1))
      where(tmp1(ixo^s)/=0.d0)
        tmp1(ixo^s)=1.d0/tmp1(ixo^s)
      elsewhere
        tmp1(ixo^s)=bigdouble
      end where
      ! b unit vector: magnetic field direction vector
      do idims=1,ndim
        bunitvec(ixo^s,idims)=bunitvec(ixo^s,idims)*tmp1(ixo^s)
      end do
      ! temperature length scale inversed
      lts(ixo^s)=abs(sum(gradt(ixo^s,1:ndim)*bunitvec(ixo^s,1:ndim),dim=ndim+1))/te(ixo^s)
      ! fraction of cells size to temperature length scale
      if(slab_uniform) then
        lts(ixo^s)=minval(dxlevel)*lts(ixo^s)
      else
        lts(ixo^s)=minval(block%ds(ixo^s,:),dim=ndim+1)*lts(ixo^s)
      end if
      lrlt=.false.
      where(lts(ixo^s) > trac_delta)
        lrlt(ixo^s)=.true.
      end where
      if(any(lrlt(ixo^s))) then
        block%special_values(1)=maxval(te(ixo^s), mask=lrlt(ixo^s))
      else
        block%special_values(1)=zero
      end if
      block%special_values(2)=tmax_local
    case(2)
      !> iijima et al. 2021, LTRAC method
      ltrc=1.5d0
      ltrp=4.d0
      ixp^l=ixo^l^ladd1;
      ! temperature gradient at cell centers
      do idims=1,ndim
        call gradient(te,ixi^l,ixp^l,idims,tmp1)
        gradt(ixp^s,idims)=tmp1(ixp^s)
      end do
      ! B vector
      if(b0field) then
        bunitvec(ixp^s,:)=w(ixp^s,iw_mag(:))+block%B0(ixp^s,:,0)
      else
        bunitvec(ixp^s,:)=w(ixp^s,iw_mag(:))
      end if
      tmp1(ixp^s)=dsqrt(sum(bunitvec(ixp^s,:)**2,dim=ndim+1))
      where(tmp1(ixp^s)/=0.d0)
        tmp1(ixp^s)=1.d0/tmp1(ixp^s)
      elsewhere
        tmp1(ixp^s)=bigdouble
      end where
      ! b unit vector: magnetic field direction vector
      do idims=1,ndim
        bunitvec(ixp^s,idims)=bunitvec(ixp^s,idims)*tmp1(ixp^s)
      end do
      ! temperature length scale inversed
      lts(ixp^s)=abs(sum(gradt(ixp^s,1:ndim)*bunitvec(ixp^s,1:ndim),dim=ndim+1))/te(ixp^s)
      ! fraction of cells size to temperature length scale
      if(slab_uniform) then
        lts(ixp^s)=minval(dxlevel)*lts(ixp^s)
      else
        lts(ixp^s)=minval(block%ds(ixp^s,:),dim=ndim+1)*lts(ixp^s)
      end if
      lts(ixp^s)=max(one, (exp(lts(ixp^s))/ltrc)**ltrp)
  
      altr=zero
      do idims=1,ndim
        hxo^l=ixo^l-kr(idims,^d);
        jxo^l=ixo^l+kr(idims,^d);
        altr(ixo^s)=altr(ixo^s)+0.25d0*(lts(hxo^s)+two*lts(ixo^s)+lts(jxo^s))*bunitvec(ixo^s,idims)**2
      end do
      block%wextra(ixo^s,tcoff_)=te(ixo^s)*altr(ixo^s)**0.4d0
      ! need one ghost layer for thermal conductivity
      {block%wextra(ixomin^d-1^d%ixP^s,tcoff_)=block%wextra(ixomin^d^d%ixP^s,tcoff_) \}
      {block%wextra(ixomax^d+1^d%ixP^s,tcoff_)=block%wextra(ixomax^d^d%ixP^s,tcoff_) \}
    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),tmp(ixI^S)
    integer :: jxC^L, ixC^L, ixA^L, id, ix^D
 
    hspeed=0.d0
    ixa^l=ixo^l^ladd1;
    do id=1,ndim
      call mhd_get_csound_prim(wprim,x,ixi^l,ixa^l,id,tmp)
      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
 
  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
 
    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)
    double precision, dimension(ixI^S) :: umean, dmean, csoundL, csoundR, 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.
      tmp1(ixo^s)=sqrt(wlp(ixo^s,rho_))
      tmp2(ixo^s)=sqrt(wrp(ixo^s,rho_))
      tmp3(ixo^s)=1.d0/(tmp1(ixo^s)+tmp2(ixo^s))
      umean(ixo^s)=(wlp(ixo^s,mom(idim))*tmp1(ixo^s)+wrp(ixo^s,mom(idim))*tmp2(ixo^s))*tmp3(ixo^s)
      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)
      dmean(ixo^s)=(tmp1(ixo^s)*csoundl(ixo^s)**2+tmp2(ixo^s)*csoundr(ixo^s)**2)*tmp3(ixo^s)+&
       0.5d0*tmp1(ixo^s)*tmp2(ixo^s)*tmp3(ixo^s)**2*&
       (wrp(ixo^s,mom(idim))-wlp(ixo^s,mom(idim)))**2
      dmean(ixo^s)=sqrt(dmean(ixo^s))
      if(present(cmin)) then
        cmin(ixo^s,1)=umean(ixo^s)-dmean(ixo^s)
        cmax(ixo^s,1)=umean(ixo^s)+dmean(ixo^s)
        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(umean(ixo^s))+dmean(ixo^s)
      end if
    case (2)
      wmean(ixo^s,1:nwflux)=0.5d0*(wlc(ixo^s,1:nwflux)+wrc(ixo^s,1:nwflux))
      tmp1(ixo^s)=wmean(ixo^s,mom(idim))/wmean(ixo^s,rho_)
      call mhd_get_csound(wmean,x,ixi^l,ixo^l,idim,csoundr)
      if(present(cmin)) then
        cmax(ixo^s,1)=max(tmp1(ixo^s)+csoundr(ixo^s),zero)
        cmin(ixo^s,1)=min(tmp1(ixo^s)-csoundr(ixo^s),zero)
        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(tmp1(ixo^s))+csoundr(ixo^s)
      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)
      csoundl(ixo^s)=max(csoundl(ixo^s),csoundr(ixo^s))
      if(present(cmin)) then
        cmin(ixo^s,1)=min(wlp(ixo^s,mom(idim)),wrp(ixo^s,mom(idim)))-csoundl(ixo^s)
        cmax(ixo^s,1)=max(wlp(ixo^s,mom(idim)),wrp(ixo^s,mom(idim)))+csoundl(ixo^s)
        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)=max(wlp(ixo^s,mom(idim)),wrp(ixo^s,mom(idim)))+csoundl(ixo^s)
      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
 
    ! Miyoshi 2005 JCP 208, 315 equation (67)
    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)
    csoundl(ixo^s)=max(csoundl(ixo^s),csoundr(ixo^s))
    if(present(cmin)) then
      cmin(ixo^s,1)=min(gamma2l*wlp(ixo^s,mom(idim)),gamma2r*wrp(ixo^s,mom(idim)))-csoundl(ixo^s)
      cmax(ixo^s,1)=max(gamma2l*wlp(ixo^s,mom(idim)),gamma2r*wrp(ixo^s,mom(idim)))+csoundl(ixo^s)
    else
      cmax(ixo^s,1)=max(gamma2l*wlp(ixo^s,mom(idim)),gamma2r*wrp(ixo^s,mom(idim)))+csoundl(ixo^s)
    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)
    double precision, dimension(ixI^S) :: umean, dmean, csoundL, csoundR, tmp1,tmp2,tmp3
    integer :: ix^D
    double precision :: rho(ixI^S)
 
    select case (boundspeed)
    case (1)
      ! This implements formula (10.52) from "Riemann Solvers and Numerical
      ! Methods for Fluid Dynamics" by Toro.
      tmp1(ixo^s)=sqrt(wlp(ixo^s,rho_)+block%equi_vars(ixo^s,equi_rho0_,b0i))
      tmp2(ixo^s)=sqrt(wrp(ixo^s,rho_)+block%equi_vars(ixo^s,equi_rho0_,b0i))
      tmp3(ixo^s)=1.d0/(tmp1(ixo^s)+tmp2(ixo^s))
      umean(ixo^s)=(wlp(ixo^s,mom(idim))*tmp1(ixo^s)+wrp(ixo^s,mom(idim))*tmp2(ixo^s))*tmp3(ixo^s)
      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)
      dmean(ixo^s)=(tmp1(ixo^s)*csoundl(ixo^s)**2+tmp2(ixo^s)*csoundr(ixo^s)**2)*tmp3(ixo^s)+&
       0.5d0*tmp1(ixo^s)*tmp2(ixo^s)*tmp3(ixo^s)**2*&
       (wrp(ixo^s,mom(idim))-wlp(ixo^s,mom(idim)))**2
      dmean(ixo^s)=sqrt(dmean(ixo^s))
      if(present(cmin)) then
        cmin(ixo^s,1)=umean(ixo^s)-dmean(ixo^s)
        cmax(ixo^s,1)=umean(ixo^s)+dmean(ixo^s)
        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(umean(ixo^s))+dmean(ixo^s)
      end if
    case (2)
      wmean(ixo^s,1:nwflux)=0.5d0*(wlc(ixo^s,1:nwflux)+wrc(ixo^s,1:nwflux))
      tmp1(ixo^s)=wmean(ixo^s,mom(idim))/(wmean(ixo^s,rho_)+block%equi_vars(ixo^s,equi_rho0_,b0i))
      call mhd_get_csound(wmean,x,ixi^l,ixo^l,idim,csoundr)
      if(present(cmin)) then
        cmax(ixo^s,1)=max(tmp1(ixo^s)+csoundr(ixo^s),zero)
        cmin(ixo^s,1)=min(tmp1(ixo^s)-csoundr(ixo^s),zero)
        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(tmp1(ixo^s))+csoundr(ixo^s)
      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)
      csoundl(ixo^s)=max(csoundl(ixo^s),csoundr(ixo^s))
      if(present(cmin)) then
        cmin(ixo^s,1)=min(wlp(ixo^s,mom(idim)),wrp(ixo^s,mom(idim)))-csoundl(ixo^s)
        cmax(ixo^s,1)=max(wlp(ixo^s,mom(idim)),wrp(ixo^s,mom(idim)))+csoundl(ixo^s)
        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)=max(wlp(ixo^s,mom(idim)),wrp(ixo^s,mom(idim)))+csoundl(ixo^s)
      end if
    end select
 
  end subroutine mhd_get_cbounds_split_rho
 
  !> prepare velocities for ct methods
  subroutine mhd_get_ct_velocity(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
 
    ! calculate velocities related to different UCT schemes
    select case(type_ct)
    case('average')
    case('uct_contact')
      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)))
    case('uct_hll')
      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,1))&
          /(vcts%cbarmax(ixo^s,idim)+vcts%cbarmin(ixo^s,idim))
    case default
      call mpistop('choose average, uct_contact,or uct_hll for type_ct!')
    end select
 
  end subroutine mhd_get_ct_velocity
 
  !> Calculate fast magnetosonic wave speed
  subroutine mhd_get_csound(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(ixI^S)
    double precision :: cfast2(ixI^S), AvMinCs2(ixI^S), b2(ixI^S), kmax
    double precision :: inv_rho(ixO^S)
 
    if(has_equi_rho0) then
      inv_rho(ixo^s) = 1d0/(w(ixo^s,rho_) + block%equi_vars(ixo^s,equi_rho0_,b0i))
    else
      inv_rho(ixo^s) = 1d0/w(ixo^s,rho_)
    endif
 
    call mhd_get_csound2(w,x,ixi^l,ixo^l,csound)
 
    ! store |B|^2 in v
    b2(ixo^s) = mhd_mag_en_all(w,ixi^l,ixo^l)
 
    cfast2(ixo^s)   = b2(ixo^s) * inv_rho+csound(ixo^s)
    avmincs2(ixo^s) = cfast2(ixo^s)**2-4.0d0*csound(ixo^s) &
         * mhd_mag_i_all(w,ixi^l,ixo^l,idim)**2 * inv_rho
 
    where(avmincs2(ixo^s)<zero)
       avmincs2(ixo^s)=zero
    end where
 
    avmincs2(ixo^s)=sqrt(avmincs2(ixo^s))
 
    if (.not. mhd_hall) then
       csound(ixo^s) = sqrt(half*(cfast2(ixo^s)+avmincs2(ixo^s)))
       if (mhd_boris_simplification) then
          ! equation (88)
          csound(ixo^s) = mhd_gamma_alfven(w, ixi^l,ixo^l) * csound(ixo^s)
       end if
    else
       ! 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)
       kmax = dpi/min({dxlevel(^d)},bigdouble)*half
       csound(ixo^s) = max(sqrt(half*(cfast2(ixo^s)+avmincs2(ixo^s))), &
            mhd_etah * sqrt(b2(ixo^s))*inv_rho*kmax)
    end if
 
  end subroutine mhd_get_csound
 
  !> Calculate fast magnetosonic wave speed
  subroutine mhd_get_csound_prim(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(ixI^S)
    double precision :: cfast2(ixI^S), AvMinCs2(ixI^S), b2(ixI^S), kmax
    double precision :: inv_rho(ixO^S)
    double precision :: tmp(ixI^S)
 
    call mhd_get_rho(w,x,ixi^l,ixo^l,tmp)
    inv_rho(ixo^s) = 1d0/tmp(ixo^s)
 
 
    if(mhd_energy) then
      if(has_equi_pe0) then
        csound(ixo^s) = w(ixo^s,e_) + block%equi_vars(ixo^s,equi_pe0_,b0i)
      else
        csound(ixo^s) = w(ixo^s,e_)
      endif
      csound(ixo^s)=mhd_gamma*csound(ixo^s)*inv_rho
    else
      csound(ixo^s)=mhd_gamma*mhd_adiab*tmp(ixo^s)**gamma_1
    end if
 
    ! store |B|^2 in v
    b2(ixo^s)        = mhd_mag_en_all(w,ixi^l,ixo^l)
    cfast2(ixo^s)   = b2(ixo^s) * inv_rho+csound(ixo^s)
    avmincs2(ixo^s) = cfast2(ixo^s)**2-4.0d0*csound(ixo^s) &
         * mhd_mag_i_all(w,ixi^l,ixo^l,idim)**2 * inv_rho
 
    where(avmincs2(ixo^s)<zero)
       avmincs2(ixo^s)=zero
    end where
 
    avmincs2(ixo^s)=sqrt(avmincs2(ixo^s))
 
    if (.not. mhd_hall) then
       csound(ixo^s) = sqrt(half*(cfast2(ixo^s)+avmincs2(ixo^s)))
       if (mhd_boris_simplification) then
          ! equation (88)
          csound(ixo^s) = mhd_gamma_alfven(w, ixi^l,ixo^l) * csound(ixo^s)
       end if
    else
       ! 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)
       kmax = dpi/min({dxlevel(^d)},bigdouble)*half
       csound(ixo^s) = max(sqrt(half*(cfast2(ixo^s)+avmincs2(ixo^s))), &
            mhd_etah * sqrt(b2(ixo^s))*inv_rho*kmax)
    end if
 
  end subroutine mhd_get_csound_prim
 
  !> 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(ixO^S), kmax
    double precision :: inv_rho(ixO^S), Alfven_speed2(ixO^S), idim_Alfven_speed2(ixO^S),B(ixO^S,1:ndir)
 
    if(b0field) then
      b(ixo^s,1:ndir)=w(ixo^s,mag(1:ndir))+block%B0(ixo^s,1:ndir,b0i)
    else
      b(ixo^s,1:ndir)=w(ixo^s,mag(1:ndir))
    end if
 
    inv_rho = 1.d0/w(ixo^s,rho_)
 
    alfven_speed2=sum(b(ixo^s,:)**2,dim=ndim+1)*inv_rho
    gamma2 = 1.0d0/(1.d0+alfven_speed2*inv_squared_c)
 
    avmincs2=1.d0-gamma2*w(ixo^s,mom(idim))**2*inv_squared_c
    ! equatoin (69)
    alfven_speed2=alfven_speed2*avmincs2
 
    ! squared sound speed
    if(mhd_energy) then
      csound(ixo^s)=mhd_gamma*w(ixo^s,p_)*inv_rho
    else
      csound(ixo^s)=mhd_gamma*mhd_adiab*w(ixo^s,rho_)**gamma_1
    end if
 
    idim_alfven_speed2=b(ixo^s,idim)**2*inv_rho
 
    ! Va_hat^2+a_hat^2 equation (57)
    alfven_speed2=alfven_speed2+csound(ixo^s)*(1.d0+idim_alfven_speed2*inv_squared_c)
 
    avmincs2=(gamma2*alfven_speed2)**2-4.0d0*gamma2*csound(ixo^s)*idim_alfven_speed2*avmincs2
 
    where(avmincs2<zero)
       avmincs2=zero
    end where
 
    ! equation (68) fast magnetosonic speed
    csound(ixo^s) = sqrt(half*(gamma2*alfven_speed2+sqrt(avmincs2)))
 
  end subroutine mhd_get_csound_semirelati
 
  !> Calculate thermal pressure=(gamma-1)*(e-0.5*m**2/rho-b**2/2) within ixO^L
  subroutine mhd_get_pthermal_origin(w,x,ixI^L,ixO^L,pth)
    use mod_global_parameters
    use mod_small_values, only: trace_small_values
 
    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):: pth(ixI^S)
    integer                      :: iw, ix^D
 
    if(mhd_energy) then
      if(mhd_internal_e) then
        pth(ixo^s)=gamma_1*w(ixo^s,e_)
      else
        pth(ixo^s)=gamma_1*(w(ixo^s,e_)&
           - mhd_kin_en(w,ixi^l,ixo^l)&
           - mhd_mag_en(w,ixi^l,ixo^l))
      end if
      if(has_equi_pe0) then
        pth(ixo^s) = pth(ixo^s) + block%equi_vars(ixo^s,equi_pe0_,b0i)
      endif
    else
      call mhd_get_rho(w,x,ixi^l,ixo^l,pth)
      pth(ixo^s)=mhd_adiab*pth(ixo^s)**mhd_gamma
    end if
 
    if (fix_small_values) then
      {do ix^db= ixo^lim^db\}
         if(pth(ix^d)<small_pressure) then
            pth(ix^d)=small_pressure
         end if
      {enddo^d&\}
    end if
 
    if (check_small_values) then
      {do ix^db= ixo^lim^db\}
         if(pth(ix^d)<small_pressure) then
           write(*,*) "Error: small value of gas pressure",pth(ix^d),&
                " encountered when call mhd_get_pthermal"
           write(*,*) "Iteration: ", it, " Time: ", global_time
           write(*,*) "Location: ", x(ix^d,:)
           write(*,*) "Cell number: ", ix^d
           do iw=1,nw
             write(*,*) trim(cons_wnames(iw)),": ",w(ix^d,iw)
           end do
           ! use erroneous arithmetic operation to crash the run
           if(trace_small_values) write(*,*) sqrt(pth(ix^d)-bigdouble)
           write(*,*) "Saving status at the previous time step"
           crash=.true.
         end if
      {enddo^d&\}
    end if
 
  end subroutine mhd_get_pthermal_origin
 
  !> Calculate thermal pressure=(gamma-1)*(e-0.5*m**2/rho-b**2/2) within ixO^L
  subroutine mhd_get_pthermal_semirelati(w,x,ixI^L,ixO^L,pth)
    use mod_global_parameters
    use mod_small_values, only: trace_small_values
 
    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):: pth(ixI^S)
    integer                      :: iw, ix^D
 
    double precision :: wprim(ixI^S,nw)
 
    if(mhd_energy) then
      wprim=w
      call mhd_to_primitive_semirelati(ixi^l,ixo^l,wprim,x)
      pth(ixo^s)=wprim(ixo^s,p_)
    else
      pth(ixo^s)=mhd_adiab*w(ixo^s,rho_)**mhd_gamma
    end if
 
    if (check_small_values) then
      {do ix^db= ixo^lim^db\}
         if(pth(ix^d)<small_pressure) then
           write(*,*) "Error: small value of gas pressure",pth(ix^d),&
                " encountered when call mhd_get_pthermal_semirelati"
           write(*,*) "Iteration: ", it, " Time: ", global_time
           write(*,*) "Location: ", x(ix^d,:)
           write(*,*) "Cell number: ", ix^d
           do iw=1,nw
             write(*,*) trim(cons_wnames(iw)),": ",w(ix^d,iw)
           end do
           ! use erroneous arithmetic operation to crash the run
           if(trace_small_values) write(*,*) sqrt(pth(ix^d)-bigdouble)
           write(*,*) "Saving status at the previous time step"
           crash=.true.
         end if
      {enddo^d&\}
    end if
 
  end subroutine mhd_get_pthermal_semirelati
 
  !> Calculate thermal pressure=(gamma-1)*(e-0.5*m**2/rho-b**2/2) within ixO^L
  subroutine mhd_get_pthermal_hde(w,x,ixI^L,ixO^L,pth)
    use mod_global_parameters
    use mod_small_values, only: trace_small_values
 
    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):: pth(ixI^S)
    integer                      :: iw, ix^D
 
    if(mhd_energy) then
      pth(ixo^s)=gamma_1*(w(ixo^s,e_)-mhd_kin_en(w,ixi^l,ixo^l))
    else
      pth(ixo^s)=mhd_adiab*w(ixo^s,rho_)**mhd_gamma
    end if
 
    if (fix_small_values) then
      {do ix^db= ixo^lim^db\}
         if(pth(ix^d)<small_pressure) then
            pth(ix^d)=small_pressure
         end if
      {enddo^d&\}
    end if
 
    if (check_small_values) then
      {do ix^db= ixo^lim^db\}
         if(pth(ix^d)<small_pressure) then
           write(*,*) "Error: small value of gas pressure",pth(ix^d),&
                " encountered when call mhd_get_pthermal_hde"
           write(*,*) "Iteration: ", it, " Time: ", global_time
           write(*,*) "Location: ", x(ix^d,:)
           write(*,*) "Cell number: ", ix^d
           do iw=1,nw
             write(*,*) trim(cons_wnames(iw)),": ",w(ix^d,iw)
           end do
           ! use erroneous arithmetic operation to crash the run
           if(trace_small_values) write(*,*) sqrt(pth(ix^d)-bigdouble)
           write(*,*) "Saving status at the previous time step"
           crash=.true.
         end if
      {enddo^d&\}
    end if
 
  end subroutine mhd_get_pthermal_hde
 
  !> Calculate temperature=p/rho when in e_ the internal energy is stored
  subroutine mhd_get_temperature_from_eint(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, 1:nw)
    double precision, intent(in) :: x(ixI^S, 1:ndim)
    double precision, intent(out):: res(ixI^S)
    res(ixo^s) = gamma_1 * w(ixo^s, e_) /w(ixo^s,rho_)
  end subroutine mhd_get_temperature_from_eint
 
  !> Calculate temperature=p/rho when in e_ the total energy is stored
  !> this does not check the values of mhd_energy and mhd_internal_e,
  !>  mhd_energy = .true. and mhd_internal_e = .false.
  !> also check small_values is avoided
  subroutine mhd_get_temperature_from_etot(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, 1:nw)
    double precision, intent(in) :: x(ixI^S, 1:ndim)
    double precision, intent(out):: res(ixI^S)
    res(ixo^s)=(gamma_1*(w(ixo^s,e_)&
           - mhd_kin_en(w,ixi^l,ixo^l)&
           - mhd_mag_en(w,ixi^l,ixo^l)))/w(ixo^s,rho_)
  end subroutine mhd_get_temperature_from_etot
 
  !> Calculate temperature from hydrodynamic energy
  subroutine mhd_get_temperature_from_hde(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, 1:nw)
    double precision, intent(in) :: x(ixI^S, 1:ndim)
    double precision, intent(out):: res(ixI^S)
    res(ixo^s)=gamma_1*(w(ixo^s,e_)&
           - mhd_kin_en(w,ixi^l,ixo^l))/w(ixo^s,rho_)
  end subroutine mhd_get_temperature_from_hde
 
  subroutine mhd_get_temperature_from_eint_with_equi(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, 1:nw)
    double precision, intent(in) :: x(ixI^S, 1:ndim)
    double precision, intent(out):: res(ixI^S)
    res(ixo^s) = (gamma_1 * w(ixo^s, e_) + block%equi_vars(ixo^s,equi_pe0_,b0i)) /&
                (w(ixo^s,rho_) +block%equi_vars(ixo^s,equi_rho0_,b0i))
  end subroutine mhd_get_temperature_from_eint_with_equi
 
  subroutine mhd_get_temperature_equi(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, 1:nw)
    double precision, intent(in) :: x(ixI^S, 1:ndim)
    double precision, intent(out):: res(ixI^S)
    res(ixo^s)= block%equi_vars(ixo^s,equi_pe0_,b0i)/block%equi_vars(ixo^s,equi_rho0_,b0i)
  end subroutine mhd_get_temperature_equi
 
  subroutine mhd_get_rho_equi(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, 1:nw)
    double precision, intent(in) :: x(ixI^S, 1:ndim)
    double precision, intent(out):: res(ixI^S)
    res(ixo^s) = block%equi_vars(ixo^s,equi_rho0_,b0i)
  end subroutine mhd_get_rho_equi
 
  subroutine mhd_get_pe_equi(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, 1:nw)
    double precision, intent(in) :: x(ixI^S, 1:ndim)
    double precision, intent(out):: res(ixI^S)
    res(ixo^s) = block%equi_vars(ixo^s,equi_pe0_,b0i)
  end subroutine mhd_get_pe_equi
 
  subroutine mhd_get_temperature_from_etot_with_equi(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, 1:nw)
    double precision, intent(in) :: x(ixI^S, 1:ndim)
    double precision, intent(out):: res(ixI^S)
    res(ixo^s)=(gamma_1*(w(ixo^s,e_)&
           - mhd_kin_en(w,ixi^l,ixo^l)&
           - mhd_mag_en(w,ixi^l,ixo^l)) +  block%equi_vars(ixo^s,equi_pe0_,b0i))&
            /(w(ixo^s,rho_) +block%equi_vars(ixo^s,equi_rho0_,b0i))
            
  end subroutine mhd_get_temperature_from_etot_with_equi
 
  !> Calculate the square of the thermal sound speed csound2 within ixO^L.
  !> csound2=gamma*p/rho
  subroutine mhd_get_csound2(w,x,ixI^L,ixO^L,csound2)
    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)   :: csound2(ixi^s)
    double precision    :: rho(ixi^s)
    
    call mhd_get_rho(w,x,ixi^l,ixo^l,rho)
    if(mhd_energy) then
      call mhd_get_pthermal(w,x,ixi^l,ixo^l,csound2)
      csound2(ixo^s)=mhd_gamma*csound2(ixo^s)/rho(ixo^s)
    else
      csound2(ixo^s)=mhd_gamma*mhd_adiab*rho(ixo^s)**gamma_1
    end if
  end subroutine mhd_get_csound2
 
  !> Calculate total pressure within ixO^L including magnetic pressure
  subroutine mhd_get_p_total(w,x,ixI^L,ixO^L,p)
    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)   :: p(ixI^S)
 
    call mhd_get_pthermal(w,x,ixi^l,ixo^l,p)
 
    p(ixo^s) = p(ixo^s) + 0.5d0 * sum(w(ixo^s, mag(:))**2, dim=ndim+1)
 
  end subroutine mhd_get_p_total
 
  !> 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             :: ptotal(ixO^S)
    double precision             :: tmp(ixI^S)
    double precision             :: vHall(ixI^S,1:ndir)
    integer                      :: idirmin, iw, idir, jdir, kdir
    double precision, allocatable, dimension(:^D&,:) :: Jambi, btot
    double precision, allocatable, dimension(:^D&) :: tmp2, tmp3
 
    ! Get flux of density
    f(ixo^s,rho_)=w(ixo^s,mom(idim))*w(ixo^s,rho_)
 
    if(mhd_energy) then
      ptotal(ixo^s)=w(ixo^s,p_)+0.5d0*sum(w(ixo^s,mag(:))**2,dim=ndim+1)
    else
      ptotal(ixo^s)=mhd_adiab*w(ixo^s,rho_)**mhd_gamma+0.5d0*sum(w(ixo^s,mag(:))**2,dim=ndim+1)
    end if
 
    if (mhd_hall) then
      call mhd_getv_hall(w,x,ixi^l,ixo^l,vhall)
    end if
 
    ! Get flux of tracer
    do iw=1,mhd_n_tracer
      f(ixo^s,tracer(iw))=w(ixo^s,mom(idim))*w(ixo^s,tracer(iw))
    end do
 
    ! Get flux of momentum
    ! f_i[m_k]=v_i*m_k-b_k*b_i [+ptotal if i==k]
    do idir=1,ndir
      if(idim==idir) then
        f(ixo^s,mom(idir))=wc(ixo^s,mom(idir))*w(ixo^s,mom(idim))+ptotal(ixo^s)-&
                            w(ixo^s,mag(idir))*w(ixo^s,mag(idim))
      else
        f(ixo^s,mom(idir))=wc(ixo^s,mom(idir))*w(ixo^s,mom(idim))-&
                            w(ixo^s,mag(idir))*w(ixo^s,mag(idim))
      end if
    end do
 
    ! Get flux of energy
    ! f_i[e]=v_i*e+v_i*ptotal-b_i*(b_k*v_k)
    if(mhd_energy) then
      if (mhd_internal_e) then
         f(ixo^s,e_)=w(ixo^s,mom(idim))*wc(ixo^s,e_)
      else
        f(ixo^s,e_)=w(ixo^s,mom(idim))*(wc(ixo^s,e_)+ptotal(ixo^s))&
           -w(ixo^s,mag(idim))*sum(w(ixo^s,mag(:))*w(ixo^s,mom(:)),dim=ndim+1)
        if(mhd_solve_eaux) f(ixo^s,eaux_)=w(ixo^s,mom(idim))*wc(ixo^s,eaux_)
        if(mhd_hall) then
        ! f_i[e]= f_i[e] + vHall_i*(b_k*b_k) - b_i*(vHall_k*b_k)
          f(ixo^s,e_) = f(ixo^s,e_) + vhall(ixo^s,idim) * &
             sum(w(ixo^s, mag(:))**2,dim=ndim+1) &
             - w(ixo^s,mag(idim)) * sum(vhall(ixo^s,:)*w(ixo^s,mag(:)),dim=ndim+1)
        end if
      end if
    end if
 
    ! compute flux of magnetic field
    ! f_i[b_k]=v_i*b_k-v_k*b_i
    do idir=1,ndir
      if (idim==idir) then
        ! f_i[b_i] should be exactly 0, so we do not use the transport flux
        if (mhd_glm) then
           f(ixo^s,mag(idir))=w(ixo^s,psi_)
        else
           f(ixo^s,mag(idir))=zero
        end if
      else
        f(ixo^s,mag(idir))=w(ixo^s,mom(idim))*w(ixo^s,mag(idir))-w(ixo^s,mag(idim))*w(ixo^s,mom(idir))
        if (mhd_hall) then
          ! f_i[b_k] = f_i[b_k] + vHall_i*b_k - vHall_k*b_i
          f(ixo^s,mag(idir)) = f(ixo^s,mag(idir)) &
               - vhall(ixo^s,idir)*w(ixo^s,mag(idim)) &
               + vhall(ixo^s,idim)*w(ixo^s,mag(idir))
        end if
      end if
    end do
 
    if (mhd_glm) then
      !f_i[psi]=Ch^2*b_{i} Eq. 24e and Eq. 38c Dedner et al 2002 JCP, 175, 645
      f(ixo^s,psi_)  = cmax_global**2*w(ixo^s,mag(idim))
    end if
 
    ! Contributions of ambipolar term in explicit scheme
    if(mhd_ambipolar_exp.and. .not.stagger_grid) then
      ! ambipolar electric field
      ! E_ambi=-eta_ambi*JxBxB=-JaxBxB=B^2*Ja-(Ja dot B)*B
      !Ja=eta_ambi*J=J * mhd_eta_ambi/rho**2
      allocate(jambi(ixi^s,1:3))
      call mhd_get_jambi(w,x,ixi^l,ixo^l,jambi)
      allocate(btot(ixo^s,1:3))
      btot(ixo^s,1:3) = w(ixo^s,mag(1:3))
      allocate(tmp2(ixo^s),tmp3(ixo^s))
      !tmp2 = Btot^2
      tmp2(ixo^s) = sum(btot(ixo^s,1:3)**2,dim=ndim+1)
      !tmp3 = J_ambi dot Btot
      tmp3(ixo^s) = sum(jambi(ixo^s,:)*btot(ixo^s,:),dim=ndim+1)
 
      select case(idim)
        case(1)
          tmp(ixo^s)=w(ixo^s,mag(3)) *jambi(ixo^s,2) - w(ixo^s,mag(2)) * jambi(ixo^s,3)
          f(ixo^s,mag(2))= f(ixo^s,mag(2)) - tmp2(ixo^s) * jambi(ixo^s,3) + tmp3(ixo^s) * btot(ixo^s,3)
          f(ixo^s,mag(3))= f(ixo^s,mag(3)) + tmp2(ixo^s) * jambi(ixo^s,2) - tmp3(ixo^s) * btot(ixo^s,2)
        case(2)
          tmp(ixo^s)=w(ixo^s,mag(1)) *jambi(ixo^s,3) - w(ixo^s,mag(3)) * jambi(ixo^s,1)
          f(ixo^s,mag(1))= f(ixo^s,mag(1)) + tmp2(ixo^s) * jambi(ixo^s,3) - tmp3(ixo^s) * btot(ixo^s,3)
          f(ixo^s,mag(3))= f(ixo^s,mag(3)) - tmp2(ixo^s) * jambi(ixo^s,1) + tmp3(ixo^s) * btot(ixo^s,1)
        case(3)
          tmp(ixo^s)=w(ixo^s,mag(2)) *jambi(ixo^s,1) - w(ixo^s,mag(1)) * jambi(ixo^s,2)
          f(ixo^s,mag(1))= f(ixo^s,mag(1)) - tmp2(ixo^s) * jambi(ixo^s,2) + tmp3(ixo^s) * btot(ixo^s,2)
          f(ixo^s,mag(2))= f(ixo^s,mag(2)) + tmp2(ixo^s) * jambi(ixo^s,1) - tmp3(ixo^s) * btot(ixo^s,1)
      endselect
 
      if(mhd_energy .and. .not. mhd_internal_e) then
        f(ixo^s,e_) = f(ixo^s,e_) + tmp2(ixo^s) *  tmp(ixo^s)
      endif
 
      deallocate(jambi,btot,tmp2,tmp3)
    endif
 
  end subroutine mhd_get_flux
 
  !> Calculate fluxes within ixO^L without any splitting
  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             :: pgas(ixO^S), ptotal(ixO^S)
    double precision             :: tmp(ixI^S)
    integer                      :: idirmin, iw, idir, jdir, kdir
    double precision, allocatable, dimension(:^D&,:) :: Jambi, btot
    double precision, allocatable, dimension(:^D&) :: tmp2, tmp3
 
    ! Get flux of density
    f(ixo^s,rho_)=w(ixo^s,mom(idim))*w(ixo^s,rho_)
    ! pgas is time dependent only
    if(mhd_energy) then
      pgas(ixo^s)=w(ixo^s,p_)
    else
      pgas(ixo^s)=mhd_adiab*w(ixo^s,rho_)**mhd_gamma
    end if
 
    ptotal(ixo^s)=pgas(ixo^s)+0.5d0*sum(w(ixo^s,mag(:))**2,dim=ndim+1)
 
    ! Get flux of tracer
    do iw=1,mhd_n_tracer
      f(ixo^s,tracer(iw))=w(ixo^s,mom(idim))*w(ixo^s,tracer(iw))
    end do
 
    ! Get flux of momentum
    ! f_i[m_k]=v_i*m_k-b_k*b_i [+ptotal if i==k]
    do idir=1,ndir
      if(idim==idir) then
        f(ixo^s,mom(idir))=wc(ixo^s,mom(idir))*w(ixo^s,mom(idim))+ptotal(ixo^s)-&
                            w(ixo^s,mag(idir))*w(ixo^s,mag(idim))
      else
        f(ixo^s,mom(idir))=wc(ixo^s,mom(idir))*w(ixo^s,mom(idim))-&
                            w(ixo^s,mag(idir))*w(ixo^s,mag(idim))
      end if
    end do
 
    ! Get flux of energy
    if(mhd_energy) then
      f(ixo^s,e_)=w(ixo^s,mom(idim))*(wc(ixo^s,e_)+pgas(ixo^s))
    end if
 
    ! compute flux of magnetic field
    ! f_i[b_k]=v_i*b_k-v_k*b_i
    do idir=1,ndir
      if (idim==idir) then
        ! f_i[b_i] should be exactly 0, so we do not use the transport flux
        if (mhd_glm) then
           f(ixo^s,mag(idir))=w(ixo^s,psi_)
        else
           f(ixo^s,mag(idir))=zero
        end if
      else
        f(ixo^s,mag(idir))=w(ixo^s,mom(idim))*w(ixo^s,mag(idir))-w(ixo^s,mag(idim))*w(ixo^s,mom(idir))
      end if
    end do
 
    if (mhd_glm) then
      !f_i[psi]=Ch^2*b_{i} Eq. 24e and Eq. 38c Dedner et al 2002 JCP, 175, 645
      f(ixo^s,psi_)  = cmax_global**2*w(ixo^s,mag(idim))
    end if
 
    ! Contributions of ambipolar term in explicit scheme
    if(mhd_ambipolar_exp.and. .not.stagger_grid) then
      ! ambipolar electric field
      ! E_ambi=-eta_ambi*JxBxB=-JaxBxB=B^2*Ja-(Ja dot B)*B
      !Ja=eta_ambi*J=J * mhd_eta_ambi/rho**2
      allocate(jambi(ixi^s,1:3))
      call mhd_get_jambi(w,x,ixi^l,ixo^l,jambi)
      allocate(btot(ixo^s,1:3))
      btot(ixo^s,1:3) = w(ixo^s,mag(1:3))
      allocate(tmp2(ixo^s),tmp3(ixo^s))
      !tmp2 = Btot^2
      tmp2(ixo^s) = sum(btot(ixo^s,1:3)**2,dim=ndim+1)
      !tmp3 = J_ambi dot Btot
      tmp3(ixo^s) = sum(jambi(ixo^s,:)*btot(ixo^s,:),dim=ndim+1)
 
      select case(idim)
        case(1)
          tmp(ixo^s)=w(ixo^s,mag(3)) *jambi(ixo^s,2) - w(ixo^s,mag(2)) * jambi(ixo^s,3)
          f(ixo^s,mag(2))= f(ixo^s,mag(2)) - tmp2(ixo^s) * jambi(ixo^s,3) + tmp3(ixo^s) * btot(ixo^s,3)
          f(ixo^s,mag(3))= f(ixo^s,mag(3)) + tmp2(ixo^s) * jambi(ixo^s,2) - tmp3(ixo^s) * btot(ixo^s,2)
        case(2)
          tmp(ixo^s)=w(ixo^s,mag(1)) *jambi(ixo^s,3) - w(ixo^s,mag(3)) * jambi(ixo^s,1)
          f(ixo^s,mag(1))= f(ixo^s,mag(1)) + tmp2(ixo^s) * jambi(ixo^s,3) - tmp3(ixo^s) * btot(ixo^s,3)
          f(ixo^s,mag(3))= f(ixo^s,mag(3)) - tmp2(ixo^s) * jambi(ixo^s,1) + tmp3(ixo^s) * btot(ixo^s,1)
        case(3)
          tmp(ixo^s)=w(ixo^s,mag(2)) *jambi(ixo^s,1) - w(ixo^s,mag(1)) * jambi(ixo^s,2)
          f(ixo^s,mag(1))= f(ixo^s,mag(1)) - tmp2(ixo^s) * jambi(ixo^s,2) + tmp3(ixo^s) * btot(ixo^s,2)
          f(ixo^s,mag(2))= f(ixo^s,mag(2)) + tmp2(ixo^s) * jambi(ixo^s,1) - tmp3(ixo^s) * btot(ixo^s,1)
      endselect
 
      if(mhd_energy) then
        f(ixo^s,e_) = f(ixo^s,e_) + tmp2(ixo^s) *  tmp(ixo^s)
      endif
 
      deallocate(jambi,btot,tmp2,tmp3)
    endif
 
  end subroutine mhd_get_flux_hde
 
  !> Calculate fluxes within ixO^L with possible splitting
  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             :: pgas(ixO^S), ptotal(ixO^S), B(ixO^S,1:ndir)
    double precision             :: tmp(ixI^S)
    double precision             :: vHall(ixI^S,1:ndir)
    integer                      :: idirmin, iw, idir, jdir, kdir
    double precision, allocatable, dimension(:^D&,:) :: Jambi, btot
    double precision, allocatable, dimension(:^D&) :: tmp2, tmp3
    double precision :: tmp4(ixO^S)
 
 
    call mhd_get_rho(w,x,ixi^l,ixo^l,tmp)
    ! Get flux of density
    f(ixo^s,rho_)=w(ixo^s,mom(idim))*tmp(ixo^s)
    ! pgas is time dependent only
    if(mhd_energy) then
      pgas(ixo^s)=w(ixo^s,p_)
    else
      pgas(ixo^s)=mhd_adiab*tmp(ixo^s)**mhd_gamma
      if(has_equi_pe0) then
        pgas(ixo^s)=pgas(ixo^s)-block%equi_vars(ixo^s,equi_pe0_,b0i)
      endif
    end if
 
    if (mhd_hall) then
      call mhd_getv_hall(w,x,ixi^l,ixo^l,vhall)
    end if
 
    if(b0field) then
      b(ixo^s,1:ndir)=w(ixo^s,mag(1:ndir))+block%B0(ixo^s,1:ndir,idim)
      pgas(ixo^s)=pgas(ixo^s)+sum(w(ixo^s,mag(:))*block%B0(ixo^s,:,idim),dim=ndim+1)
    else
      b(ixo^s,1:ndir)=w(ixo^s,mag(1:ndir))
    end if
 
    ptotal(ixo^s)=pgas(ixo^s)+0.5d0*sum(w(ixo^s,mag(:))**2,dim=ndim+1)
 
    ! Get flux of tracer
    do iw=1,mhd_n_tracer
      f(ixo^s,tracer(iw))=w(ixo^s,mom(idim))*w(ixo^s,tracer(iw))
    end do
 
    ! Get flux of momentum
    ! f_i[m_k]=v_i*m_k-b_k*b_i [+ptotal if i==k]
    if(b0field) then
      do idir=1,ndir
        if(idim==idir) then
          f(ixo^s,mom(idir))=wc(ixo^s,mom(idir))*w(ixo^s,mom(idim))+ptotal(ixo^s)-&
                              w(ixo^s,mag(idir))*b(ixo^s,idim)-&
                       block%B0(ixo^s,idir,idim)*w(ixo^s,mag(idim))
        else
          f(ixo^s,mom(idir))=wc(ixo^s,mom(idir))*w(ixo^s,mom(idim))-&
                              w(ixo^s,mag(idir))*b(ixo^s,idim)-&
                       block%B0(ixo^s,idir,idim)*w(ixo^s,mag(idim))
        end if
      end do
    else
      do idir=1,ndir
        if(idim==idir) then
          f(ixo^s,mom(idir))=wc(ixo^s,mom(idir))*w(ixo^s,mom(idim))+ptotal(ixo^s)-&
                              w(ixo^s,mag(idir))*b(ixo^s,idim)
        else
          f(ixo^s,mom(idir))=wc(ixo^s,mom(idir))*w(ixo^s,mom(idim))-&
                              w(ixo^s,mag(idir))*b(ixo^s,idim)
        end if
      end do
    end if
 
    ! Get flux of energy
    ! f_i[e]=v_i*e+v_i*ptotal-b_i*(b_k*v_k)
    if(mhd_energy) then
      if (mhd_internal_e) then
         f(ixo^s,e_)=w(ixo^s,mom(idim))*wc(ixo^s,e_)
      else
        f(ixo^s,e_)=w(ixo^s,mom(idim))*(wc(ixo^s,e_)+ptotal(ixo^s))&
           -b(ixo^s,idim)*sum(w(ixo^s,mag(:))*w(ixo^s,mom(:)),dim=ndim+1)
        if(mhd_solve_eaux) f(ixo^s,eaux_)=w(ixo^s,mom(idim))*wc(ixo^s,eaux_)
 
        if (mhd_hall) then
        ! f_i[e]= f_i[e] + vHall_i*(b_k*b_k) - b_i*(vHall_k*b_k)
           if (mhd_etah>zero) then
              f(ixo^s,e_) = f(ixo^s,e_) + vhall(ixo^s,idim) * &
                 sum(w(ixo^s, mag(:))*b(ixo^s,:),dim=ndim+1) &
                 - b(ixo^s,idim) * sum(vhall(ixo^s,:)*w(ixo^s,mag(:)),dim=ndim+1)
           end if
        end if
      end if
      if(has_equi_pe0) then
        f(ixo^s,e_)=  f(ixo^s,e_) &
          + w(ixo^s,mom(idim)) * block%equi_vars(ixo^s,equi_pe0_,idim) * inv_gamma_1
      end if
    end if
 
    ! compute flux of magnetic field
    ! f_i[b_k]=v_i*b_k-v_k*b_i
    do idir=1,ndir
      if (idim==idir) then
        ! f_i[b_i] should be exactly 0, so we do not use the transport flux
        if (mhd_glm) then
           f(ixo^s,mag(idir))=w(ixo^s,psi_)
        else
           f(ixo^s,mag(idir))=zero
        end if
      else
        f(ixo^s,mag(idir))=w(ixo^s,mom(idim))*b(ixo^s,idir)-b(ixo^s,idim)*w(ixo^s,mom(idir))
 
        if (mhd_hall) then
          ! f_i[b_k] = f_i[b_k] + vHall_i*b_k - vHall_k*b_i
          if (mhd_etah>zero) then
            f(ixo^s,mag(idir)) = f(ixo^s,mag(idir)) &
                 - vhall(ixo^s,idir)*b(ixo^s,idim) &
                 + vhall(ixo^s,idim)*b(ixo^s,idir)
          end if
        end if
 
      end if
    end do
 
    if (mhd_glm) then
      !f_i[psi]=Ch^2*b_{i} Eq. 24e and Eq. 38c Dedner et al 2002 JCP, 175, 645
      f(ixo^s,psi_)  = cmax_global**2*w(ixo^s,mag(idim))
    end if
 
    ! Contributions of ambipolar term in explicit scheme
    if(mhd_ambipolar_exp.and. .not.stagger_grid) then
      ! ambipolar electric field
      ! E_ambi=-eta_ambi*JxBxB=-JaxBxB=B^2*Ja-(Ja dot B)*B
      !Ja=eta_ambi*J=J * mhd_eta_ambi/rho**2
      allocate(jambi(ixi^s,1:3))
      call mhd_get_jambi(w,x,ixi^l,ixo^l,jambi)
      allocate(btot(ixo^s,1:3))
      if(b0field) then
        do idir=1,3
          btot(ixo^s, idir) = w(ixo^s,mag(idir)) + block%B0(ixo^s,idir,idim)
        enddo
      else
        btot(ixo^s,1:3) = w(ixo^s,mag(1:3))
      endif
      allocate(tmp2(ixo^s),tmp3(ixo^s))
      !tmp2 = Btot^2
      tmp2(ixo^s) = sum(btot(ixo^s,1:3)**2,dim=ndim+1)
      !tmp3 = J_ambi dot Btot
      tmp3(ixo^s) = sum(jambi(ixo^s,:)*btot(ixo^s,:),dim=ndim+1)
 
      select case(idim)
        case(1)
          tmp(ixo^s)=w(ixo^s,mag(3)) *jambi(ixo^s,2) - w(ixo^s,mag(2)) * jambi(ixo^s,3)
          if(b0field) tmp4(ixo^s) = w(ixo^s,mag(2)) * btot(ixo^s,3) - w(ixo^s,mag(3)) * btot(ixo^s,2)
          f(ixo^s,mag(2))= f(ixo^s,mag(2)) - tmp2(ixo^s) * jambi(ixo^s,3) + tmp3(ixo^s) * btot(ixo^s,3)
          f(ixo^s,mag(3))= f(ixo^s,mag(3)) + tmp2(ixo^s) * jambi(ixo^s,2) - tmp3(ixo^s) * btot(ixo^s,2)
        case(2)
          tmp(ixo^s)=w(ixo^s,mag(1)) *jambi(ixo^s,3) - w(ixo^s,mag(3)) * jambi(ixo^s,1)
          if(b0field) tmp4(ixo^s) = w(ixo^s,mag(3)) * btot(ixo^s,1) - w(ixo^s,mag(1)) * btot(ixo^s,3)
          f(ixo^s,mag(1))= f(ixo^s,mag(1)) + tmp2(ixo^s) * jambi(ixo^s,3) - tmp3(ixo^s) * btot(ixo^s,3)
          f(ixo^s,mag(3))= f(ixo^s,mag(3)) - tmp2(ixo^s) * jambi(ixo^s,1) + tmp3(ixo^s) * btot(ixo^s,1)
        case(3)
          tmp(ixo^s)=w(ixo^s,mag(2)) *jambi(ixo^s,1) - w(ixo^s,mag(1)) * jambi(ixo^s,2)
          if(b0field) tmp4(ixo^s) = w(ixo^s,mag(1)) * btot(ixo^s,2) - w(ixo^s,mag(2)) * btot(ixo^s,1)
          f(ixo^s,mag(1))= f(ixo^s,mag(1)) - tmp2(ixo^s) * jambi(ixo^s,2) + tmp3(ixo^s) * btot(ixo^s,2)
          f(ixo^s,mag(2))= f(ixo^s,mag(2)) + tmp2(ixo^s) * jambi(ixo^s,1) - tmp3(ixo^s) * btot(ixo^s,1)
      endselect
 
      if(mhd_energy .and. .not. mhd_internal_e) then
        f(ixo^s,e_) = f(ixo^s,e_) + tmp2(ixo^s) *  tmp(ixo^s)
        if(b0field) f(ixo^s,e_) = f(ixo^s,e_) +  tmp3(ixo^s) *  tmp4(ixo^s)
      endif
 
      deallocate(jambi,btot,tmp2,tmp3)
    endif
 
  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             :: pgas(ixO^S)
    double precision             :: SA(ixO^S), E(ixO^S,1:ndir), B(ixO^S,1:ndir)
    integer                      :: idirmin, iw, idir, jdir, kdir
 
    ! gas thermal pressure
    if(mhd_energy) then
      pgas(ixo^s)=w(ixo^s,p_)
    else
      pgas(ixo^s)=mhd_adiab*w(ixo^s,rho_)**mhd_gamma
    end if
 
    ! Get flux of density
    f(ixo^s,rho_)=w(ixo^s,mom(idim))*w(ixo^s,rho_)
 
    ! Get flux of tracer
    do iw=1,mhd_n_tracer
      f(ixo^s,tracer(iw))=w(ixo^s,mom(idim))*w(ixo^s,tracer(iw))
    end do
    ! E=-uxB=Bxu
    if(b0field) then
      b(ixo^s,1:ndir)=w(ixo^s,mag(1:ndir))+block%B0(ixo^s,1:ndir,idim)
      pgas(ixo^s)=pgas(ixo^s)+sum(w(ixo^s,mag(:))*block%B0(ixo^s,:,idim),dim=ndim+1)
    else
      b(ixo^s,1:ndir)=w(ixo^s,mag(1:ndir))
    end if
    e=0.d0
    do idir=1,ndir; do jdir=1,ndir; do kdir=1,ndir
      if(lvc(idir,jdir,kdir)==1)then
        e(ixo^s,idir)=e(ixo^s,idir)+b(ixo^s,jdir)*w(ixo^s,mom(kdir))
      else if(lvc(idir,jdir,kdir)==-1)then
        e(ixo^s,idir)=e(ixo^s,idir)-b(ixo^s,jdir)*w(ixo^s,mom(kdir))
      end if
    end do; end do; end do
 
    pgas(ixo^s)=pgas(ixo^s)+half*(sum(w(ixo^s,mag(:))**2,dim=ndim+1)+&
             sum(e(ixo^s,:)**2,dim=ndim+1)*inv_squared_c)
 
    ! Get flux of momentum
    if(b0field) then
      do idir=1,ndir
        if(idim==idir) then
          f(ixo^s,mom(idir))=w(ixo^s,rho_)*w(ixo^s,mom(idir))*w(ixo^s,mom(idim))+pgas&
           -w(ixo^s,mag(idir))*b(ixo^s,idim)-e(ixo^s,idir)*e(ixo^s,idim)*inv_squared_c&
           -block%B0(ixo^s,idir,idim)*w(ixo^s,mag(idim))
        else
          f(ixo^s,mom(idir))=w(ixo^s,rho_)*w(ixo^s,mom(idir))*w(ixo^s,mom(idim))&
           -w(ixo^s,mag(idir))*b(ixo^s,idim)-e(ixo^s,idir)*e(ixo^s,idim)*inv_squared_c&
           -block%B0(ixo^s,idir,idim)*w(ixo^s,mag(idim))
        end if
      end do
    else
      do idir=1,ndir
        if(idim==idir) then
          f(ixo^s,mom(idir))=w(ixo^s,rho_)*w(ixo^s,mom(idir))*w(ixo^s,mom(idim))+pgas&
           -w(ixo^s,mag(idir))*b(ixo^s,idim)-e(ixo^s,idir)*e(ixo^s,idim)*inv_squared_c
        else
          f(ixo^s,mom(idir))=w(ixo^s,rho_)*w(ixo^s,mom(idir))*w(ixo^s,mom(idim))&
           -w(ixo^s,mag(idir))*b(ixo^s,idim)-e(ixo^s,idir)*e(ixo^s,idim)*inv_squared_c
        end if
      end do
    end if
 
    ! Get flux of energy
    if(mhd_energy) then
      sa=0.d0
      do jdir=1,ndir; do kdir=1,ndir
        if(lvc(idim,jdir,kdir)==1)then
          sa(ixo^s)=sa(ixo^s)+e(ixo^s,jdir)*w(ixo^s,mag(kdir))
        else if(lvc(idim,jdir,kdir)==-1) then
          sa(ixo^s)=sa(ixo^s)-e(ixo^s,jdir)*w(ixo^s,mag(kdir))
        end if
      end do; end do
      f(ixo^s,e_)=w(ixo^s,mom(idim))*(half*w(ixo^s,rho_)*sum(w(ixo^s,mom(:))**2,dim=ndim+1)+&
                  mhd_gamma*pgas*inv_gamma_1)+sa(ixo^s)
    end if
 
    ! compute flux of magnetic field
    ! f_i[b_k]=v_i*b_k-v_k*b_i
    do idir=1,ndir
      if (idim==idir) then
        ! f_i[b_i] should be exactly 0, so we do not use the transport flux
        if (mhd_glm) then
           f(ixo^s,mag(idir))=w(ixo^s,psi_)
        else
           f(ixo^s,mag(idir))=zero
        end if
      else
        f(ixo^s,mag(idir))=w(ixo^s,mom(idim))*b(ixo^s,idir)-b(ixo^s,idim)*w(ixo^s,mom(idir))
      end if
    end do
 
    if (mhd_glm) then
      !f_i[psi]=Ch^2*b_{i} Eq. 24e and Eq. 38c Dedner et al 2002 JCP, 175, 645
      f(ixo^s,psi_)  = cmax_global**2*w(ixo^s,mag(idim))
    end if
 
  end subroutine mhd_get_flux_semirelati
 
  !> Source terms J.E in internal energy.
  !> For the ambipolar term E = ambiCoef * JxBxB=ambiCoef * B^2(-J_perpB)
  !=> the source term J.E = ambiCoef * B^2 * J_perpB^2 = ambiCoef * JxBxB^2/B^2
  !> ambiCoef is calculated as mhd_ambi_coef/rho^2,  see also the subroutine mhd_get_Jambi
  subroutine add_source_ambipolar_internal_energy(qdt,ixI^L,ixO^L,wCT,w,x,ie)
    use mod_global_parameters
    integer, intent(in)             :: ixI^L, ixO^L,ie
    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)
    double precision :: jxbxb(ixI^S,1:3)
 
    call mhd_get_jxbxb(wct,x,ixi^l,ixo^l,jxbxb)
    tmp(ixo^s) = sum(jxbxb(ixo^s,1:3)**2,dim=ndim+1) / mhd_mag_en_all(wct, ixi^l, ixo^l)
    call multiplyambicoef(ixi^l,ixo^l,tmp,wct,x)
    w(ixo^s,ie)=w(ixo^s,ie)+qdt * tmp
 
  end subroutine add_source_ambipolar_internal_energy
 
  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(:^D&,:)
 
    double precision  :: btot(ixI^S,1:3)
    integer          :: idir, idirmin
    double precision :: current(ixI^S,7-2*ndir:3)
    double precision :: tmp(ixI^S),b2(ixI^S)
 
    res=0.d0
    ! Calculate current density and idirmin
    call get_current(w,ixi^l,ixo^l,idirmin,current)
    !!!here we know that current has nonzero values only for components in the range idirmin, 3
 
    if(b0field) then
      do idir=1,3
        btot(ixo^s, idir) = w(ixo^s,mag(idir)) + block%B0(ixo^s,idir,b0i)
      enddo
    else
      btot(ixo^s,1:3) = w(ixo^s,mag(1:3))
    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
  end subroutine mhd_get_jxbxb
 
  !> Sets the sources for the ambipolar
  !> this is used 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,7-2*ndim:3)
    double precision  :: btot(ixI^S,1:3),tmp2(ixI^S)
    integer :: i, ixA^L, ie_
 
    ixa^l=ixo^l^ladd1;
 
    fluxall=zero
 
    call mhd_get_jxbxb(w,x,ixi^l,ixa^l,tmp)
 
    !set electric field in tmp: E=nuA * jxbxb, where nuA=-etaA/rho^2
    do i=1,3
      !tmp(ixA^S,i) = -(mhd_eta_ambi/w(ixA^S, rho_)**2) * tmp(ixA^S,i)
      call multiplyambicoef(ixi^l,ixa^l,tmp(ixi^s,i),w,x)
    enddo
 
    if(mhd_energy .and. .not.mhd_internal_e) then
      !btot should be only mag. pert.
      btot(ixa^s,1:3)=0.d0
      !if(B0field) then
      !  do i=1,ndir
      !    btot(ixA^S, i) = w(ixA^S,mag(i)) + block%B0(ixA^S,i,0)
      !  enddo
      !else
        btot(ixa^s,1:ndir) = w(ixa^s,mag(1:ndir))
      !endif
      call cross_product(ixi^l,ixa^l,tmp,btot,ff)
      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 comes from the fact that the flux divergence is a source now
      wres(ixo^s,e_)=-tmp2(ixo^s)
    endif
 
    if(stagger_grid) then
      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}
 
      !!!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,7-2*ndim: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
    ! calcuate ambipolar electric field on cell edges from cell centers
    do idir=7-2*ndim,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=7-2*ndim,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 to get cell-face flux
  !> and get the source term as the divergence of the 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(:^D&,:), 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
    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)
    ! flux at cell face
    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 ambipokar 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)
    coef = maxval(abs(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 implemneting 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,ixo^l,rho)
    tmp=0.d0
    tmp(ixo^s)=-mhd_eta_ambi/rho(ixo^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,ixI^L,ixO^L,wCT,w,x,qsourcesplit,active,wCTprim)
    use mod_global_parameters
    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
    double precision, intent(in)    :: wCT(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
    double precision, intent(in), optional :: wCTprim(ixI^S,1:nw)
 
    if (.not. qsourcesplit) then
      if(mhd_internal_e) then
        ! Source for solving internal energy
        active = .true.
        call internal_energy_add_source(qdt,ixi^l,ixo^l,wct,w,x,e_)
      else
        if(mhd_solve_eaux) then
          ! Source for auxiliary internal energy equation
          active = .true.
          call internal_energy_add_source(qdt,ixi^l,ixo^l,wct,w,x,eaux_)
        endif
        if(has_equi_pe0) then
          active = .true.
          call add_pe0_divv(qdt,ixi^l,ixo^l,wct,w,x)
        endif
      endif
 
      ! Source for B0 splitting
      if (b0field.or.b0field) then
        active = .true.
        call add_source_b0split(qdt,ixi^l,ixo^l,wct,w,x)
      end if
 
      ! Sources for resistivity in eqs. for e, B1, B2 and B3
      if (abs(mhd_eta)>smalldouble)then
        active = .true.
        call add_source_res2(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
      ! add sources for semirelativistic MHD
      if (unsplit_semirelativistic) then
        active = .true.
        call add_source_semirelativistic(qdt,ixi^l,ixo^l,wct,w,x,wctprim)
      end if
      ! add sources for hydrodynamic energy version of MHD
      if (mhd_hydrodynamic_e) then
        active = .true.
        call add_source_hydrodynamic_e(qdt,ixi^l,ixo^l,wct,w,x,wctprim)
      end if
    end if
 
      {^nooned
    if(.not.source_split_divb .and. .not.qsourcesplit .and. istep==nstep) then
      ! Sources related to div B
      select case (type_divb)
      case (divb_none)
        ! Do nothing
      case (divb_glm)
        active = .true.
        call add_source_glm(dt,ixi^l,ixo^l,pso(block%igrid)%w,w,x)
      case (divb_powel)
        active = .true.
        call add_source_powel(dt,ixi^l,ixo^l,pso(block%igrid)%w,w,x)
      case (divb_janhunen)
        active = .true.
        call add_source_janhunen(dt,ixi^l,ixo^l,pso(block%igrid)%w,w,x)
      case (divb_linde)
        active = .true.
        call add_source_linde(dt,ixi^l,ixo^l,pso(block%igrid)%w,w,x)
      case (divb_lindejanhunen)
        active = .true.
        call add_source_linde(dt,ixi^l,ixo^l,pso(block%igrid)%w,w,x)
        call add_source_janhunen(dt,ixi^l,ixo^l,pso(block%igrid)%w,w,x)
      case (divb_lindepowel)
        active = .true.
        call add_source_linde(dt,ixi^l,ixo^l,pso(block%igrid)%w,w,x)
        call add_source_powel(dt,ixi^l,ixo^l,pso(block%igrid)%w,w,x)
      case (divb_lindeglm)
        active = .true.
        call add_source_linde(dt,ixi^l,ixo^l,pso(block%igrid)%w,w,x)
        call add_source_glm(dt,ixi^l,ixo^l,pso(block%igrid)%w,w,x)
      case (divb_ct)
        continue ! Do nothing
      case (divb_multigrid)
        continue ! Do nothing
      case default
        call mpistop('Unknown divB fix')
      end select
    else if(source_split_divb .and. qsourcesplit) then
      ! Sources related to div B
      select case (type_divb)
      case (divb_none)
        ! Do nothing
      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,wct,w,x)
      case (divb_janhunen)
        active = .true.
        call add_source_janhunen(qdt,ixi^l,ixo^l,wct,w,x)
      case (divb_linde)
        active = .true.
        call add_source_linde(qdt,ixi^l,ixo^l,wct,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,wct,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,wct,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_ct)
        continue ! Do nothing
      case (divb_multigrid)
        continue ! 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,&
           w,x,qsourcesplit,active, rc_fl)
    end if
 
    if(mhd_viscosity) then
      call viscosity_add_source(qdt,ixi^l,ixo^l,wct,&
           w,x,mhd_energy,qsourcesplit,active)
    end if
 
    if(mhd_gravity) then
      call gravity_add_source(qdt,ixi^l,ixo^l,wct,&
           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
 
  end subroutine mhd_add_source
 
  subroutine add_pe0_divv(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)
    double precision                :: v(ixI^S,1:ndir)
    double precision                :: divv(ixI^S)
 
    call mhd_get_v(wct,x,ixi^l,ixi^l,v)
 
    if(slab_uniform) then
      if(nghostcells .gt. 2) then
        call divvector(v,ixi^l,ixo^l,divv,sixthorder=.true.)
      else
        call divvector(v,ixi^l,ixo^l,divv,fourthorder=.true.)
      end if
    else
     call divvector(v,ixi^l,ixo^l,divv)
    end if
    w(ixo^s,e_)=w(ixo^s,e_)-qdt*block%equi_vars(ixo^s,equi_pe0_,0)*divv(ixo^s)
 
  end subroutine add_pe0_divv
 
  !> Compute the Lorentz force (JxB)
  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)
    integer                         :: idir, 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)
 
    b=0.0d0
    do idir = 1, ndir
      b(ixo^s, idir) = mhd_mag_i_all(w, ixi^l, ixo^l,idir)
    end do
 
    ! 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
 
  !> Compute 1/(1+v_A^2/c^2) for semirelativistic MHD, where v_A is the Alfven
  !> velocity
  subroutine mhd_gamma2_alfven(ixI^L, ixO^L, w, gamma_A2)
    use mod_global_parameters
    integer, intent(in)           :: ixI^L, ixO^L
    double precision, intent(in)  :: w(ixI^S, nw)
    double precision, intent(out) :: gamma_A2(ixO^S)
    double precision              :: rho(ixI^S)
 
    ! mhd_get_rho cannot be used as x is not a param
    if(has_equi_rho0) 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
    ! Compute the inverse of 1 + B^2/(rho * c^2)
    gamma_a2(ixo^s) = 1.0d0/(1.0d0+mhd_mag_en_all(w, ixi^l, ixo^l)/rho(ixo^s)*inv_squared_c)
  end subroutine mhd_gamma2_alfven
 
  !> Compute 1/sqrt(1+v_A^2/c^2) for semirelativisitic MHD, where v_A is the
  !> Alfven velocity
  function mhd_gamma_alfven(w, ixI^L, ixO^L) result(gamma_A)
    use mod_global_parameters
    integer, intent(in)           :: ixi^l, ixo^l
    double precision, intent(in)  :: w(ixi^s, nw)
    double precision              :: gamma_a(ixo^s)
 
    call mhd_gamma2_alfven(ixi^l, ixo^l, w, gamma_a)
    gamma_a = sqrt(gamma_a)
  end function mhd_gamma_alfven
 
  subroutine internal_energy_add_source(qdt,ixI^L,ixO^L,wCT,w,x,ie)
    use mod_global_parameters
    use mod_geometry
 
    integer, intent(in)             :: ixI^L, ixO^L,ie
    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                :: v(ixI^S,1:ndir),divv(ixI^S)
 
    call mhd_get_v(wct,x,ixi^l,ixi^l,v)
    if(slab_uniform) then
      if(nghostcells .gt. 2) then
        call divvector(v,ixi^l,ixo^l,divv,sixthorder=.true.)
      else
        call divvector(v,ixi^l,ixo^l,divv,fourthorder=.true.)
      end if
    else
     call divvector(v,ixi^l,ixo^l,divv)
    end if
    w(ixo^s,ie)=w(ixo^s,ie)-qdt*wct(ixo^s,ie)*gamma_1*divv(ixo^s)
    if(mhd_ambipolar)then
       call add_source_ambipolar_internal_energy(qdt,ixi^l,ixo^l,wct,w,x,ie)
    end if
    if(fix_small_values) then
      call mhd_handle_small_ei(w,x,ixi^l,ixo^l,ie,'internal_energy_add_source')
    end if
  end subroutine internal_energy_add_source
 
  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_rho0) 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
 
    integer :: idir
    logical :: flag(ixI^S,1:nw)
    double precision              :: rho(ixI^S)
 
    flag=.false.
    if(has_equi_pe0) then
      where(w(ixo^s,ie)+block%equi_vars(ixo^s,equi_pe0_,0)*inv_gamma_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_pe0) then
          where(flag(ixo^s,ie)) w(ixo^s,ie)=small_e - &
                  block%equi_vars(ixo^s,equi_pe0_,0)*inv_gamma_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_)*gamma_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,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 :: 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) 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)
      axb(ixo^s,:)=axb(ixo^s,:)*qdt
      ! 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,:)=wct(ixo^s,mag(:))
      ! store full magnetic field B0+B1 in b
      if(.not.b0field_forcefree) b(ixo^s,:)=b(ixo^s,:)+block%B0(ixo^s,:,0)
      ! store velocity in a
      call mhd_get_v(wct,x,ixi^l,ixo^l,a(ixi^s,1:ndir))
      call cross_product(ixi^l,ixo^l,a,b,axb)
      axb(ixo^s,:)=axb(ixo^s,:)*qdt
      ! 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
      if(mhd_ambipolar) then
        !reuse axb
        call mhd_get_jxbxb(wct,x,ixi^l,ixo^l,axb)
        ! source J0 * E
        do idir=7-2*ndim,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_)+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
  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 :: B(ixI^S,3), v(ixI^S,3), E(ixI^S,3), divE(ixI^S)
    integer :: idir
 
    ! store B0 magnetic field in b
    if(b0field) then
      b(ixi^s,1:ndir)=wct(ixi^s,mag(1:ndir))+block%B0(ixi^s,1:ndir,0)
    else
      b(ixi^s,1:ndir)=wct(ixi^s,mag(1:ndir))
    end if
    v(ixi^s,1:ndir)=wctprim(ixi^s,mom(1:ndir))
 
    call cross_product(ixi^l,ixi^l,b,v,e)
    ! add source term in momentum equations (1/c0^2-1/c^2)E divE
    call divvector(e,ixi^l,ixo^l,dive)
    dive(ixo^s)=qdt*(inv_squared_c0-inv_squared_c)*dive(ixo^s)
    do idir=1,ndir
      w(ixo^s,mom(idir))=w(ixo^s,mom(idir))+e(ixo^s,idir)*dive(ixo^s)
    end do
 
  end subroutine add_source_semirelativistic
 
  !> 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)
    integer :: idir, idirmin, idims, ix^D
    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
 
    b=0.0d0
    do idir = 1, ndir
      b(ixo^s, idir) = wct(ixo^s,mag(idir))
    end do
 
    call get_current(wct,ixi^l,ixo^l,idirmin,current)
 
    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)
 
    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
        if (.not. associated(usr_gravity)) then
          write(*,*) "mod_usr.t: please point usr_gravity to a subroutine"
          write(*,*) "like the phys_gravity in mod_usr_methods.t"
          call mpistop("add_source_hydrodynamic_e: usr_gravity not defined")
        else
          gravity_field=0.d0
          call usr_gravity(ixi^l,ixo^l,wct,x,gravity_field(ixi^s,1:ndim))
        end if
        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
 
  end subroutine add_source_hydrodynamic_e
 
  !> Add resistive source to w within ixO Uses 3 point stencil (1 neighbour) in
  !> each direction, non-conservative. If the fourthorder precompiler flag is
  !> set, uses fourth order central difference for the laplacian. Then the
  !> stencil is 5 (2 neighbours).
  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,jxO^L,hxO^L,ix
    integer :: lxO^L, kxO^L
 
    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)
 
    ! Calculating resistive sources involve one extra layer
    if (mhd_4th_order) then
      ixa^l=ixo^l^ladd2;
    else
      ixa^l=ixo^l^ladd1;
    end if
 
    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)
       ! assumes that eta is not function of current?
       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
 
    do idir=1,ndir
       ! Put B_idir into tmp2 and eta*Laplace B_idir into tmp
       if (mhd_4th_order) then
         tmp(ixo^s)=zero
         tmp2(ixi^s)=bf(ixi^s,idir)
         do idim=1,ndim
            lxo^l=ixo^l+2*kr(idim,^d);
            jxo^l=ixo^l+kr(idim,^d);
            hxo^l=ixo^l-kr(idim,^d);
            kxo^l=ixo^l-2*kr(idim,^d);
            tmp(ixo^s)=tmp(ixo^s)+&
                 (-tmp2(lxo^s)+16.0d0*tmp2(jxo^s)-30.0d0*tmp2(ixo^s)+16.0d0*tmp2(hxo^s)-tmp2(kxo^s)) &
                 /(12.0d0 * dxlevel(idim)**2)
         end do
       else
         tmp(ixo^s)=zero
         tmp2(ixi^s)=bf(ixi^s,idir)
         do idim=1,ndim
            jxo^l=ixo^l+kr(idim,^d);
            hxo^l=ixo^l-kr(idim,^d);
            tmp(ixo^s)=tmp(ixo^s)+&
                 (tmp2(jxo^s)-2.0d0*tmp2(ixo^s)+tmp2(hxo^s))/dxlevel(idim)**2
         end do
       end if
 
       ! Multiply by eta
       tmp(ixo^s)=tmp(ixo^s)*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
      tmp(ixo^s)=qdt*eta(ixo^s)*sum(current(ixo^s,:)**2,dim=ndim+1)
      w(ixo^s,e_)=w(ixo^s,e_)+tmp(ixo^s)
      if(mhd_solve_eaux) then
        ! add eta*J**2 source term in the internal energy equation
        w(ixo^s,eaux_)=w(ixo^s,eaux_)+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_res1')
 
  end subroutine add_source_res1
 
  !> Add resistive source to w within ixO
  !> Uses 5 point stencil (2 neighbours) in each direction, conservative
  subroutine add_source_res2(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_res2: 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
      if(mhd_solve_eaux) then
        ! add eta*J**2 source term in the internal energy equation
        w(ixo^s,eaux_)=w(ixo^s,eaux_)+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_res2')
  end subroutine add_source_res2
 
  !> 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)
    integer          :: idim,idir
    double precision :: gradPsi(ixI^S)
 
 
    ! 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
      ! gradient of Psi
      if(total_energy) then
        do idim=1,ndim
          select case(typegrad)
          case("central")
            call gradient(wct(ixi^s,psi_),ixi^l,ixo^l,idim,gradpsi)
          case("limited")
            call gradients(wct(ixi^s,psi_),ixi^l,ixo^l,idim,gradpsi)
          end select
          ! e  = e  -qdt (b . grad(Psi))
          w(ixo^s,e_) = w(ixo^s,e_)-qdt*wct(ixo^s,mag(idim))*gradpsi(ixo^s)
        end do
      end if
 
      ! We calculate now div B
      call get_divb(wct,ixi^l,ixo^l,divb, mhd_divb_4thorder)
 
      ! m = m - qdt b div b
      do idir=1,ndir
        w(ixo^s,mom(idir))=w(ixo^s,mom(idir))-qdt*mhd_mag_i_all(w,ixi^l,ixo^l,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),v(ixI^S,1:ndir)
    integer                         :: idir
 
    ! We calculate now div B
    call get_divb(wct,ixi^l,ixo^l,divb, mhd_divb_4thorder)
 
    ! calculate velocity
    call mhd_get_v(wct,x,ixi^l,ixo^l,v)
 
    if (total_energy) then
      ! e = e - qdt (v . b) * div b
      w(ixo^s,e_)=w(ixo^s,e_)-&
           qdt*sum(v(ixo^s,:)*wct(ixo^s,mag(:)),dim=ndim+1)*divb(ixo^s)
    end if
 
    ! b = b - qdt v * div b
    do idir=1,ndir
      w(ixo^s,mag(idir))=w(ixo^s,mag(idir))-qdt*v(ixo^s,idir)*divb(ixo^s)
    end do
 
    ! m = m - qdt b div b
    do idir=1,ndir
      w(ixo^s,mom(idir))=w(ixo^s,mom(idir))-qdt*mhd_mag_i_all(w,ixi^l,ixo^l,idir)*divb(ixo^s)
    end do
 
    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),vel(ixI^S,1:ndir)
    integer                         :: idir
 
    ! We calculate now div B
    call get_divb(wct,ixi^l,ixo^l,divb, mhd_divb_4thorder)
 
    call mhd_get_v(wct,x,ixi^l,ixo^l,vel)
    ! b = b - qdt v * div b
    do idir=1,ndir
      w(ixo^s,mag(idir))=w(ixo^s,mag(idir))-qdt*vel(ixo^s,idir)*divb(ixo^s)
    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)
    integer :: idim, idir, ixp^L, i^D, iside
    double precision :: divb(ixI^S),graddivb(ixI^S)
    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_4thorder)
 
    ! 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)
       select case(typegrad)
       case("central")
         call gradient(divb,ixi^l,ixp^l,idim,graddivb)
       case("limited")
         call gradients(divb,ixi^l,ixp^l,idim,graddivb)
       end select
 
       ! Multiply by Linde's eta*dt = divbdiff*(c_max*dx)*dt = divbdiff*dx**2
       if (slab_uniform) then
          graddivb(ixp^s)=graddivb(ixp^s)*divbdiff/(^d&1.0d0/dxlevel(^d)**2+)
       else
          graddivb(ixp^s)=graddivb(ixp^s)*divbdiff &
                          /(^d&1.0d0/block%ds(ixp^s,^d)**2+)
       end if
 
       w(ixp^s,mag(idim))=w(ixp^s,mag(idim))+graddivb(ixp^s)
 
       if (typedivbdiff=='all' .and. total_energy) then
         ! e += B_idim*eta*grad_idim(divb)
         w(ixp^s,e_)=w(ixp^s,e_)+wct(ixp^s,mag(idim))*graddivb(ixp^s)
       end if
    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
 
  !> Calculate div B within ixO
  subroutine get_divb(w,ixI^L,ixO^L,divb, fourthorder)
    use mod_global_parameters
    use mod_geometry
 
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(in)    :: w(ixi^s,1:nw)
    double precision, intent(inout) :: divb(ixi^s)
    logical, intent(in), optional   :: fourthorder
 
    integer                            :: ixc^l, idir
 
    if(stagger_grid) then
      divb(ixo^s)=0.d0
      do idir=1,ndim
        ixc^l=ixo^l-kr(idir,^d);
        divb(ixo^s)=divb(ixo^s)+block%ws(ixo^s,idir)*block%surfaceC(ixo^s,idir)-&
                                block%ws(ixc^s,idir)*block%surfaceC(ixc^s,idir)
      end do
      divb(ixo^s)=divb(ixo^s)/block%dvolume(ixo^s)
    else
      select case(typediv)
      case("central")
        call divvector(w(ixi^s,mag(1:ndir)),ixi^l,ixo^l,divb,fourthorder)
      case("limited")
        call divvectors(w(ixi^s,mag(1:ndir)),ixi^l,ixo^l,divb)
      end select
    end if
 
  end subroutine get_divb
 
  !> 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
    integer :: idir, idirmin0
 
    ! 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)
 
    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
  subroutine mhd_get_dt(w,ixI^L,ixO^L,dtnew,dx^D,x)
    use mod_global_parameters
    use mod_usr_methods
    use mod_radiative_cooling, only: cooling_get_dt
    use mod_viscosity, only: viscosity_get_dt
    use mod_gravity, only: gravity_get_dt
    use mod_cak_force, only: cak_get_dt
 
    integer, intent(in)             :: ixI^L, ixO^L
    double precision, intent(inout) :: dtnew
    double precision, intent(in)    :: dx^D
    double precision, intent(in)    :: w(ixI^S,1:nw)
    double precision, intent(in)    :: x(ixI^S,1:ndim)
 
    integer                       :: idirmin,idim
    double precision              :: dxarr(ndim)
    double precision              :: current(ixI^S,7-2*ndir:3),eta(ixI^S)
 
    dtnew = bigdouble
 
    ^d&dxarr(^d)=dx^d;
    if (mhd_eta>zero)then
       dtnew=dtdiffpar*minval(dxarr(1:ndim))**2/mhd_eta
    else if (mhd_eta<zero)then
       call get_current(w,ixi^l,ixo^l,idirmin,current)
       call usr_special_resistivity(w,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_radiative_cooling) then
      call cooling_get_dt(w,ixi^l,ixo^l,dtnew,dx^d,x,rc_fl)
    end if
 
    if(mhd_viscosity) then
      call viscosity_get_dt(w,ixi^l,ixo^l,dtnew,dx^d,x)
    end if
 
    if(mhd_gravity) then
      call gravity_get_dt(w,ixi^l,ixo^l,dtnew,dx^d,x)
    end if
 
    if(mhd_ambipolar_exp) then
      dtnew=min(dtdiffpar*get_ambipolar_dt(w,ixi^l,ixo^l,dx^d,x),dtnew)
    endif
 
    if (mhd_cak_force) then
      call cak_get_dt(w,ixi^l,ixo^l,dtnew,dx^d,x)
    end if
 
  end subroutine mhd_get_dt
 
  ! Add geometrical source terms to w
  subroutine mhd_add_source_geom(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, x(ixI^S,1:ndim)
    double precision, intent(inout) :: wCT(ixI^S,1:nw), w(ixI^S,1:nw)
 
    integer          :: iw,idir, h1x^L{^NOONED, h2x^L}
    double precision :: tmp(ixI^S),tmp1(ixI^S),tmp2(ixI^S),invrho(ixO^S),invr(ixO^S)
 
    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_
 
    ! 1/rho
    invrho(ixo^s)=1.d0/wct(ixo^s,rho_)
    invr(ixo^s)=1.d0/x(ixo^s,1)
    select case (coordinate)
    case (cylindrical)
      if (angmomfix) then
        call mpistop("angmomfix not implemented yet in MHD")
      endif
      call mhd_get_p_total(wct,x,ixi^l,ixo^l,tmp)
      if(phi_>0) then
        w(ixo^s,mr_)=w(ixo^s,mr_)+qdt*invr(ixo^s)*(tmp(ixo^s)-&
                  wct(ixo^s,bphi_)**2+wct(ixo^s,mphi_)**2*invrho(ixo^s))
        w(ixo^s,mphi_)=w(ixo^s,mphi_)+qdt*invr(ixo^s)*(&
                 -wct(ixo^s,mphi_)*wct(ixo^s,mr_)*invrho(ixo^s) &
                 +wct(ixo^s,bphi_)*wct(ixo^s,br_))
        if(.not.stagger_grid) then
          w(ixo^s,bphi_)=w(ixo^s,bphi_)+qdt*invr(ixo^s)*&
                   (wct(ixo^s,bphi_)*wct(ixo^s,mr_) &
                   -wct(ixo^s,br_)*wct(ixo^s,mphi_)) &
                   *invrho(ixo^s)
        end if
      else
        w(ixo^s,mr_)=w(ixo^s,mr_)+qdt*invr(ixo^s)*tmp(ixo^s)
      end if
      if(mhd_glm) w(ixo^s,br_)=w(ixo^s,br_)+qdt*wct(ixo^s,psi_)*invr(ixo^s)
    case (spherical)
       h1x^l=ixo^l-kr(1,^d); {^nooned h2x^l=ixo^l-kr(2,^d);}
       call mhd_get_p_total(wct,x,ixi^l,ixo^l,tmp1)
       ! m1
       tmp(ixo^s)=tmp1(ixo^s)*x(ixo^s,1) &
                  *(block%surfaceC(ixo^s,1)-block%surfaceC(h1x^s,1))/block%dvolume(ixo^s)
       do idir=2,ndir
         tmp(ixo^s)=tmp(ixo^s)+wct(ixo^s,mom(idir))**2*invrho(ixo^s)-wct(ixo^s,mag(idir))**2
       end do
       w(ixo^s,mom(1))=w(ixo^s,mom(1))+qdt*tmp(ixo^s)*invr(ixo^s)
       ! b1
       if(mhd_glm) then
         w(ixo^s,mag(1))=w(ixo^s,mag(1))+qdt*invr(ixo^s)*2.0d0*wct(ixo^s,psi_)
       end if
 
       {^nooned
       ! m2
       ! This will make hydrostatic p=const an exact solution
       w(ixo^s,mom(2))=w(ixo^s,mom(2))+qdt*tmp1(ixo^s) &
            *(block%surfaceC(ixo^s,2)-block%surfaceC(h2x^s,2)) &
            /block%dvolume(ixo^s)
       tmp(ixo^s)=-(wct(ixo^s,mom(1))*wct(ixo^s,mom(2))*invrho(ixo^s) &
            -wct(ixo^s,mag(1))*wct(ixo^s,mag(2)))
       if(ndir==3) then
         tmp(ixo^s)=tmp(ixo^s)+(wct(ixo^s,mom(3))**2*invrho(ixo^s) &
              -wct(ixo^s,mag(3))**2)*dcos(x(ixo^s,2))/dsin(x(ixo^s,2))
       end if
       w(ixo^s,mom(2))=w(ixo^s,mom(2))+qdt*tmp(ixo^s)*invr(ixo^s)
       ! b2
       if(.not.stagger_grid) then
         tmp(ixo^s)=(wct(ixo^s,mom(1))*wct(ixo^s,mag(2)) &
              -wct(ixo^s,mom(2))*wct(ixo^s,mag(1)))*invrho(ixo^s)
         if(mhd_glm) then
           tmp(ixo^s)=tmp(ixo^s) &
                + dcos(x(ixo^s,2))/dsin(x(ixo^s,2))*wct(ixo^s,psi_)
         end if
         w(ixo^s,mag(2))=w(ixo^s,mag(2))+qdt*tmp(ixo^s)*invr(ixo^s)
       end if
       }
 
       if(ndir==3) then
         ! m3
         if(.not.angmomfix) then
           tmp(ixo^s)=-(wct(ixo^s,mom(3))*wct(ixo^s,mom(1))*invrho(ixo^s) &
                -wct(ixo^s,mag(3))*wct(ixo^s,mag(1))) {^nooned &
                -(wct(ixo^s,mom(2))*wct(ixo^s,mom(3))*invrho(ixo^s) &
                -wct(ixo^s,mag(2))*wct(ixo^s,mag(3))) &
                *dcos(x(ixo^s,2))/dsin(x(ixo^s,2)) }
           w(ixo^s,mom(3))=w(ixo^s,mom(3))+qdt*tmp(ixo^s)*invr(ixo^s)
         else
           call mpistop("angmomfix not implemented yet in MHD")
         end if
         ! b3
         if(.not.stagger_grid) then
           tmp(ixo^s)=(wct(ixo^s,mom(1))*wct(ixo^s,mag(3)) &
                -wct(ixo^s,mom(3))*wct(ixo^s,mag(1)))*invrho(ixo^s) {^nooned &
                -(wct(ixo^s,mom(3))*wct(ixo^s,mag(2)) &
                -wct(ixo^s,mom(2))*wct(ixo^s,mag(3)))*dcos(x(ixo^s,2)) &
                /(wct(ixo^s,rho_)*dsin(x(ixo^s,2))) }
           w(ixo^s,mag(3))=w(ixo^s,mag(3))+qdt*tmp(ixo^s)*invr(ixo^s)
         end if
       end if
    end select
  end subroutine mhd_add_source_geom
 
  ! Add geometrical source terms to w
  subroutine mhd_add_source_geom_split(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, x(ixI^S,1:ndim)
    double precision, intent(inout) :: wCT(ixI^S,1:nw), w(ixI^S,1:nw)
 
    integer          :: iw,idir, h1x^L{^NOONED, h2x^L}
    double precision :: tmp(ixI^S),tmp1(ixI^S),tmp2(ixI^S),invrho(ixO^S),invr(ixO^S)
 
    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(has_equi_rho0) then
      invrho(ixo^s) = 1d0/(wct(ixo^s,rho_) + block%equi_vars(ixo^s,equi_rho0_,b0i))
    else
      invrho(ixo^s) = 1d0/wct(ixo^s,rho_)
    end if
    invr(ixo^s)=1d0/x(ixo^s,1)
 
    select case (coordinate)
    case (cylindrical)
      if (angmomfix) then
        call mpistop("angmomfix not implemented yet in MHD")
      endif
      call mhd_get_p_total(wct,x,ixi^l,ixo^l,tmp)
      if(phi_>0) then
        w(ixo^s,mr_)=w(ixo^s,mr_)+qdt*invr(ixo^s)*(tmp(ixo^s)-&
                  wct(ixo^s,bphi_)**2+wct(ixo^s,mphi_)**2*invrho(ixo^s))
        w(ixo^s,mphi_)=w(ixo^s,mphi_)+qdt*invr(ixo^s)*(&
                 -wct(ixo^s,mphi_)*wct(ixo^s,mr_)*invrho(ixo^s) &
                 +wct(ixo^s,bphi_)*wct(ixo^s,br_))
        if(.not.stagger_grid) then
          w(ixo^s,bphi_)=w(ixo^s,bphi_)+qdt*invr(ixo^s)*&
                   (wct(ixo^s,bphi_)*wct(ixo^s,mr_) &
                   -wct(ixo^s,br_)*wct(ixo^s,mphi_)) &
                   *invrho(ixo^s)
        end if
      else
        w(ixo^s,mr_)=w(ixo^s,mr_)+qdt*invr(ixo^s)*tmp(ixo^s)
      end if
      if(mhd_glm) w(ixo^s,br_)=w(ixo^s,br_)+qdt*wct(ixo^s,psi_)*invr(ixo^s)
    case (spherical)
       h1x^l=ixo^l-kr(1,^d); {^nooned h2x^l=ixo^l-kr(2,^d);}
       call mhd_get_p_total(wct,x,ixi^l,ixo^l,tmp1)
       tmp(ixo^s)=tmp1(ixo^s)
       if(b0field) then
         tmp2(ixo^s)=sum(block%B0(ixo^s,:,0)*wct(ixo^s,mag(:)),dim=ndim+1)
         tmp(ixo^s)=tmp(ixo^s)+tmp2(ixo^s)
       end if
       ! m1
       tmp(ixo^s)=tmp(ixo^s)*x(ixo^s,1) &
                  *(block%surfaceC(ixo^s,1)-block%surfaceC(h1x^s,1))/block%dvolume(ixo^s)
       if(ndir>1) then
         do idir=2,ndir
           tmp(ixo^s)=tmp(ixo^s)+wct(ixo^s,mom(idir))**2*invrho(ixo^s)-wct(ixo^s,mag(idir))**2
           if(b0field) tmp(ixo^s)=tmp(ixo^s)-2.0d0*block%B0(ixo^s,idir,0)*wct(ixo^s,mag(idir))
         end do
       end if
       w(ixo^s,mom(1))=w(ixo^s,mom(1))+qdt*tmp(ixo^s)*invr(ixo^s)
       ! b1
       if(mhd_glm) then
         w(ixo^s,mag(1))=w(ixo^s,mag(1))+qdt*invr(ixo^s)*2.0d0*wct(ixo^s,psi_)
       end if
 
       {^nooned
       ! m2
       tmp(ixo^s)=tmp1(ixo^s)
       if(b0field) then
         tmp(ixo^s)=tmp(ixo^s)+tmp2(ixo^s)
       end if
       ! This will make hydrostatic p=const an exact solution
       w(ixo^s,mom(2))=w(ixo^s,mom(2))+qdt*tmp(ixo^s) &
            *(block%surfaceC(ixo^s,2)-block%surfaceC(h2x^s,2)) &
            /block%dvolume(ixo^s)
       tmp(ixo^s)=-(wct(ixo^s,mom(1))*wct(ixo^s,mom(2))*invrho(ixo^s) &
            -wct(ixo^s,mag(1))*wct(ixo^s,mag(2)))
       if (b0field) then
          tmp(ixo^s)=tmp(ixo^s)+block%B0(ixo^s,1,0)*wct(ixo^s,mag(2)) &
               +wct(ixo^s,mag(1))*block%B0(ixo^s,2,0)
       end if
       if(ndir==3) then
         tmp(ixo^s)=tmp(ixo^s)+(wct(ixo^s,mom(3))**2*invrho(ixo^s) &
              -wct(ixo^s,mag(3))**2)*dcos(x(ixo^s,2))/dsin(x(ixo^s,2))
         if (b0field) then
            tmp(ixo^s)=tmp(ixo^s)-2.0d0*block%B0(ixo^s,3,0)*wct(ixo^s,mag(3))&
                 *dcos(x(ixo^s,2))/dsin(x(ixo^s,2))
         end if
       end if
       w(ixo^s,mom(2))=w(ixo^s,mom(2))+qdt*tmp(ixo^s)*invr(ixo^s)
       ! b2
       if(.not.stagger_grid) then
         tmp(ixo^s)=(wct(ixo^s,mom(1))*wct(ixo^s,mag(2)) &
              -wct(ixo^s,mom(2))*wct(ixo^s,mag(1)))*invrho(ixo^s)
         if(b0field) then
           tmp(ixo^s)=tmp(ixo^s)+(wct(ixo^s,mom(1))*block%B0(ixo^s,2,0) &
                -wct(ixo^s,mom(2))*block%B0(ixo^s,1,0))*invrho(ixo^s)
         end if
         if(mhd_glm) then
           tmp(ixo^s)=tmp(ixo^s) &
                + dcos(x(ixo^s,2))/dsin(x(ixo^s,2))*wct(ixo^s,psi_)
         end if
         w(ixo^s,mag(2))=w(ixo^s,mag(2))+qdt*tmp(ixo^s)*invr(ixo^s)
       end if
       }
 
       if(ndir==3) then
         ! m3
         if(.not.angmomfix) then
           tmp(ixo^s)=-(wct(ixo^s,mom(3))*wct(ixo^s,mom(1))*invrho(ixo^s) &
                -wct(ixo^s,mag(3))*wct(ixo^s,mag(1))) {^nooned &
                -(wct(ixo^s,mom(2))*wct(ixo^s,mom(3))*invrho(ixo^s) &
                -wct(ixo^s,mag(2))*wct(ixo^s,mag(3))) &
                *dcos(x(ixo^s,2))/dsin(x(ixo^s,2)) }
           if (b0field) then
              tmp(ixo^s)=tmp(ixo^s)+block%B0(ixo^s,1,0)*wct(ixo^s,mag(3)) &
                   +wct(ixo^s,mag(1))*block%B0(ixo^s,3,0) {^nooned &
                   +(block%B0(ixo^s,2,0)*wct(ixo^s,mag(3)) &
                   +wct(ixo^s,mag(2))*block%B0(ixo^s,3,0)) &
                   *dcos(x(ixo^s,2))/dsin(x(ixo^s,2)) }
           end if
           w(ixo^s,mom(3))=w(ixo^s,mom(3))+qdt*tmp(ixo^s)*invr(ixo^s)
         else
           call mpistop("angmomfix not implemented yet in MHD")
         end if
         ! b3
         if(.not.stagger_grid) then
           tmp(ixo^s)=(wct(ixo^s,mom(1))*wct(ixo^s,mag(3)) &
                -wct(ixo^s,mom(3))*wct(ixo^s,mag(1)))*invrho(ixo^s) {^nooned &
                -(wct(ixo^s,mom(3))*wct(ixo^s,mag(2)) &
                -wct(ixo^s,mom(2))*wct(ixo^s,mag(3)))*dcos(x(ixo^s,2)) &
                *invrho(ixo^s)/dsin(x(ixo^s,2)) }
           if (b0field) then
              tmp(ixo^s)=tmp(ixo^s)+(wct(ixo^s,mom(1))*block%B0(ixo^s,3,0) &
                   -wct(ixo^s,mom(3))*block%B0(ixo^s,1,0))*invrho(ixo^s){^nooned &
                   -(wct(ixo^s,mom(3))*block%B0(ixo^s,2,0) &
                   -wct(ixo^s,mom(2))*block%B0(ixo^s,3,0))*dcos(x(ixo^s,2)) &
                   *invrho(ixo^s)/dsin(x(ixo^s,2)) }
           end if
           w(ixo^s,mag(3))=w(ixo^s,mag(3))+qdt*tmp(ixo^s)*invr(ixo^s)
         end if
       end if
    end select
  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
 
  !> Compute full magnetic field by direction
  function mhd_mag_i_all(w, ixI^L, ixO^L,idir) result(mgf)
    use mod_global_parameters
    integer, intent(in)           :: ixi^l, ixo^l, idir
    double precision, intent(in)  :: w(ixi^s, nw)
    double precision              :: mgf(ixo^s)
 
    if (b0field) then
      mgf = w(ixo^s, mag(idir))+block%B0(ixo^s,idir,b0i)
    else
      mgf = w(ixo^s, mag(idir))
    end if
  end function mhd_mag_i_all
 
  !> Compute evolving magnetic energy
  function mhd_mag_en(w, ixI^L, ixO^L) result(mge)
    use mod_global_parameters, only: nw, ndim
    integer, intent(in)           :: ixi^l, ixo^l
    double precision, intent(in)  :: w(ixi^s, nw)
    double precision              :: mge(ixo^s)
 
    mge = 0.5d0 * sum(w(ixo^s, mag(:))**2, dim=ndim+1)
  end function mhd_mag_en
 
  !> compute kinetic energy
  function mhd_kin_en_origin(w, ixI^L, ixO^L, inv_rho) result(ke)
    use mod_global_parameters, only: nw, ndim,block
    integer, intent(in)           :: ixi^l, ixo^l
    double precision, intent(in)  :: w(ixi^s, nw)
    double precision              :: ke(ixo^s)
    double precision, intent(in), optional :: inv_rho(ixo^s)
 
    if (present(inv_rho)) then
      ke = 0.5d0 * sum(w(ixo^s, mom(:))**2, dim=ndim+1) * inv_rho
    else
      if(has_equi_rho0) then
        ke(ixo^s) = 0.5d0 * sum(w(ixo^s, mom(:))**2, dim=ndim+1) / (w(ixo^s, rho_) + block%equi_vars(ixo^s,equi_rho0_,0))
      else
        ke(ixo^s) = 0.5d0 * sum(w(ixo^s, mom(:))**2, dim=ndim+1) / w(ixo^s, rho_)
      endif
    end if
  end function mhd_kin_en_origin
 
  !> compute kinetic energy
  function mhd_kin_en_boris(w, ixI^L, ixO^L, inv_rho) result(ke)
    use mod_global_parameters
    integer, intent(in)           :: ixi^l, ixo^l
    double precision, intent(in)  :: w(ixi^s, nw)
    double precision              :: ke(ixo^s)
    double precision, intent(in), optional :: inv_rho(ixo^s)
 
    if (present(inv_rho)) then
      ke=1.d0/(1.d0+sum(w(ixo^s,mag(:))**2,dim=ndim+1)*inv_rho*inv_squared_c)
      ke=0.5d0*sum((w(ixo^s, mom(:)))**2,dim=ndim+1)*ke**2*inv_rho
    else
      ke=1.d0/(1.d0+sum(w(ixo^s,mag(:))**2,dim=ndim+1)/w(ixo^s,rho_)*inv_squared_c)
      ke=0.5d0*sum(w(ixo^s, mom(:))**2,dim=ndim+1)*ke**2/w(ixo^s, rho_)
    end if
  end function mhd_kin_en_boris
 
  subroutine mhd_getv_hall(w,x,ixI^L,ixO^L,vHall)
    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(inout) :: vHall(ixI^S,1:3)
 
    integer          :: idir, idirmin
    double precision :: current(ixI^S,7-2*ndir:3)
    double precision :: rho(ixI^S)
 
    call mhd_get_rho(w,x,ixi^l,ixo^l,rho)
    ! Calculate current density and idirmin
    call get_current(w,ixi^l,ixo^l,idirmin,current)
    vhall(ixo^s,1:3) = zero
    vhall(ixo^s,idirmin:3) = - mhd_etah*current(ixo^s,idirmin:3)
    do idir = idirmin, 3
       vhall(ixo^s,idir) = vhall(ixo^s,idir)/rho(ixo^s)
    end do
 
  end subroutine mhd_getv_hall
 
  subroutine mhd_get_jambi(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, allocatable, intent(inout) :: res(:^D&,:)
 
 
    integer          :: idir, idirmin
    double precision :: current(ixI^S,7-2*ndir:3)
 
    res = 0d0
 
    ! Calculate current density and idirmin
    call get_current(w,ixi^l,ixo^l,idirmin,current)
 
    res(ixo^s,idirmin:3)=-current(ixo^s,idirmin:3)
    do idir = idirmin, 3
      call multiplyambicoef(ixi^l,ixo^l,res(ixi^s,idir),w,x)
    enddo
 
  end subroutine mhd_get_jambi
 
    ! COMMENTED  because we have that in cmax now:
!  subroutine mhd_getdt_Hall(w,x,ixI^L,ixO^L,dx^D,dthall)
!    use mod_global_parameters
!
!    integer, intent(in) :: ixI^L, ixO^L
!    double precision, intent(in)    :: dx^D
!    double precision, intent(in)    :: w(ixI^S,1:nw)
!    double precision, intent(in)    :: x(ixI^S,1:ndim)
!    double precision, intent(out)   :: dthall
!    !.. local ..
!    double precision :: dxarr(ndim)
!    double precision :: bmag(ixI^S)
!
!    dthall=bigdouble
!
!
!    ^D&dxarr(^D)=dx^D;
!
!    if (.not. B0field) then
!       bmag(ixO^S)=sqrt(sum(w(ixO^S,mag(:))**2, dim=ndim+1))
!    else
!       bmag(ixO^S)=sqrt(sum((w(ixO^S,mag(:)) + block%B0(ixO^S,1:ndir,b0i))**2))
!    end if
!
!    if(slab_uniform) then
!      dthall=dtdiffpar*minval(dxarr(1:ndim))**2.0d0/(mhd_etah*maxval(bmag(ixO^S)/w(ixO^S,rho_)))
!    else
!      dthall=dtdiffpar*minval(block%ds(ixO^S,1:ndim))**2.0d0/(mhd_etah*maxval(bmag(ixO^S)/w(ixO^S,rho_)))
!    end if
!
!  end subroutine mhd_getdt_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(ixI^S), dPsi(ixI^S)
 
    if(stagger_grid) then
      wlc(ixo^s,mag(idir))=s%ws(ixo^s,idir)
      wrc(ixo^s,mag(idir))=s%ws(ixo^s,idir)
      wlp(ixo^s,mag(idir))=s%ws(ixo^s,idir)
      wrp(ixo^s,mag(idir))=s%ws(ixo^s,idir)
    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
      db(ixo^s)   = wrp(ixo^s,mag(idir)) - wlp(ixo^s,mag(idir))
      dpsi(ixo^s) = wrp(ixo^s,psi_) - wlp(ixo^s,psi_)
 
      wlp(ixo^s,mag(idir))   = 0.5d0 * (wrp(ixo^s,mag(idir)) + wlp(ixo^s,mag(idir))) &
           - 0.5d0/cmax_global * dpsi(ixo^s)
      wlp(ixo^s,psi_)       = 0.5d0 * (wrp(ixo^s,psi_) + wlp(ixo^s,psi_)) &
           - 0.5d0*cmax_global * db(ixo^s)
 
      wrp(ixo^s,mag(idir)) = wlp(ixo^s,mag(idir))
      wrp(ixo^s,psi_) = wlp(ixo^s,psi_)
 
      if(total_energy) then
        wrc(ixo^s,e_)=wrc(ixo^s,e_)-half*wrc(ixo^s,mag(idir))**2
        wlc(ixo^s,e_)=wlc(ixo^s,e_)-half*wlc(ixo^s,mag(idir))**2
      end if
      wrc(ixo^s,mag(idir)) = wlp(ixo^s,mag(idir))
      wrc(ixo^s,psi_) = wlp(ixo^s,psi_)
      wlc(ixo^s,mag(idir)) = wlp(ixo^s,mag(idir))
      wlc(ixo^s,psi_) = wlp(ixo^s,psi_)
      ! modify total energy according to the change of magnetic field
      if(total_energy) then
        wrc(ixo^s,e_)=wrc(ixo^s,e_)+half*wrc(ixo^s,mag(idir))**2
        wlc(ixo^s,e_)=wlc(ixo^s,e_)+half*wlc(ixo^s,mag(idir))**2
      end if
    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 mhd_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 mhd_to_conserved(ixg^l,ixo^l,w,x)
     case(2)
       if(total_energy) call mhd_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 mhd_to_conserved(ixg^l,ixo^l,w,x)
     case(3)
       if(total_energy) call mhd_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 mhd_to_conserved(ixg^l,ixo^l,w,x)
     case(4)
       if(total_energy) call mhd_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 mhd_to_conserved(ixg^l,ixo^l,w,x)
     {^ifthreed
     case(5)
       if(total_energy) call mhd_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 mhd_to_conserved(ixg^l,ixo^l,w,x)
     case(6)
       if(total_energy) call mhd_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 mhd_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                      :: iigrid, igrid, id
    integer                      :: n, nc, lvl, ix^l, ixc^l, idim
    type(tree_node), pointer     :: pnode
    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, parameter           :: max_its      = 50
    double precision             :: residual_it(max_its), max_divb
 
    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_4thorder)
       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 gradientx(tmp,ps(igrid)%x,ixg^ll,ixc^l,idim,grad(ixg^t,idim),.false.)
           ! 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
  }
 
  subroutine mhd_update_faces(ixI^L,ixO^L,qt,qdt,wprim,fC,fE,sCT,s,vcts)
    use mod_global_parameters
 
    integer, intent(in)                :: ixI^L, ixO^L
    double precision, intent(in)       :: qt,qdt
    ! cell-center primitive variables
    double precision, intent(in)       :: wprim(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,7-2*ndim:3)
 
    select case(type_ct)
    case('average')
      call update_faces_average(ixi^l,ixo^l,qt,qdt,fc,fe,sct,s)
    case('uct_contact')
      call update_faces_contact(ixi^l,ixo^l,qt,qdt,wprim,fc,fe,sct,s,vcts)
    case('uct_hll')
      call update_faces_hll(ixi^l,ixo^l,qt,qdt,fe,sct,s,vcts)
    case default
      call mpistop('choose average, uct_contact,or uct_hll for type_ct!')
    end select
 
  end subroutine mhd_update_faces
 
  !> get electric field though averaging neighors to update faces in CT
  subroutine update_faces_average(ixI^L,ixO^L,qt,qdt,fC,fE,sCT,s)
    use mod_global_parameters
    use mod_usr_methods
 
    integer, intent(in)                :: ixI^L, ixO^L
    double precision, intent(in)       :: qt, qdt
    type(state)                        :: sCT, s
    double precision, intent(in)       :: fC(ixI^S,1:nwflux,1:ndim)
    double precision, intent(inout)    :: fE(ixI^S,7-2*ndim:3)
 
    integer                            :: hxC^L,ixC^L,jxC^L,ixCm^L
    integer                            :: idim1,idim2,idir,iwdim1,iwdim2
    double precision                   :: circ(ixI^S,1:ndim)
    ! non-ideal electric field on cell edges
    double precision, dimension(ixI^S,7-2*ndim:3) :: E_resi, E_ambi
 
    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,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)
      do idim2=1,ndim
        iwdim2 = mag(idim2)
        do idir=7-2*ndim,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
            jxc^l=ixc^l+kr(idim1,^d);
            hxc^l=ixc^l+kr(idim2,^d);
            ! Interpolate to edges
            fe(ixc^s,idir)=quarter*(fc(ixc^s,iwdim1,idim2)+fc(jxc^s,iwdim1,idim2)&
                                   -fc(ixc^s,iwdim2,idim1)-fc(hxc^s,iwdim2,idim1))
 
            ! 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_))<1.0d-9)
                fe(ixc^s,idir)=zero
              end where
            end if
          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
        do idir=7-2*ndim,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
      ! Divide by the area of the face to get dB/dt
      where(s%surfaceC(ixc^s,idim1) > 1.0d-9*s%dvolume(ixc^s))
        circ(ixc^s,idim1)=circ(ixc^s,idim1)/s%surfaceC(ixc^s,idim1)
      elsewhere
        circ(ixc^s,idim1)=zero
      end where
      ! Time update cell-face magnetic field component
      bfaces(ixc^s,idim1)=bfaces(ixc^s,idim1)-circ(ixc^s,idim1)
    end do
 
    end associate
 
  end subroutine update_faces_average
 
  !> update faces using UCT contact mode by Gardiner and Stone 2005 JCP 205, 509
  subroutine update_faces_contact(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,7-2*ndim:3)
 
    double precision                   :: circ(ixI^S,1:ndim)
    ! electric field at cell centers
    double precision                   :: ECC(ixI^S,7-2*ndim: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(ixI^S),ERC(ixI^S)
    ! non-ideal electric field on cell edges
    double precision, dimension(ixI^S,7-2*ndim:3) :: E_resi, E_ambi
    ! total magnetic field at cell centers
    double precision                   :: Btot(ixI^S,1:ndim)
    integer                            :: hxC^L,ixC^L,jxC^L,ixA^L,ixB^L
    integer                            :: idim1,idim2,idir,iwdim1,iwdim2
 
    associate(bfaces=>s%ws,x=>s%x,w=>s%w,vnorm=>vcts%vnorm)
 
    if(b0field) then
      btot(ixi^s,1:ndim)=wp(ixi^s,mag(1:ndim))+block%B0(ixi^s,1:ndim,0)
    else
      btot(ixi^s,1:ndim)=wp(ixi^s,mag(1:ndim))
    end if
    ecc=0.d0
    ! Calculate electric field at cell centers
    do idim1=1,ndim; do idim2=1,ndim; do idir=7-2*ndim,3
      if(lvc(idim1,idim2,idir)==1)then
         ecc(ixi^s,idir)=ecc(ixi^s,idir)+btot(ixi^s,idim1)*wp(ixi^s,mom(idim2))
      else if(lvc(idim1,idim2,idir)==-1) then
         ecc(ixi^s,idir)=ecc(ixi^s,idir)-btot(ixi^s,idim1)*wp(ixi^s,mom(idim2))
      endif
    enddo; enddo; enddo
 
    ! if there is resistivity, get eta J
    if(mhd_eta/=zero) call get_resistive_electric_field(ixi^l,ixo^l,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)
 
    ! 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)
      do idim2=1,ndim
        iwdim2 = mag(idim2)
        do idir=7-2*ndim,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
            jxc^l=ixc^l+kr(idim1,^d);
            hxc^l=ixc^l+kr(idim2,^d);
            ! average cell-face electric field to cell edges
            fe(ixc^s,idir)=quarter*&
            (fc(ixc^s,iwdim1,idim2)+fc(jxc^s,iwdim1,idim2)&
            -fc(ixc^s,iwdim2,idim1)-fc(hxc^s,iwdim2,idim1))
 
            ! add slope in idim2 direction from equation (50)
            ixamin^d=ixcmin^d;
            ixamax^d=ixcmax^d+kr(idim1,^d);
            el(ixa^s)=fc(ixa^s,iwdim1,idim2)-ecc(ixa^s,idir)
            hxc^l=ixa^l+kr(idim2,^d);
            er(ixa^s)=fc(ixa^s,iwdim1,idim2)-ecc(hxc^s,idir)
            where(vnorm(ixc^s,idim1)>0.d0)
              elc(ixc^s)=el(ixc^s)
            else where(vnorm(ixc^s,idim1)<0.d0)
              elc(ixc^s)=el(jxc^s)
            else where
              elc(ixc^s)=0.5d0*(el(ixc^s)+el(jxc^s))
            end where
            hxc^l=ixc^l+kr(idim2,^d);
            where(vnorm(hxc^s,idim1)>0.d0)
              erc(ixc^s)=er(ixc^s)
            else where(vnorm(hxc^s,idim1)<0.d0)
              erc(ixc^s)=er(jxc^s)
            else where
              erc(ixc^s)=0.5d0*(er(ixc^s)+er(jxc^s))
            end where
            fe(ixc^s,idir)=fe(ixc^s,idir)+0.25d0*(elc(ixc^s)+erc(ixc^s))
 
            ! add slope in idim1 direction from equation (50)
            jxc^l=ixc^l+kr(idim2,^d);
            ixamin^d=ixcmin^d;
            ixamax^d=ixcmax^d+kr(idim2,^d);
            el(ixa^s)=-fc(ixa^s,iwdim2,idim1)-ecc(ixa^s,idir)
            hxc^l=ixa^l+kr(idim1,^d);
            er(ixa^s)=-fc(ixa^s,iwdim2,idim1)-ecc(hxc^s,idir)
            where(vnorm(ixc^s,idim2)>0.d0)
              elc(ixc^s)=el(ixc^s)
            else where(vnorm(ixc^s,idim2)<0.d0)
              elc(ixc^s)=el(jxc^s)
            else where
              elc(ixc^s)=0.5d0*(el(ixc^s)+el(jxc^s))
            end where
            hxc^l=ixc^l+kr(idim1,^d);
            where(vnorm(hxc^s,idim2)>0.d0)
              erc(ixc^s)=er(ixc^s)
            else where(vnorm(hxc^s,idim2)<0.d0)
              erc(ixc^s)=er(jxc^s)
            else where
              erc(ixc^s)=0.5d0*(er(ixc^s)+er(jxc^s))
            end where
            fe(ixc^s,idir)=fe(ixc^s,idir)+0.25d0*(elc(ixc^s)+erc(ixc^s))
 
            ! 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)
 
            ! times time step and edge length
            fe(ixc^s,idir)=fe(ixc^s,idir)*qdt*s%dsC(ixc^s,idir)
            if (.not.slab) then
              where(abs(x(ixc^s,r_)+half*dxlevel(r_))<1.0d-9)
                fe(ixc^s,idir)=zero
              end where
            end if
          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
        do idir=7-2*ndim,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
      ! Divide by the area of the face to get dB/dt
      where(s%surfaceC(ixc^s,idim1) > 1.0d-9*s%dvolume(ixc^s))
        circ(ixc^s,idim1)=circ(ixc^s,idim1)/s%surfaceC(ixc^s,idim1)
      elsewhere
        circ(ixc^s,idim1)=zero
      end where
      ! Time update cell-face magnetic field component
      bfaces(ixc^s,idim1)=bfaces(ixc^s,idim1)-circ(ixc^s,idim1)
    end do
 
    end associate
 
  end subroutine update_faces_contact
 
  !> update faces
  subroutine update_faces_hll(ixI^L,ixO^L,qt,qdt,fE,sCT,s,vcts)
    use mod_global_parameters
    use mod_constrained_transport
    use mod_usr_methods
 
    integer, intent(in)                :: ixI^L, ixO^L
    double precision, intent(in)       :: qt, qdt
    double precision, intent(inout)    :: fE(ixI^S,7-2*ndim:3)
    type(state)                        :: sCT, s
    type(ct_velocity)                  :: vcts
 
    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,7-2*ndim:3) :: E_resi, E_ambi
    integer                            :: hxC^L,ixC^L,ixCp^L,jxC^L,ixCm^L
    integer                            :: idim1,idim2,idir
 
    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,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=7-2*ndim,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=7-2*ndim,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
      ! Divide by the area of the face to get dB/dt
      where(s%surfaceC(ixc^s,idim1) > 1.0d-9*s%dvolume(ixc^s))
        circ(ixc^s,idim1)=circ(ixc^s,idim1)/s%surfaceC(ixc^s,idim1)
      elsewhere
        circ(ixc^s,idim1)=zero
      end where
      ! Time update cell-face magnetic field component
      bfaces(ixc^s,idim1)=bfaces(ixc^s,idim1)-circ(ixc^s,idim1)
    end do
 
    end associate
  end subroutine update_faces_hll
 
  !> calculate eta J at cell edges
  subroutine get_resistive_electric_field(ixI^L,ixO^L,sCT,s,jce)
    use mod_global_parameters
    use mod_usr_methods
    use mod_geometry
 
    integer, intent(in)                :: ixI^L, ixO^L
    type(state), intent(in)            :: sCT, s
    ! current on cell edges
    double precision :: jce(ixI^S,7-2*ndim: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=7-2*ndim,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 gradientx(wcts(ixgs^t,idim2),xs,ixgs^ll,ixc^l,idim1,gradi,.true.)
          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(wct,ixi^l,ixa^l,idirmin,x,jcc,eta)
      ! calcuate eta on cell edges
      do idir=7-2*ndim,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)
      enddo
    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,7-2*ndim: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)
    ! calcuate electric field on cell edges from cell centers
    do idir=7-2*ndim,3
      !set electric field in jxbxb: E=nuA * jxbxb, where nuA=-etaA/rho^2
      !jxbxb(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                            :: fxo^l, gxo^l, hxo^l, jxo^l, kxo^l, idim
 
    associate(w=>s%w, ws=>s%ws)
 
    ! calculate cell-center values from face-center values in 2nd order
    do idim=1,ndim
      ! Displace index to the left
      ! Even if ixI^L is the full size of the w arrays, this is ok
      ! because the staggered arrays have an additional place to the left.
      hxo^l=ixo^l-kr(idim,^d);
      ! Interpolate to cell barycentre using arithmetic average
      ! This might be done better later, to make the method less diffusive.
      w(ixo^s,mag(idim))=half/s%surface(ixo^s,idim)*&
        (ws(ixo^s,idim)*s%surfaceC(ixo^s,idim)&
        +ws(hxo^s,idim)*s%surfaceC(hxo^s,idim))
    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 associate
 
  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