mod_thermal_conduction.t

Go to the documentation of this file.

!> Thermal conduction for HD and MHD
!> Adaptation of mod_thermal_conduction for the mod_supertimestepping
!> In order to use it set use_mhd_tc=1 (for the mhd impl) or 2 (for the hd impl) in mhd_list  (for the mhd module both hd and mhd impl can be used)
!> or use_new_hd_tc in hd_list parameters to true
!> (for the hd module, hd implementation has to be used)
!> The TC is set by calling one
!> tc_init_hd_for_total_energy and tc_init_mhd_for_total_energy might
!> The second argument: ixArray has to be [rho_,e_,mag(1)] for mhd (Be aware that the other components of the mag field are assumed consecutive) and [rho_,e_] for hd
!> additionally when internal energy equation is solved, an additional element of this array is eaux_: the index of the internal energy variable.
!>
!> 10.07.2011 developed by Chun Xia and Rony Keppens
!> 01.09.2012 moved to modules folder by Oliver Porth
!> 13.10.2013 optimized further by Chun Xia
!> 12.03.2014 implemented RKL2 super timestepping scheme to reduce iterations
!> and improve stability and accuracy up to second order in time by Chun Xia.
!> 23.08.2014 implemented saturation and perpendicular TC by Chun Xia
!> 12.01.2017 modulized by Chun Xia
!>
!> PURPOSE:
!> IN MHD ADD THE HEAT CONDUCTION SOURCE TO THE ENERGY EQUATION
!> S=DIV(KAPPA_i,j . GRAD_j T)
!> where KAPPA_i,j = tc_k_para b_i b_j + tc_k_perp (I - b_i b_j)
!> b_i b_j = B_i B_j / B**2, I is the unit matrix, and i, j= 1, 2, 3 for 3D
!> IN HD ADD THE HEAT CONDUCTION SOURCE TO THE ENERGY EQUATION
!> S=DIV(tc_k_para . GRAD T)
!> USAGE:
!> 1. in mod_usr.t -> subroutine usr_init(), add
!>        unit_length=your length unit
!>        unit_numberdensity=your number density unit
!>        unit_velocity=your velocity unit
!>        unit_temperature=your temperature unit
!>    before call (m)hd_activate()
!> 2. to switch on thermal conduction in the (m)hd_list of amrvac.par add:
!>    (m)hd_thermal_conduction=.true.
!> 3. in the tc_list of amrvac.par :
!>    tc_perpendicular=.true.  ! (default .false.) turn on thermal conduction perpendicular to magnetic field
!>    tc_saturate=.true.  ! (default .false. ) turn on thermal conduction saturate effect
!>    tc_slope_limiter='MC' ! choose limiter for slope-limited anisotropic thermal conduction in MHD
 
module mod_thermal_conduction
  use mod_global_parameters, only: std_len
  use mod_geometry
  use mod_comm_lib, only: mpistop
  implicit none
 
    !> The adiabatic index
    double precision :: tc_gamma_1
 
  abstract interface
    subroutine get_var_subr(w,x,ixI^L,ixO^L,res)
      use mod_global_parameters
      integer, intent(in)          :: ixI^L, ixO^L
      double precision, intent(in) :: w(ixI^S,nw)
      double precision, intent(in) :: x(ixI^S,1:ndim)
      double precision, intent(out):: res(ixI^S)
    end subroutine get_var_subr
 
 
  end interface
 
  type tc_fluid
 
    procedure(get_var_subr), pointer, nopass :: get_rho => null()
    procedure(get_var_subr), pointer, nopass :: get_rho_equi => null()
    procedure(get_var_subr), pointer,nopass :: get_temperature_from_eint => null()
    procedure(get_var_subr), pointer,nopass :: get_temperature_from_conserved => null()
    procedure(get_var_subr), pointer,nopass :: get_temperature_equi => null()
     !> Indices of the variables
    integer :: e_=-1
    !> Index of cut off temperature for TRAC
    integer :: tcoff_
    ! if has_equi = .true. get_temperature_equi and get_rho_equi have to be set
    logical :: has_equi=.false.
 
    ! the following are read from param file or set in tc_read_hd_params or tc_read_mhd_params
    !> Coefficient of thermal conductivity (parallel to magnetic field)
    double precision :: tc_k_para
 
    !> Coefficient of thermal conductivity perpendicular to magnetic field
    double precision :: tc_k_perp
 
    !> Name of slope limiter for transverse component of thermal flux
    integer :: tc_slope_limiter
 
    !> Logical switch for test constant conductivity
    logical :: tc_constant=.false.
 
    !> Calculate thermal conduction perpendicular to magnetic field (.true.) or not (.false.)
    logical :: tc_perpendicular=.false.
 
    !> Consider thermal conduction saturation effect (.true.) or not (.false.)
    logical :: tc_saturate=.false.
    ! END the following are read from param file or set in tc_read_hd_params or tc_read_mhd_params
  end type tc_fluid
 
 
  public :: tc_get_mhd_params
  public :: tc_get_hd_params
  public :: get_tc_dt_mhd
  public :: get_tc_dt_hd
  public :: sts_set_source_tc_mhd
  public :: sts_set_source_tc_hd
 
contains
 
  subroutine tc_init_params(phys_gamma)
    use mod_global_parameters
    double precision, intent(in) :: phys_gamma
 
    tc_gamma_1=phys_gamma-1d0
  end subroutine tc_init_params
 
  !> Init  TC coeffiecients: MHD case
  subroutine tc_get_mhd_params(fl,read_mhd_params)
    use mod_global_parameters
 
    interface
      subroutine read_mhd_params(fl)
        use mod_global_parameters, only: unitpar,par_files
        import tc_fluid
        type(tc_fluid), intent(inout) :: fl
 
      end subroutine read_mhd_params
    end interface
 
    type(tc_fluid), intent(inout) :: fl
 
    fl%tc_slope_limiter=1
 
    fl%tc_k_para=0.d0
 
    fl%tc_k_perp=0.d0
 
    call read_mhd_params(fl)
 
    if(fl%tc_k_para==0.d0 .and. fl%tc_k_perp==0.d0) then
      if(si_unit) then
        ! Spitzer thermal conductivity with SI units
        fl%tc_k_para=8.d-12*unit_temperature**3.5d0/unit_length/unit_density/unit_velocity**3
        ! thermal conductivity perpendicular to magnetic field
        fl%tc_k_perp=4.d-30*unit_numberdensity**2/unit_magneticfield**2/unit_temperature**3*fl%tc_k_para
      else
        ! Spitzer thermal conductivity with cgs units
        fl%tc_k_para=8.d-7*unit_temperature**3.5d0/unit_length/unit_density/unit_velocity**3
        ! thermal conductivity perpendicular to magnetic field
        fl%tc_k_perp=4.d-10*unit_numberdensity**2/unit_magneticfield**2/unit_temperature**3*fl%tc_k_para
      end if
      if(mype .eq. 0) print*, "Spitzer MHD: par: ",fl%tc_k_para, &
          " ,perp: ",fl%tc_k_perp
    else
      fl%tc_constant=.true.
    end if
 
    contains
 
    !> Read tc module parameters from par file: MHD case
 
  end subroutine tc_get_mhd_params
 
  subroutine tc_get_hd_params(fl,read_hd_params)
    use mod_global_parameters
 
    interface
      subroutine read_hd_params(fl)
        use mod_global_parameters, only: unitpar,par_files
        import tc_fluid
        type(tc_fluid), intent(inout) :: fl
 
      end subroutine read_hd_params
    end interface
    type(tc_fluid), intent(inout) :: fl
 
    fl%tc_k_para=0.d0
    !> Read tc parameters from par file: HD case
    call read_hd_params(fl)
    if(fl%tc_k_para==0.d0 ) then
      if(si_unit) then
        ! Spitzer thermal conductivity with SI units
        fl%tc_k_para=8.d-12*unit_temperature**3.5d0/unit_length/unit_density/unit_velocity**3
      else
        ! Spitzer thermal conductivity with cgs units
        fl%tc_k_para=8.d-7*unit_temperature**3.5d0/unit_length/unit_density/unit_velocity**3
      end if
      if(mype .eq. 0) print*, "Spitzer HD par: ",fl%tc_k_para
    end if
  end subroutine tc_get_hd_params
 
  !> Get the explicut timestep for the TC (mhd implementation)
  function get_tc_dt_mhd(w,ixI^L,ixO^L,dx^D,x,fl) 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
 
    type(tc_fluid), intent(in)  ::  fl
    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 :: mf(ixo^s,1:ndim),te(ixi^s),b2(ixi^s),gradt(ixi^s)
    double precision :: tmp2(ixo^s),tmp(ixo^s),hfs(ixo^s)
    double precision :: dtdiff_tcond,maxtmp2
    integer          :: idims
 
    !temperature
    call fl%get_temperature_from_conserved(w,x,ixi^l,ixi^l,te)
 
    ! B
    if(b0field) then
      mf(ixo^s,1:ndim)=w(ixo^s,iw_mag(1:ndim))+block%B0(ixo^s,1:ndim,0)
    else
      mf(ixo^s,1:ndim)=w(ixo^s,iw_mag(1:ndim))
    end if
    ! B**2
    tmp=sum(mf**2,dim=ndim+1)
    ! B_i**2/B**2
    where(tmp(ixo^s)/=0.d0)
      ^d&mf(ixo^s,^d)=mf(ixo^s,^d)**2/tmp(ixo^s);
    elsewhere
      ^d&mf(ixo^s,^d)=1.d0;
    end where
 
    dtnew=bigdouble
    ! B2 is now density
    call fl%get_rho(w,x,ixi^l,ixo^l,b2)
 
    !tc_k_para_i
    if(fl%tc_constant) then
      tmp(ixo^s)=fl%tc_k_para
    else
      if(fl%tc_saturate) then
        ! Kannan 2016 MN 458, 410
        ! 3^1.5*kB^2/(4*sqrt(pi)*e^4)
        ! l_mfpe=3.d0**1.5d0*kB_cgs**2/(4.d0*sqrt(dpi)*e_cgs**4*37.d0)=7093.9239487765044d0
        tmp2(ixo^s)=te(ixo^s)**2/b2(ixo^s)*7093.9239487765044d0*unit_temperature**2/(unit_numberdensity*unit_length)
        hfs=0.d0
        do idims=1,ndim
          call gradient(te,ixi^l,ixo^l,idims,gradt)
          hfs(ixo^s)=hfs(ixo^s)+gradt(ixo^s)*sqrt(mf(ixo^s,idims))
        end do
        ! kappa=kappa_Spizer/(1+4.2*l_mfpe/(T/|gradT.b|))
        tmp(ixo^s)=fl%tc_k_para*dsqrt(te(ixo^s)**5)/(1.d0+4.2d0*tmp2(ixo^s)*dabs(hfs(ixo^s))/te(ixo^s))
      else
        ! kappa=kappa_Spizer
        tmp(ixo^s)=fl%tc_k_para*dsqrt(te(ixo^s)**5)
      end if
    end if
 
    if(slab_uniform) then
      do idims=1,ndim
        ! approximate thermal conduction flux: tc_k_para_i/rho/dx*B_i**2/B**2
        tmp2(ixo^s)=tmp(ixo^s)*mf(ixo^s,idims)/(b2(ixo^s)*dxlevel(idims))
        maxtmp2=maxval(tmp2(ixo^s))
        ! dt< dx_idim**2/((gamma-1)*tc_k_para_i/rho*B_i**2/B**2)
        dtdiff_tcond=dxlevel(idims)/(tc_gamma_1*maxtmp2+smalldouble)
        ! limit the time step
        dtnew=min(dtnew,dtdiff_tcond)
      end do
    else
      do idims=1,ndim
        ! approximate thermal conduction flux: tc_k_para_i/rho/dx*B_i**2/B**2
        tmp2(ixo^s)=tmp(ixo^s)*mf(ixo^s,idims)/(b2(ixo^s)*block%ds(ixo^s,idims))
        maxtmp2=maxval(tmp2(ixo^s)/block%ds(ixo^s,idims))
        ! dt< dx_idim**2/((gamma-1)*tc_k_para_i/rho*B_i**2/B**2)
        dtdiff_tcond=1.d0/(tc_gamma_1*maxtmp2+smalldouble)
        ! limit the time step
        dtnew=min(dtnew,dtdiff_tcond)
      end do
    end if
    dtnew=dtnew/dble(ndim)
 
  end function get_tc_dt_mhd
 
  !> anisotropic thermal conduction with slope limited symmetric scheme
  !> Sharma 2007 Journal of Computational Physics 227, 123
  subroutine sts_set_source_tc_mhd(ixI^L,ixO^L,w,x,wres,fix_conserve_at_step,my_dt,igrid,nflux,fl)
    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(in) ::   w(ixi^s,1:nw)
    double precision, intent(inout) ::  wres(ixi^s,1:nw)
    double precision, intent(in) :: my_dt
    logical, intent(in) :: fix_conserve_at_step
    type(tc_fluid), intent(in) :: fl
 
    !! qd store the heat conduction energy changing rate
    double precision :: qd(ixi^s)
    double precision :: rho(ixi^s),te(ixi^s)
    double precision :: qvec(ixi^s,1:ndim)
    double precision, allocatable, dimension(:^D&,:) :: qvec_equi
 
    double precision, allocatable, dimension(:^D&,:,:) :: fluxall
    double precision :: alpha,dxinv(ndim)
    integer :: idims,idir,ix^d,ix^l,ixc^l,ixa^l,ixb^l
 
    ! coefficient of limiting on normal component
    if(ndim<3) then
      alpha=0.75d0
    else
      alpha=0.85d0
    end if
    ix^l=ixo^l^ladd1;
 
    dxinv=1.d0/dxlevel
 
    call fl%get_temperature_from_eint(w, x, ixi^l, ixi^l, te)  !calculate Te in whole domain (+ghosts)
    call fl%get_rho(w, x, ixi^l, ixi^l, rho)  !calculate rho in whole domain (+ghosts)
    call set_source_tc_mhd(ixi^l,ixo^l,w,x,fl,qvec,rho,te,alpha)
    if(fl%has_equi) then
      allocate(qvec_equi(ixi^s,1:ndim))
      call fl%get_temperature_equi(w, x, ixi^l, ixi^l, te)  !calculate Te in whole domain (+ghosts)
      call fl%get_rho_equi(w, x, ixi^l, ixi^l, rho)  !calculate rho in whole domain (+ghosts)
      call set_source_tc_mhd(ixi^l,ixo^l,w,x,fl,qvec_equi,rho,te,alpha)
      do idims=1,ndim
        qvec(ix^s,idims)=qvec(ix^s,idims) - qvec_equi(ix^s,idims)
      end do
      deallocate(qvec_equi)
    endif
 
    qd=0.d0
    if(slab_uniform) then
      do idims=1,ndim
        qvec(ix^s,idims)=dxinv(idims)*qvec(ix^s,idims)
        ixb^l=ixo^l-kr(idims,^d);
        qd(ixo^s)=qd(ixo^s)+qvec(ixo^s,idims)-qvec(ixb^s,idims)
      end do
    else
      do idims=1,ndim
        qvec(ix^s,idims)=qvec(ix^s,idims)*block%surfaceC(ix^s,idims)
        ixb^l=ixo^l-kr(idims,^d);
        qd(ixo^s)=qd(ixo^s)+qvec(ixo^s,idims)-qvec(ixb^s,idims)
      end do
      qd(ixo^s)=qd(ixo^s)/block%dvolume(ixo^s)
    end if
 
    if(fix_conserve_at_step) then
      allocate(fluxall(ixi^s,1,1:ndim))
      fluxall(ixi^s,1,1:ndim)=my_dt*qvec(ixi^s,1:ndim)
      call store_flux(igrid,fluxall,1,ndim,nflux)
      deallocate(fluxall)
    end if
 
    wres(ixo^s,fl%e_)=qd(ixo^s)
 
  end subroutine sts_set_source_tc_mhd
 
  subroutine set_source_tc_mhd(ixI^L,ixO^L,w,x,fl,qvec,rho,Te,alpha)
    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)
    type(tc_fluid), intent(in) :: fl
    double precision, intent(in) :: rho(ixI^S),Te(ixI^S)
    double precision, intent(in) :: alpha
    double precision, intent(out) :: qvec(ixI^S,1:ndim)
 
    !! qd store the heat conduction energy changing rate
    double precision :: qd(ixI^S)
 
    double precision, dimension(ixI^S,1:ndim) :: mf,Bc,Bcf
    double precision, dimension(ixI^S,1:ndim) :: gradT
    double precision, dimension(ixI^S) :: ka,kaf,ke,kef,qdd,qe,Binv,minq,maxq,Bnorm
    double precision, allocatable, dimension(:^D&,:,:) :: fluxall
    integer, dimension(ndim) :: lowindex
    integer :: idims,idir,ix^D,ix^L,ixC^L,ixA^L,ixB^L,ixA^D,ixB^D
 
    ix^l=ixo^l^ladd1;
 
    ! T gradient at cell faces
    ! B vector
    if(b0field) then
      mf(ixi^s,1:ndim)=w(ixi^s,iw_mag(1:ndim))+block%B0(ixi^s,1:ndim,0)
    else
      mf(ixi^s,1:ndim)=w(ixi^s,iw_mag(1:ndim))
    end if
    ! |B|
    binv=dsqrt(sum(mf**2,dim=ndim+1))
    {do ix^db=ixmin^db,ixmax^db\}
      if(binv(ix^d)/=0.d0) then
        binv(ix^d)=1.d0/binv(ix^d)
      else
        binv(ix^d)=bigdouble
      end if
    {end do\}
    ! b unit vector: magnetic field direction vector
    do idims=1,ndim
      mf(ix^s,idims)=mf(ix^s,idims)*binv(ix^s)
    end do
    ! ixC is cell-corner index
    ixcmax^d=ixomax^d; ixcmin^d=ixomin^d-1;
    ! b unit vector at cell corner
    bc=0.d0
    {do ix^db=0,1\}
      ixamin^d=ixcmin^d+ix^d;
      ixamax^d=ixcmax^d+ix^d;
      bc(ixc^s,1:ndim)=bc(ixc^s,1:ndim)+mf(ixa^s,1:ndim)
    {end do\}
    bc(ixc^s,1:ndim)=bc(ixc^s,1:ndim)*0.5d0**ndim
    ! T gradient at cell faces
    do idims=1,ndim
      ixbmin^d=ixmin^d;
      ixbmax^d=ixmax^d-kr(idims,^d);
      call gradientc(te,ixi^l,ixb^l,idims,minq)
      gradt(ixb^s,idims)=minq(ixb^s)
    end do
    if(fl%tc_constant) then
      if(fl%tc_perpendicular) then
        ka(ixc^s)=fl%tc_k_para-fl%tc_k_perp
        ke(ixc^s)=fl%tc_k_perp
      else
        ka(ixc^s)=fl%tc_k_para
      end if
    else
      ! conductivity at cell center
      if(phys_trac) then
        minq(ix^s)=te(ix^s)
       {do ix^db=ixmin^db,ixmax^db\}
          if(minq(ix^d) < block%wextra(ix^d,fl%Tcoff_)) then
            minq(ix^d)=block%wextra(ix^d,fl%Tcoff_)
          end if
       {end do\}
        minq(ix^s)=fl%tc_k_para*sqrt(minq(ix^s)**5)
      else
        minq(ix^s)=fl%tc_k_para*sqrt(te(ix^s)**5)
      end if
      ka=0.d0
      {do ix^db=0,1\}
        ixbmin^d=ixcmin^d+ix^d;
        ixbmax^d=ixcmax^d+ix^d;
        ka(ixc^s)=ka(ixc^s)+minq(ixb^s)
      {end do\}
      ! cell corner conductivity
      ka(ixc^s)=0.5d0**ndim*ka(ixc^s)
      ! compensate with perpendicular conductivity
      if(fl%tc_perpendicular) then
        minq(ix^s)=fl%tc_k_perp*rho(ix^s)**2*binv(ix^s)**2/dsqrt(te(ix^s))
        ke=0.d0
        {do ix^db=0,1\}
          ixbmin^d=ixcmin^d+ix^d;
          ixbmax^d=ixcmax^d+ix^d;
          ke(ixc^s)=ke(ixc^s)+minq(ixb^s)
        {end do\}
        ! cell corner conductivity: k_parallel-k_perpendicular
        ke(ixc^s)=0.5d0**ndim*ke(ixc^s)
       {do ix^db=ixcmin^db,ixcmax^db\}
          if(ke(ix^d)<ka(ix^d)) then
            ka(ix^d)=ka(ix^d)-ke(ix^d)
          else
            ke(ix^d)=ka(ix^d)
            ka(ix^d)=0.d0
          end if
       {end do\}
      end if
    end if
    if(fl%tc_slope_limiter==0) then
      ! calculate thermal conduction flux with symmetric scheme
      do idims=1,ndim
        !qd corner values
        qd=0.d0
        {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;
             qd(ixc^s)=qd(ixc^s)+gradt(ixb^s,idims)
           end if
        {end do\}
        ! temperature gradient at cell corner
        qvec(ixc^s,idims)=qd(ixc^s)*0.5d0**(ndim-1)
      end do
      ! b grad T at cell corner
      qd(ixc^s)=0.d0
      do idims=1,ndim
       qd(ixc^s)=qvec(ixc^s,idims)*bc(ixc^s,idims)+qd(ixc^s)
      end do
      do idims=1,ndim
        ! TC flux at cell corner
        gradt(ixc^s,idims)=ka(ixc^s)*bc(ixc^s,idims)*qd(ixc^s)
        if(fl%tc_perpendicular) gradt(ixc^s,idims)=gradt(ixc^s,idims)+ke(ixc^s)*qvec(ixc^s,idims)
      end do
      ! TC flux at cell face
      qvec=0.d0
      do idims=1,ndim
        ixb^l=ixo^l-kr(idims,^d);
        ixamax^d=ixomax^d; ixamin^d=ixbmin^d;
        {do ix^db=0,1 \}
           if({ ix^d==0 .and. ^d==idims | .or.}) then
             ixbmin^d=ixamin^d-ix^d;
             ixbmax^d=ixamax^d-ix^d;
             qvec(ixa^s,idims)=qvec(ixa^s,idims)+gradt(ixb^s,idims)
           end if
        {end do\}
        qvec(ixa^s,idims)=qvec(ixa^s,idims)*0.5d0**(ndim-1)
        if(fl%tc_saturate) then
          ! consider saturation (Cowie and Mckee 1977 ApJ, 211, 135)
          ! unsigned saturated TC flux = 5 phi rho c**3, c is isothermal sound speed
          bcf=0.d0
          {do ix^db=0,1 \}
             if({ ix^d==0 .and. ^d==idims | .or.}) then
               ixbmin^d=ixamin^d-ix^d;
               ixbmax^d=ixamax^d-ix^d;
               bcf(ixa^s,idims)=bcf(ixa^s,idims)+bc(ixb^s,idims)
             end if
          {end do\}
          ! averaged b at face centers
          bcf(ixa^s,idims)=bcf(ixa^s,idims)*0.5d0**(ndim-1)
          ixb^l=ixa^l+kr(idims,^d);
          qd(ixa^s)=2.75d0*(rho(ixa^s)+rho(ixb^s))*dsqrt(0.5d0*(te(ixa^s)+te(ixb^s)))**3*dabs(bcf(ixa^s,idims))
         {do ix^db=ixamin^db,ixamax^db\}
            if(dabs(qvec(ix^d,idims))>qd(ix^d)) then
              qvec(ix^d,idims)=sign(1.d0,qvec(ix^d,idims))*qd(ix^d)
            end if
         {end do\}
        end if
      end do
    else
      ! calculate thermal conduction flux with slope-limited symmetric scheme
      qvec=0.d0
      do idims=1,ndim
        ixb^l=ixo^l-kr(idims,^d);
        ixamax^d=ixomax^d; ixamin^d=ixbmin^d;
        ! calculate normal of magnetic field
        ixb^l=ixa^l+kr(idims,^d);
        bnorm(ixa^s)=0.5d0*(mf(ixa^s,idims)+mf(ixb^s,idims))
        bcf=0.d0
        kaf=0.d0
        kef=0.d0
        {do ix^db=0,1 \}
           if({ ix^d==0 .and. ^d==idims | .or.}) then
             ixbmin^d=ixamin^d-ix^d;
             ixbmax^d=ixamax^d-ix^d;
             bcf(ixa^s,1:ndim)=bcf(ixa^s,1:ndim)+bc(ixb^s,1:ndim)
             kaf(ixa^s)=kaf(ixa^s)+ka(ixb^s)
             if(fl%tc_perpendicular) kef(ixa^s)=kef(ixa^s)+ke(ixb^s)
           end if
        {end do\}
        ! averaged b at face centers
        bcf(ixa^s,1:ndim)=bcf(ixa^s,1:ndim)*0.5d0**(ndim-1)
        ! averaged thermal conductivity at face centers
        kaf(ixa^s)=kaf(ixa^s)*0.5d0**(ndim-1)
        if(fl%tc_perpendicular) kef(ixa^s)=kef(ixa^s)*0.5d0**(ndim-1)
        ! limited normal component
        minq(ixa^s)=min(alpha*gradt(ixa^s,idims),gradt(ixa^s,idims)/alpha)
        maxq(ixa^s)=max(alpha*gradt(ixa^s,idims),gradt(ixa^s,idims)/alpha)
        ! eq (19)
        !corner values of gradT
        qdd=0.d0
        {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;
             qdd(ixc^s)=qdd(ixc^s)+gradt(ixb^s,idims)
           end if
        {end do\}
        ! temperature gradient at cell corner
        qdd(ixc^s)=qdd(ixc^s)*0.5d0**(ndim-1)
        ! eq (21)
        qe=0.d0
        {do ix^db=0,1 \}
           qd(ixc^s)=qdd(ixc^s)
           if({ ix^d==0 .and. ^d==idims | .or.}) then
             ixbmin^d=ixamin^d-ix^d;
             ixbmax^d=ixamax^d-ix^d;
            {do ixa^db=ixamin^db,ixamax^db
               ixb^db=ixa^db-ix^db\}
               if(qd(ixb^d)<=minq(ixa^d)) then
                 qd(ixb^d)=minq(ixa^d)
               else if(qd(ixb^d)>=maxq(ixa^d)) then
                 qd(ixb^d)=maxq(ixa^d)
               end if 
            {end do\}
             qvec(ixa^s,idims)=qvec(ixa^s,idims)+bc(ixb^s,idims)**2*qd(ixb^s)
             if(fl%tc_perpendicular) qe(ixa^s)=qe(ixa^s)+qd(ixb^s)
           end if
        {end do\}
        qvec(ixa^s,idims)=kaf(ixa^s)*qvec(ixa^s,idims)*0.5d0**(ndim-1)
        ! add normal flux from perpendicular conduction
        if(fl%tc_perpendicular) qvec(ixa^s,idims)=qvec(ixa^s,idims)+kef(ixa^s)*qe(ixa^s)*0.5d0**(ndim-1)
        ! limited transverse component, eq (17)
        ixbmin^d=ixamin^d;
        ixbmax^d=ixamax^d+kr(idims,^d);
        do idir=1,ndim
          if(idir==idims) cycle
          qd(ixi^s)=slope_limiter(gradt(ixi^s,idir),ixi^l,ixb^l,idir,-1,fl%tc_slope_limiter)
          qd(ixi^s)=slope_limiter(qd,ixi^l,ixa^l,idims,1,fl%tc_slope_limiter)
          qvec(ixa^s,idims)=qvec(ixa^s,idims)+kaf(ixa^s)*bnorm(ixa^s)*bcf(ixa^s,idir)*qd(ixa^s)
        end do
 
        if(fl%tc_saturate) then
          ! consider saturation (Cowie and Mckee 1977 ApJ, 211, 135)
          ! unsigned saturated TC flux = 5 phi rho c**3, c=sqrt(p/rho) is isothermal sound speed, phi=1.1
          ixb^l=ixa^l+kr(idims,^d);
          qd(ixa^s)=2.75d0*(rho(ixa^s)+rho(ixb^s))*dsqrt(0.5d0*(te(ixa^s)+te(ixb^s)))**3*dabs(bnorm(ixa^s))
         {do ix^db=ixamin^db,ixamax^db\}
            if(dabs(qvec(ix^d,idims))>qd(ix^d)) then
              !write(*,*) 'it',it,qvec(ix^D,idims),qd(ix^D),' TC saturated at ',&
              !x(ix^D,:),' rho',rho(ix^D),' Te',Te(ix^D)
              qvec(ix^d,idims)=sign(1.d0,qvec(ix^d,idims))*qd(ix^d)
            end if
         {end do\}
        end if
      end do
    end if
 
  end subroutine set_source_tc_mhd
 
  function slope_limiter(f,ixI^L,ixO^L,idims,pm,tc_slope_limiter) result(lf)
    use mod_global_parameters
    integer, intent(in) :: ixi^l, ixo^l, idims, pm
    double precision, intent(in) :: f(ixi^s)
    double precision :: lf(ixi^s)
    integer, intent(in)  :: tc_slope_limiter
 
    double precision :: signf(ixi^s)
    integer :: ixb^l
 
    ixb^l=ixo^l+pm*kr(idims,^d);
    signf(ixo^s)=sign(1.d0,f(ixo^s))
    select case(tc_slope_limiter)
     case(1)
       ! 'MC' montonized central limiter Woodward and Collela limiter (eq.3.51h), a factor of 2 is pulled out
       lf(ixo^s)=two*signf(ixo^s)* &
            max(zero,min(dabs(f(ixo^s)),signf(ixo^s)*f(ixb^s),&
            signf(ixo^s)*quarter*(f(ixb^s)+f(ixo^s))))
     case(2)
       ! 'minmod' limiter
       lf(ixo^s)=signf(ixo^s)*max(0.d0,min(abs(f(ixo^s)),signf(ixo^s)*f(ixb^s)))
     case(3)
       ! 'superbee' Roes superbee limiter (eq.3.51i)
       lf(ixo^s)=signf(ixo^s)* &
            max(zero,min(two*dabs(f(ixo^s)),signf(ixo^s)*f(ixb^s)),&
            min(dabs(f(ixo^s)),two*signf(ixo^s)*f(ixb^s)))
     case(4)
       ! 'koren' Barry Koren Right variant
       lf(ixo^s)=signf(ixo^s)* &
            max(zero,min(two*dabs(f(ixo^s)),two*signf(ixo^s)*f(ixb^s),&
            (two*f(ixb^s)*signf(ixo^s)+dabs(f(ixo^s)))*third))
     case default
       call mpistop("Unknown slope limiter for thermal conduction")
    end select
 
  end function slope_limiter
 
  !> Calculate gradient of a scalar q at cell interfaces in direction idir
  subroutine gradientc(q,ixI^L,ixO^L,idir,gradq)
    use mod_global_parameters
 
    integer, intent(in)             :: ixI^L, ixO^L, idir
    double precision, intent(in)    :: q(ixI^S)
    double precision, intent(inout) :: gradq(ixI^S)
    integer                         :: jxO^L
 
    associate(x=>block%x)
 
    jxo^l=ixo^l+kr(idir,^d);
    select case(coordinate)
    case(cartesian)
      gradq(ixo^s)=(q(jxo^s)-q(ixo^s))/dxlevel(idir)
    case(cartesian_stretched)
      gradq(ixo^s)=(q(jxo^s)-q(ixo^s))/(x(jxo^s,idir)-x(ixo^s,idir))
    case(spherical)
      select case(idir)
      case(1)
        gradq(ixo^s)=(q(jxo^s)-q(ixo^s))/(x(jxo^s,1)-x(ixo^s,1))
        {^nooned
      case(2)
        gradq(ixo^s)=(q(jxo^s)-q(ixo^s))/( (x(jxo^s,2)-x(ixo^s,2))*x(ixo^s,1) )
        }
        {^ifthreed
      case(3)
        gradq(ixo^s)=(q(jxo^s)-q(ixo^s))/( (x(jxo^s,3)-x(ixo^s,3))*x(ixo^s,1)*dsin(x(ixo^s,2)) )
        }
      end select
    case(cylindrical)
      if(idir==phi_) then
        gradq(ixo^s)=(q(jxo^s)-q(ixo^s))/((x(jxo^s,phi_)-x(ixo^s,phi_))*x(ixo^s,r_))
      else
        gradq(ixo^s)=(q(jxo^s)-q(ixo^s))/(x(jxo^s,idir)-x(ixo^s,idir))
      end if
    case default
      call mpistop('Unknown geometry')
    end select
 
    end associate
  end subroutine gradientc
 
  function get_tc_dt_hd(w,ixI^L,ixO^L,dx^D,x,fl)  result(dtnew)
    ! Check diffusion time limit dt < dx_i**2 / ((gamma-1)*tc_k_para_i/rho)
    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)
    type(tc_fluid), intent(in) :: fl
    double precision :: dtnew
 
    double precision :: tmp(ixo^s),tmp2(ixo^s),te(ixi^s),rho(ixi^s),hfs(ixo^s),gradt(ixi^s)
    double precision :: dtdiff_tcond,maxtmp2
    integer          :: idim
 
    call fl%get_temperature_from_conserved(w,x,ixi^l,ixi^l,te)
    call fl%get_rho(w,x,ixi^l,ixo^l,rho)
 
    if(fl%tc_saturate) then
      ! Kannan 2016 MN 458, 410
      ! 3^1.5*kB^2/(4*sqrt(pi)*e^4)
      ! l_mfpe=3.d0**1.5d0*kB_cgs**2/(4.d0*sqrt(dpi)*e_cgs**4*37.d0)=7093.9239487765044d0
      tmp2(ixo^s)=te(ixo^s)**2/rho(ixo^s)*7093.9239487765044d0*unit_temperature**2/(unit_numberdensity*unit_length)
      hfs=0.d0
      do idim=1,ndim
        call gradient(te,ixi^l,ixo^l,idim,gradt)
        hfs(ixo^s)=hfs(ixo^s)+gradt(ixo^s)**2
      end do
      ! kappa=kappa_Spizer/(1+4.2*l_mfpe/(T/|gradT|))
      tmp(ixo^s)=fl%tc_k_para*dsqrt((te(ixo^s))**5)/(rho(ixo^s)*(1.d0+4.2d0*tmp2(ixo^s)*sqrt(hfs(ixo^s))/te(ixo^s)))
    else
      tmp(ixo^s)=fl%tc_k_para*dsqrt((te(ixo^s))**5)/rho(ixo^s)
    end if
    dtnew = bigdouble
 
    if(slab_uniform) then
      do idim=1,ndim
        ! approximate thermal conduction flux: tc_k_para_i/rho/dx
        tmp2(ixo^s)=tmp(ixo^s)/dxlevel(idim)
        maxtmp2=maxval(tmp2(ixo^s))
        ! dt< dx_idim**2/((gamma-1)*tc_k_para_i/rho)
        dtdiff_tcond=dxlevel(idim)/(tc_gamma_1*maxtmp2+smalldouble)
        ! limit the time step
        dtnew=min(dtnew,dtdiff_tcond)
      end do
    else
      do idim=1,ndim
        ! approximate thermal conduction flux: tc_k_para_i/rho/dx
        tmp2(ixo^s)=tmp(ixo^s)/block%ds(ixo^s,idim)
        maxtmp2=maxval(tmp2(ixo^s)/block%ds(ixo^s,idim))
        ! dt< dx_idim**2/((gamma-1)*tc_k_para_i/rho*B_i**2/B**2)
        dtdiff_tcond=1.d0/(tc_gamma_1*maxtmp2+smalldouble)
        ! limit the time step
        dtnew=min(dtnew,dtdiff_tcond)
      end do
    end if
    dtnew=dtnew/dble(ndim)
 
  end function get_tc_dt_hd
 
  subroutine sts_set_source_tc_hd(ixI^L,ixO^L,w,x,wres,fix_conserve_at_step,my_dt,igrid,nflux,fl)
    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(in) ::  w(ixi^s,1:nw)
    double precision, intent(inout) ::  wres(ixi^s,1:nw)
    double precision, intent(in) :: my_dt
    logical, intent(in) :: fix_conserve_at_step
    type(tc_fluid), intent(in)    :: fl
 
    double precision :: te(ixi^s),rho(ixi^s)
    double precision :: qvec(ixi^s,1:ndim),qd(ixi^s)
    double precision, allocatable, dimension(:^D&,:) :: qvec_equi
    double precision, allocatable, dimension(:^D&,:,:) :: fluxall
 
    double precision :: dxinv(ndim)
    integer :: idims,ix^l,ixb^l
 
    ix^l=ixo^l^ladd1;
 
    dxinv=1.d0/dxlevel
 
    !calculate Te in whole domain (+ghosts)
    call fl%get_temperature_from_eint(w, x, ixi^l, ixi^l, te)
    call fl%get_rho(w, x, ixi^l, ixi^l, rho)
    call set_source_tc_hd(ixi^l,ixo^l,w,x,fl,qvec,rho,te)
    if(fl%has_equi) then
      allocate(qvec_equi(ixi^s,1:ndim))
      call fl%get_temperature_equi(w, x, ixi^l, ixi^l, te)  !calculate Te in whole domain (+ghosts)
      call fl%get_rho_equi(w, x, ixi^l, ixi^l, rho)  !calculate rho in whole domain (+ghosts)
      call set_source_tc_hd(ixi^l,ixo^l,w,x,fl,qvec_equi,rho,te)
      do idims=1,ndim
        qvec(ix^s,idims)=qvec(ix^s,idims) - qvec_equi(ix^s,idims)
      end do
      deallocate(qvec_equi)
    endif
 
 
    qd=0.d0
    if(slab_uniform) then
      do idims=1,ndim
        qvec(ix^s,idims)=dxinv(idims)*qvec(ix^s,idims)
        ixb^l=ixo^l-kr(idims,^d);
        qd(ixo^s)=qd(ixo^s)+qvec(ixo^s,idims)-qvec(ixb^s,idims)
      end do
    else
      do idims=1,ndim
        qvec(ix^s,idims)=qvec(ix^s,idims)*block%surfaceC(ix^s,idims)
        ixb^l=ixo^l-kr(idims,^d);
        qd(ixo^s)=qd(ixo^s)+qvec(ixo^s,idims)-qvec(ixb^s,idims)
      end do
      qd(ixo^s)=qd(ixo^s)/block%dvolume(ixo^s)
    end if
 
    if(fix_conserve_at_step) then
      allocate(fluxall(ixi^s,1,1:ndim))
      fluxall(ixi^s,1,1:ndim)=my_dt*qvec(ixi^s,1:ndim)
      call store_flux(igrid,fluxall,1,ndim,nflux)
      deallocate(fluxall)
    end if
    wres(ixo^s,fl%e_)=qd(ixo^s)
 
  end subroutine sts_set_source_tc_hd
 
  subroutine set_source_tc_hd(ixI^L,ixO^L,w,x,fl,qvec,rho,Te)
    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)
    type(tc_fluid), intent(in)    :: fl
    double precision, intent(in) :: Te(ixI^S),rho(ixI^S)
    double precision, intent(out) :: qvec(ixI^S,1:ndim)
 
 
    double precision :: gradT(ixI^S,1:ndim),ke(ixI^S),qd(ixI^S)
 
    integer :: idims,ix^D,ix^L,ixC^L,ixA^L,ixB^L,ixD^L
 
    ix^l=ixo^l^ladd1;
    ! ixC is cell-corner index
    ixcmax^d=ixomax^d; ixcmin^d=ixomin^d-1;
 
    !{^IFONED
    !! cell corner temperature in ke
    !ke=0.d0
    !ixAmax^D=ixmax^D; ixAmin^D=ixmin^D-1;
    !{do ix^DB=0,1\}
    !  ixBmin^D=ixAmin^D+ix^D;
    !  ixBmax^D=ixAmax^D+ix^D;
    !  ke(ixA^S)=ke(ixA^S)+Te(ixB^S)
    !{end do\}
    !ke(ixA^S)=0.5d0**ndim*ke(ixA^S)
    !do idims=1,ndim
    !  ixBmin^D=ixmin^D;
    !  ixBmax^D=ixmax^D-kr(idims,^D);
    !  call gradient(ke,ixI^L,ixB^L,idims,qd)
    !  gradT(ixB^S,idims)=qd(ixB^S)
    !end do
    !! transition region adaptive conduction
    !if(phys_trac) then
    !  where(ke(ixI^S) < block%wextra(ixI^S,fl%Tcoff_))
    !    ke(ixI^S)=block%wextra(ixI^S,fl%Tcoff_)
    !  end where
    !end if
    !! cell corner conduction flux
    !do idims=1,ndim
    !  gradT(ixC^S,idims)=gradT(ixC^S,idims)*fl%tc_k_para*sqrt(ke(ixC^S)**5)
    !end do
    !}
 
    ! calculate thermal conduction flux with symmetric scheme
    ! T gradient (central difference) at cell corners
    do idims=1,ndim
      ixbmin^d=ixmin^d;
      ixbmax^d=ixmax^d-kr(idims,^d);
      call gradientc(te,ixi^l,ixb^l,idims,ke)
      qd=0.d0
     {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;
          qd(ixc^s)=qd(ixc^s)+ke(ixb^s)
        end if
     {end do\}
      ! temperature gradient at cell corner
      qvec(ixc^s,idims)=qd(ixc^s)*0.5d0**(ndim-1)
    end do
    ! conductivity at cell center
    if(phys_trac) then
      ! transition region adaptive conduction
      {do ix^db=ixmin^db,ixmax^db\}
        if(te(ix^d) < block%wextra(ix^d,fl%Tcoff_)) then
          qd(ix^d)=fl%tc_k_para*dsqrt(block%wextra(ix^d,fl%Tcoff_))**5
        else
          qd(ix^d)=fl%tc_k_para*dsqrt(te(ix^d))**5
        end if
      {end do\}
    else
      qd(ix^s)=fl%tc_k_para*dsqrt(te(ix^s))**5
    end if
    ke=0.d0
    {do ix^db=0,1\}
      ixbmin^d=ixcmin^d+ix^d;
      ixbmax^d=ixcmax^d+ix^d;
      ke(ixc^s)=ke(ixc^s)+qd(ixb^s)
    {end do\}
    ! cell corner conductivity
    ke(ixc^s)=0.5d0**ndim*ke(ixc^s)
    ! cell corner conduction flux
    do idims=1,ndim
      gradt(ixc^s,idims)=ke(ixc^s)*qvec(ixc^s,idims)
    end do
 
    if(fl%tc_saturate) then
      ! consider saturation with unsigned saturated TC flux = 5 phi rho c**3
      ! saturation flux at cell center
      qd(ix^s)=5.5d0*rho(ix^s)*dsqrt(te(ix^s)**3)
      !cell corner values of qd in ke
      ke=0.d0
      {do ix^db=0,1\}
        ixbmin^d=ixcmin^d+ix^d;
        ixbmax^d=ixcmax^d+ix^d;
        ke(ixc^s)=ke(ixc^s)+qd(ixb^s)
      {end do\}
      ! cell corner saturation flux
      ke(ixc^s)=0.5d0**ndim*ke(ixc^s)
      ! magnitude of cell corner conduction flux
      qd(ixc^s)=norm2(gradt(ixc^s,:),dim=ndim+1)
      {do ix^db=ixcmin^db,ixcmax^db\}
        if(qd(ix^d)>ke(ix^d)) then
          ke(ix^d)=ke(ix^d)/(qd(ix^d)+smalldouble)
          do idims=1,ndim
            gradt(ix^d,idims)=ke(ix^d)*gradt(ix^d,idims)
          end do
        end if
      {end do\}
    end if
 
    ! conduction flux at cell face
    qvec=0.d0
    do idims=1,ndim
      ixb^l=ixo^l-kr(idims,^d);
      ixamax^d=ixomax^d; ixamin^d=ixbmin^d;
      {do ix^db=0,1 \}
         if({ ix^d==0 .and. ^d==idims | .or.}) then
           ixbmin^d=ixamin^d-ix^d;
           ixbmax^d=ixamax^d-ix^d;
           qvec(ixa^s,idims)=qvec(ixa^s,idims)+gradt(ixb^s,idims)
         end if
      {end do\}
      qvec(ixa^s,idims)=qvec(ixa^s,idims)*0.5d0**(ndim-1)
    end do
 
  end subroutine set_source_tc_hd
 
end module mod_thermal_conduction