mod_fld.t

Go to the documentation of this file.

!> Module for flux limited diffusion (FLD)-approximation in Radiation-(Magneto)hydrodynamics simulations
!>
!> Full description of RHD-FLD in
!> Moens N., Sundqvist J.O., El Mellah I., Poniatowski L., Teunissen J. & Keppens R. 2022, A&A 657, A81
!> Radiation-hydrodynamics with MPI-AMRVAC . Flux-limited diffusion
!> doi:10.1051/0004-6361/202141023
!>
!> Full description for RMHD-FLD in
!> N. Narechania, R. Keppens, A. ud-Doula, N. Moens & J. Sundqvist 2025, A&A 696, A131
!> doi:10.1051/0004-6361/202452208
!> Radiation-magnetohydrodynamics with MPI-AMRVAC using flux-limited diffusion
 
module mod_fld
    use mod_comm_lib, only: mpistop
    use mod_geometry
    implicit none
    !> source split for energy interact and radforce:
    logical :: fld_radforce_split = .false.
    !> Opacity per unit of unit_density
    double precision, public :: fld_kappa0 = 0.34d0
    !> Tolerance for bisection method for Energy sourceterms
    !> This is a percentage of the minimum of gas- and radiation energy
    double precision, public :: fld_bisect_tol = 1.d-4
    !> Tolerance for radiative Energy diffusion
    double precision, public :: fld_diff_tol = 1.d-4
    !> switches for local debug purposes
    logical :: fld_debug,fld_no_mg
    !> switches for opacity
    character(len=8)  :: fld_opacity_law = 'const'
    character(len=50) :: fld_opal_table = 'Y09800' 
    !> flux limiter choice
    character(len=16) :: fld_fluxlimiter = 'Pomraning'
    !> diffusion coefficient for multigrid method
    integer :: i_diff_mg
    !> diffusion coefficient stencil control
    integer :: nth_for_diff_mg
    !> Which method to find the root for the energy interaction polynomial
    character(len=8) :: fld_interaction_method = 'Halley'
    !> A copy of (m)hd_gamma
    double precision, private, protected :: fld_gamma
 
    !> public methods
    !> these are called in mod_hd_phys or mod_mhd_phys
    public :: fld_init
    public :: fld_get_radpress
    public :: fld_get_diffcoef_central
    public :: add_fld_rad_force
    public :: fld_radforce_get_dt
    ! these are made public for mod_usr purposes and diagnostics
    public :: fld_get_radflux
    public :: fld_get_fluxlimiter
    public :: fld_get_fluxlimiter_prim
    public :: fld_get_opacity_prim
  contains
 
  !> Reading in fld-list parameters from .par file
  subroutine fld_params_read(files)
    use mod_global_parameters, only: unitpar
    use mod_constants
    character(len=*), intent(in) :: files(:)
    integer                      :: n
 
    namelist /fld_list/ fld_kappa0, fld_radforce_split, &
    fld_bisect_tol, fld_diff_tol, fld_opacity_law, fld_fluxlimiter, &
    fld_interaction_method, fld_opal_table, nth_for_diff_mg, fld_debug, fld_no_mg
 
    do n = 1, size(files)
       open(unitpar, file=trim(files(n)), status="old")
       read(unitpar, fld_list, end=111)
       111    close(unitpar)
    end do
  end subroutine fld_params_read
 
  !> Initialising FLD-module
  !> Read opacities
  !> Initialise Multigrid and adimensionalise kappa
  subroutine fld_init(He_abundance, r_gamma)
    use mod_global_parameters
    use mod_variables
    use mod_physics
    use mod_opal_opacity, only: init_opal_table
    use mod_multigrid_coupling
 
    double precision, intent(in) :: he_abundance, r_gamma
    double precision :: sigma_thomson
 
    nth_for_diff_mg=1
    fld_debug=.false.
    fld_no_mg=.false.
    call fld_params_read(par_files)
    if(.not.fld_no_mg)then
      select case(nth_for_diff_mg)
        case(1)
         ! no need for stencil extension
        case(2)
         ! need for stencil extension
         phys_wider_stencil=1 
       case default
         call mpistop("nth_for_diff_mg must be 1 or 2")
       end select
       phys_implicit_update   => fld_implicit_update
       phys_evaluate_implicit => fld_evaluate_implicit
       phys_set_mg_bounds     => fld_set_mg_bounds
       ! store the diffusion coefficient as extra variable (needed in mg vhelmholtz)
       i_diff_mg = var_set_extravar("D", "D")
       use_multigrid = .true.
       ! use multigrid to solve a helmholtz equation with variable coefficient
       mg%n_extra_vars = 1
       mg%operator_type = mg_vhelmholtz
       mg%smoother_type = mg_smoother_gs
    endif
    !> set gamma
    fld_gamma = r_gamma
    !> Read in opacity table if necesary
    if(fld_opacity_law .eq. 'opal') call init_opal_table(fld_opal_table)
    if(fld_opacity_law .eq. 'thomson')  then
      ! special fixed value for thomson opacity, assuming cgs units
      sigma_thomson = 6.6524585d-25
      fld_kappa0 = sigma_thomson/const_mp * (1.+2.*he_abundance)/(1.+4.*he_abundance)
    endif
  end subroutine fld_init
 
  !> Set the boundaries for the diffusion of E
  subroutine fld_set_mg_bounds
    use mod_global_parameters
    use mod_multigrid_coupling
    use mod_usr_methods
 
    integer :: iB
 
    ! Set boundary conditions for the multigrid solver
    do ib = 1, 2*ndim
       select case (typeboundary(iw_r_e, ib))
       case (bc_symm)
          ! d/dx u = 0
          mg%bc(ib, mg_iphi)%bc_type = mg_bc_neumann
          mg%bc(ib, mg_iphi)%bc_value = 0.0_dp
       case (bc_asymm)
          ! u = 0
          mg%bc(ib, mg_iphi)%bc_type = mg_bc_dirichlet
          mg%bc(ib, mg_iphi)%bc_value = 0.0_dp
       case (bc_cont)
          ! d/dx u = 0
          mg%bc(ib, mg_iphi)%bc_type = mg_bc_neumann
          mg%bc(ib, mg_iphi)%bc_value = 0.0_dp
       case (bc_periodic)
          ! Nothing to do here
       case (bc_noinflow)
          if (.not. associated(usr_special_mg_bc)) then 
             call mpistop("special BC for MG not defined")
          else
             call usr_special_mg_bc(ib)
          endif
       case (bc_special)
          if (.not. associated(usr_special_mg_bc)) then 
             call mpistop("special BC for MG not defined")
          else
             call usr_special_mg_bc(ib)
          endif
       case default
          call mpistop("divE_multigrid warning: unknown b.c. ")
       end select
       ! Neumann on the diffusion coefficient
       ! d/dx u = 0
       mg%bc(ib, mg_iveps)%bc_type = mg_bc_neumann
       mg%bc(ib, mg_iveps)%bc_value = 0.0_dp
    end do
 
  end subroutine fld_set_mg_bounds
 
 
 
  !> w[iw]=w[iw]+qdt*S[wCT,qtC,x] where S is the source based on wCT within ixO
  !> This subroutine handles the radiation force and its work added explicitly
  !> and the energy interaction term combined with photon tiring using an implicit update
  subroutine add_fld_rad_force(qdt,ixI^L,ixO^L,wCT,wCTprim,w,x,qsourcesplit,active)
    use mod_constants
    use mod_global_parameters
    use mod_geometry
    use mod_physics, only: phys_get_rfactor
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(in)    :: qdt, x(ixi^s,1:ndim)
    double precision, intent(in)    :: wct(ixi^s,1:nw),wctprim(ixi^s,1:nw)
    double precision, intent(inout) :: w(ixi^s,1:nw)
    logical, intent(in) :: qsourcesplit
    logical, intent(inout) :: active
 
    integer :: idir,jdir,nth_for_fld,ix^d
    double precision :: sigma_b,cc
    double precision, dimension(ixI^S) :: a1,a2,a3,c0,c1,kappa
    double precision, dimension(ixI^S) :: e_gas,e_rad,tmp
    double precision, dimension(ixI^S,1:ndim,1:ndim) :: div_v,edd
 
    !> Calculate and add sourceterms
    if(qsourcesplit .eqv. fld_radforce_split) then
      active = .true.
      nth_for_fld=2
      ! store here lambda in a1 and fld_R in a2
      call fld_get_eddington(wctprim,x,ixi^l,ixo^l,edd,a1,a2,nth_for_fld)
      do idir = 1,ndim
        call gradient(wctprim(ixi^s,iw_r_e),ixi^l,ixo^l,idir,tmp,nth_for_fld)
        ! Radiation force = kappa*rho/c *Flux = lambda gradE
        ! recycle grad E to store -lambda (grad E)_i
        tmp(ixo^s) = -a1(ixo^s)*tmp(ixo^s)
        !> Momentum equation source term
        w(ixo^s,iw_mom(idir)) = w(ixo^s,iw_mom(idir))+ qdt*tmp(ixo^s)
        !> Energy equation source term 
        w(ixo^s,iw_e) = w(ixo^s,iw_e) + qdt*wctprim(ixo^s,iw_mom(idir))*tmp(ixo^s)
      enddo
 
      !> Photon tiring : calculate tensor grad v (named div_v here)
      ! NOTE: This is ok for uniform Cartesian only!!!!!
      do idir = 1,ndim
        do jdir = 1,ndim
          call gradient(wctprim(ixi^s,iw_mom(jdir)),ixi^l,ixo^l,idir,tmp)
          div_v(ixo^s,idir,jdir) = tmp(ixo^s)
        enddo
      enddo
      ! perform contraction fe : grad(v) with fe eddington tensor
      {^ifoned
      a3(ixo^s) = div_v(ixo^s,1,1)*edd(ixo^s,1,1)
      }
      {^iftwod
      a3(ixo^s) = div_v(ixo^s,1,1)*edd(ixo^s,1,1) &
                      + div_v(ixo^s,1,2)*edd(ixo^s,1,2) &
                      + div_v(ixo^s,2,1)*edd(ixo^s,2,1) &
                      + div_v(ixo^s,2,2)*edd(ixo^s,2,2)
      }
      {^ifthreed
      a3(ixo^s) = div_v(ixo^s,1,1)*edd(ixo^s,1,1) &
                      + div_v(ixo^s,1,2)*edd(ixo^s,1,2) &
                      + div_v(ixo^s,1,3)*edd(ixo^s,1,3) &
                      + div_v(ixo^s,2,1)*edd(ixo^s,2,1) &
                      + div_v(ixo^s,2,2)*edd(ixo^s,2,2) &
                      + div_v(ixo^s,2,3)*edd(ixo^s,2,3) &
                      + div_v(ixo^s,3,1)*edd(ixo^s,3,1) &
                      + div_v(ixo^s,3,2)*edd(ixo^s,3,2) &
                      + div_v(ixo^s,3,3)*edd(ixo^s,3,3)
      }
      call fld_get_opacity_prim(wctprim,x,ixi^l,ixo^l,kappa)
 
      cc = const_c/unit_velocity
      sigma_b = const_rad_a*cc/4.d0*(unit_temperature**4.d0)/(unit_pressure)
      !> e_gas is the INTERNAL ENERGY without KINETIC ENERGY
      e_gas(ixo^s) = w(ixo^s,iw_e)-half*sum(w(ixo^s,iw_mom(:))**2,dim=ndim+1)/w(ixo^s,iw_rho)
      if(allocated(iw_mag)) then
        e_gas(ixo^s) = e_gas(ixo^s)-half*sum(w(ixo^s,iw_mag(:))**2,dim=ndim+1)
      endif
      e_rad(ixo^s) = w(ixo^s,iw_r_e)
 
      if(fix_small_values)then
        {do ix^d = ixomin^d,ixomax^d\ }
          e_gas(ix^d) = max(e_gas(ix^d),small_e)
          e_rad(ix^d) = max(e_rad(ix^d),small_r_e)
        {enddo\}
      endif
 
      !> Coefficients for the polynomial in Moens et al. 2022, eq 37. but with photon tiring (a3)
      call phys_get_rfactor(wct,x,ixi^l,ixo^l,tmp)
      a1(ixo^s) = 4.d0*sigma_b*qdt*kappa(ixo^s)*(fld_gamma-one)**4/(wct(ixo^s,iw_rho)**3*tmp(ixo^s)**4)
      a2(ixo^s) = cc*kappa(ixo^s)*wct(ixo^s,iw_rho)*qdt
      a3(ixo^s) = a3(ixo^s)*qdt
 
      c0(ixo^s) = ((one+a2(ixo^s)+a3(ixo^s))*e_gas(ixo^s)+a2(ixo^s)*e_rad(ixo^s))/a1(ixo^s)/(one+a3(ixo^s))
      c1(ixo^s) = (one+a2(ixo^s)+a3(ixo^s))/a1(ixo^s)/(one+a3(ixo^s))
 
      !> Loop over every cell for rootfinding method
      {do ix^d = ixomin^d,ixomax^d\}
        select case(fld_interaction_method)
        case('Bisect')
        call bisection_method(e_gas(ix^d),e_rad(ix^d),c0(ix^d),c1(ix^d))
        case('Newton')
        call newton_method(e_gas(ix^d),e_rad(ix^d),c0(ix^d),c1(ix^d))
        case('Halley')
        call halley_method(e_gas(ix^d),e_rad(ix^d),c0(ix^d),c1(ix^d))
        case default
        call mpistop('root-method not known')
        end select 
      {enddo\}
 
      e_rad(ixo^s) = (a1(ixo^s)*e_gas(ixo^s)**4.d0+e_rad(ixo^s))/(one+a2(ixo^s)+a3(ixo^s))
 
      if(fix_small_values)then
        {do ix^d = ixomin^d,ixomax^d\ }
          e_gas(ix^d) = max(e_gas(ix^d),small_e)
          e_rad(ix^d) = max(e_rad(ix^d),small_r_e)
        {enddo\}
      endif
 
      !> Update gas-energy in w, internal + kinetic
      w(ixo^s,iw_e) = e_gas(ixo^s)
      w(ixo^s,iw_e) = w(ixo^s,iw_e)+half*sum(w(ixo^s,iw_mom(:))**2,dim=ndim+1)/w(ixo^s,iw_rho)
      if(allocated(iw_mag)) then
        w(ixo^s,iw_e) = w(ixo^s,iw_e)+half*sum(w(ixo^s,iw_mag(:))**2,dim=ndim+1)
      endif
      !> Update rad-energy in w
      w(ixo^s,iw_r_e) = e_rad(ixo^s)
    end if
  end subroutine add_fld_rad_force
 
  !> get dt limit for radiation force and FLD explicit source additions
  !> NOTE: w is primitive on entry
  subroutine fld_radforce_get_dt(w,ixI^L,ixO^L,dtnew,dx^D,x)
    use mod_global_parameters
    use mod_usr_methods
    use mod_geometry
    use mod_physics, only: phys_get_csrad2
 
    integer, intent(in)             :: ixi^l, ixo^l
    double precision, intent(in)    :: dx^d, x(ixi^s,1:ndim), w(ixi^s,1:nw)
    double precision, intent(inout) :: dtnew
 
    integer          :: idim,idims,nth_for_fld
    double precision :: dxinv(1:ndim), max_grav
    double precision :: lambda(ixi^s),fld_r(ixi^s)
    double precision :: tmp(ixi^s)
    double precision :: cmax(ixi^s),cmaxtot(ixi^s),courantmaxtots
 
    if(fld_debug)print *,'DT limit on entry to radforce_get_dt=',dtnew
    nth_for_fld=2
    call fld_get_fluxlimiter_prim(w,x,ixi^l,ixo^l,lambda,fld_r,nth_for_fld)
    if(slab_uniform) then
      ^d&dxinv(^d)=one/dx^d;
      do idim = 1, ndim
        call gradient(w(ixi^s,iw_r_e),ixi^l,ixo^l,idim,tmp,nth_for_fld)
        max_grav = maxval(dabs(-lambda(ixo^s)*tmp(ixo^s)/w(ixo^s,iw_rho)))
        max_grav = max(max_grav, epsilon(1.0d0))
        dtnew = min(dtnew, 1.0d0 / dsqrt(max_grav * dxinv(idim)))
      end do
    else
      do idim = 1, ndim
        call gradient(w(ixi^s,iw_r_e),ixi^l,ixo^l,idim,tmp,nth_for_fld)
        max_grav = maxval(dabs(-lambda(ixo^s)*tmp(ixo^s)/w(ixo^s,iw_rho))/block%ds(ixo^s,idim))
        max_grav = max(max_grav, epsilon(1.0d0))
        dtnew = min(dtnew, 1.0d0 / dsqrt(max_grav))
      end do
    endif
 
    if(fld_debug)print *,'DT limit after RADFORCE eff grav=',dtnew
 
    ! here we interface back to fld_get_radpress
    call phys_get_csrad2(w,x,ixi^l,ixo^l,tmp)
    if(slab_uniform) then
       ^d&dxinv(^d)=one/dx^d;
       do idims=1,ndim
          cmax(ixo^s)=dabs(w(ixo^s,iw_mom(idims)))+dsqrt(tmp(ixo^s))
          if(idims==1) then
            cmaxtot(ixo^s)=cmax(ixo^s)*dxinv(idims)
          else
            cmaxtot(ixo^s)=cmaxtot(ixo^s)+cmax(ixo^s)*dxinv(idims)
          end if
       end do
    else
       do idims=1,ndim
          cmax(ixo^s)=dabs(w(ixo^s,iw_mom(idims)))+dsqrt(tmp(ixo^s))
          if(idims==1) then
            cmaxtot(ixo^s)=cmax(ixo^s)/block%ds(ixo^s,idims)
          else
            cmaxtot(ixo^s)=cmaxtot(ixo^s)+cmax(ixo^s)/block%ds(ixo^s,idims)
          end if
       end do
    end if
    ! courantmaxtots='max(summed c/dx)'
    courantmaxtots=maxval(cmaxtot(ixo^s))
    if(courantmaxtots>smalldouble) dtnew=min(dtnew,courantpar/courantmaxtots)
    if(fld_debug)print *,'DT limit RADFORCE CSRAD=',dtnew
 
  end subroutine fld_radforce_get_dt
 
  !> Sets the opacity in the w-array
  !> by calling mod_opal_opacity
  !> NOTE: assumes primitives in w
  !> NOTE: assuming opacity is local, not ok with cak line force
  subroutine fld_get_opacity_prim(w, x, ixI^L, ixO^L, fld_kappa)
    use mod_global_parameters
    use mod_physics, only: phys_get_tgas
    use mod_usr_methods
    use mod_opal_opacity
    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) :: fld_kappa(ixi^s)
 
    integer :: ix^d
    double precision :: rho0,temp0,n
    double precision :: temp(ixi^s)
 
    select case (fld_opacity_law)
      case('const','thomson')
        fld_kappa(ixo^s) = fld_kappa0/unit_opacity
      case('opal')
        call phys_get_tgas(w,x,ixi^l,ixo^l,temp)
        {do ix^d=ixomin^d,ixomax^d\ }
          rho0 = w(ix^d,iw_rho)*unit_density
          temp0 = temp(ix^d)*unit_temperature
          call set_opal_opacity(rho0,temp0,n)
          fld_kappa(ix^d) = n/unit_opacity
        {enddo\ }
      case('special')
        if (.not. associated(usr_special_opacity)) then
          call mpistop("special opacity not defined")
        endif
        call usr_special_opacity(ixi^l, ixo^l, w, x, fld_kappa)
      case default
        call mpistop("Doesn't know opacity law")
      end select
  end subroutine fld_get_opacity_prim
 
  !> Returns Radiation Pressure as tensor
  !> NOTE: w is primitive on entry
  subroutine fld_get_radpress(w, x, ixI^L, ixO^L, rad_pressure)
    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):: rad_pressure(ixi^s,1:ndim,1:ndim)
    integer :: i,j,nth
    double precision             :: eddington_tensor(ixi^s,1:ndim,1:ndim)
    double precision             :: lambda(ixi^s),fld_r(ixi^s)
 
    nth=2
    call fld_get_eddington(w, x, ixi^l, ixo^l, eddington_tensor, lambda, fld_r, nth)
    if(fld_debug)then
       print *,'In get_radPress with nth=',nth,' on ixO=',ixo^l
       print *,'Max and Min value of fe'
       print *,maxval(eddington_tensor(ixo^s,1:ndim,1:ndim))
       print *,minval(eddington_tensor(ixo^s,1:ndim,1:ndim))
       print *,'Max and Min value of Erad'
       print *,maxval(w(ixo^s,iw_r_e))
       print *,minval(w(ixo^s,iw_r_e))
       print *,'End get_radPress'
    endif
    do i=1,ndim
      do j=1,ndim
        rad_pressure(ixo^s,i,j) = eddington_tensor(ixo^s,i,j)*w(ixo^s,iw_r_e)
      enddo
    enddo
  end subroutine fld_get_radpress
 
  !> This subroutine calculates flux limiter lambda according to fld_fluxlimiter
  !> It also calculates fld_R which is ratio of radiation scaleheight and mean free path
  !> NOTE: nth and ixI and ixO not free to choose here: TODO
  subroutine fld_get_fluxlimiter(w,x,ixI^L,ixO^L,fld_lambda,fld_R,nth)
    use mod_global_parameters
    use mod_geometry
    use mod_usr_methods
    use mod_physics, only: phys_to_primitive
    integer, intent(in)           :: ixi^l,ixo^l,nth
    double precision, intent(in)  :: w(ixi^s,1:nw)
    double precision, intent(in)  :: x(ixi^s,1:ndim)
    double precision, intent(out) :: fld_r(ixi^s),fld_lambda(ixi^s)
 
    double precision :: wprim(ixi^s,1:nw)
 
    wprim(ixi^s,1:nw)=w(ixi^s,1:nw)
    call phys_to_primitive(ixi^l,ixi^l,wprim,x)
    call fld_get_fluxlimiter_prim(wprim,x,ixi^l,ixo^l,fld_lambda,fld_r,nth)
 
  end subroutine fld_get_fluxlimiter
 
  !> This subroutine calculates flux limiter lambda according to fld_fluxlimiter
  !> It also calculates fld_R which is ratio of radiation scaleheight and mean free path
  !> NOTE: this one operates on primitives
  !> NOTE: nth and ixI and ixO not free to choose 
  subroutine fld_get_fluxlimiter_prim(w,x,ixI^L,ixO^L,fld_lambda,fld_R,nth)
    use mod_global_parameters
    use mod_geometry
    use mod_usr_methods
    integer, intent(in)           :: ixi^l,ixo^l,nth
    double precision, intent(in)  :: w(ixi^s,1:nw)
    double precision, intent(in)  :: x(ixi^s,1:ndim)
    double precision, intent(out) :: fld_r(ixi^s),fld_lambda(ixi^s)
 
    integer :: idir, ix^d
    double precision :: kappa(ixi^s),normgrad2(ixi^s)
    double precision :: grad_r_e(ixi^s)
 
    select case(fld_fluxlimiter)
    case('Diffusion')
      ! optically thick limit
      fld_lambda(ixo^s) = 1.d0/3.d0
      fld_r(ixo^s) = zero
    case('FreeStream')
      ! optically thin limit
      normgrad2(ixo^s) = zero
      do idir=1,ndim
        call gradient(w(ixi^s,iw_r_e),ixi^l,ixo^l,idir,grad_r_e,nth)
        normgrad2(ixo^s) = normgrad2(ixo^s)+grad_r_e(ixo^s)**2
      end do
      call fld_get_opacity_prim(w,x,ixi^l,ixo^l,kappa)
      ! Calculate R everywhere
      ! |grad E|/(rho kappa E)
      fld_r(ixo^s) = dsqrt(normgrad2(ixo^s))/(kappa(ixo^s)*w(ixo^s,iw_rho)*w(ixo^s,iw_r_e))
      where(normgrad2(ixo^s)<smalldouble**2)
        ! treat uniform case as diffusion limit
        fld_r(ixo^s)=zero
        fld_lambda(ixo^s) = 1.0d0/3.0d0
      elsewhere
        fld_lambda(ixo^s) = one/fld_r(ixo^s)
      endwhere
    case('Pomraning')
      ! Calculate R everywhere
      ! |grad E|/(rho kappa E)
      normgrad2(ixo^s) = zero
      do idir = 1,ndim
        call gradient(w(ixi^s,iw_r_e),ixi^l,ixo^l,idir,grad_r_e,nth)
        normgrad2(ixo^s) = normgrad2(ixo^s) + grad_r_e(ixo^s)**2
      end do
      call fld_get_opacity_prim(w,x,ixi^l,ixo^l,kappa)
      fld_r(ixo^s) = dsqrt(normgrad2(ixo^s))/(kappa(ixo^s)*w(ixo^s,iw_rho)*w(ixo^s,iw_r_e))
      ! Calculate the flux limiter, lambda
      ! Levermore and Pomraning: lambda = (2 + R)/(6 + 3R + R^2)
      fld_lambda(ixo^s) = (2.d0+fld_r(ixo^s))/(6.d0+3*fld_r(ixo^s)+fld_r(ixo^s)**2)
    case('Minerbo')
      ! Calculate R everywhere
      ! |grad E|/(rho kappa E)
      normgrad2(ixo^s) = zero
      do idir = 1,ndim
        call gradient(w(ixi^s,iw_r_e),ixi^l,ixo^l,idir,grad_r_e,nth)
        normgrad2(ixo^s) = normgrad2(ixo^s) + grad_r_e(ixo^s)**2
      end do
      call fld_get_opacity_prim(w, x, ixi^l, ixo^l, kappa)
      fld_r(ixo^s) = dsqrt(normgrad2(ixo^s))/(kappa(ixo^s)*w(ixo^s,iw_rho)*w(ixo^s,iw_r_e))
      ! Calculate the flux limiter, lambda
      ! Minerbo:
      {do ix^d = ixomin^d,ixomax^d\ }
        if(fld_r(ix^d) .lt. 3.d0/2.d0) then
          fld_lambda(ix^d) = 2.d0/(3.d0+dsqrt(9.d0+12.d0*fld_r(ix^d)**2))
        else
          fld_lambda(ix^d) = 1.d0/(1.d0+fld_r(ix^d)+dsqrt(1.d0+2.d0*fld_r(ix^d)))
        endif
      {enddo\}
    case('special')
      if (.not. associated(usr_special_fluxlimiter)) then
        call mpistop("special fluxlimiter not defined")
      endif
      call usr_special_fluxlimiter(ixi^l,ixo^l,w,x,fld_lambda,fld_r)
    case default
      call mpistop('Fluxlimiter unknown')
    end select
 
  end subroutine fld_get_fluxlimiter_prim
 
  !> Calculate Radiation Flux (use of cgs units)
  !> NOTE: only for diagnostics purposes (w conservative on entry)
  !> This returns cell centered values for radiation flux 
  subroutine fld_get_radflux(w, x, ixI^L, ixO^L, rad_flux)
    use mod_global_parameters
    use mod_geometry
    use mod_physics, only: phys_to_primitive
    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) :: rad_flux(ixi^s, 1:ndim)
 
    integer :: idir,nth_for_fld
    double precision :: cc
    double precision :: wprim(ixi^s,1:nw)
    double precision :: grad_r_e(ixi^s)
    double precision :: kappa(ixi^s), lambda(ixi^s), fld_r(ixi^s)
 
    wprim(ixi^s,1:nw)=w(ixi^s,1:nw)
    call phys_to_primitive(ixi^l,ixi^l,wprim,x)
 
    cc = const_c/unit_velocity
    call fld_get_opacity_prim(wprim, x, ixi^l, ixo^l, kappa)
    nth_for_fld=2
    call fld_get_fluxlimiter_prim(wprim, x, ixi^l, ixo^l, lambda, fld_r, nth_for_fld)
    !> Calculate the Flux using the fld closure relation
    !> F = -c*lambda/(kappa*rho) *grad E
    do idir = 1,ndim
      call gradient(wprim(ixi^s,iw_r_e),ixi^l,ixo^l,idir,grad_r_e,nth_for_fld)
      rad_flux(ixo^s, idir) = -cc*lambda(ixo^s)/(kappa(ixo^s)*wprim(ixo^s,iw_rho))*grad_r_e(ixo^s)
    end do
  end subroutine fld_get_radflux
 
  !> Calculate Eddington-tensor (where w is primitive)
  !> also feeds back the flux limiter lambda and R
  subroutine fld_get_eddington(w, x, ixI^L, ixO^L, eddington_tensor, lambda, fld_R, nth)
    use mod_global_parameters
    use mod_geometry
    integer, intent(in)          :: ixI^L, ixO^L, nth
    double precision, intent(in) :: w(ixI^S, 1:nw)
    double precision, intent(in) :: x(ixI^S, 1:ndim)
    double precision, intent(out) :: eddington_tensor(ixI^S,1:ndim,1:ndim)
    double precision, intent(out) :: lambda(ixI^S),fld_R(ixI^S)
 
    integer :: idir,jdir
    double precision :: normgrad2(ixI^S)
    double precision :: tmp(ixI^S),grad_r_e(ixI^S,1:ndim)
    double precision :: nn_regularized(ixI^S,1:ndim,1:ndim)
 
    normgrad2(ixo^s) = zero
    do idir = 1,ndim
      call gradient(w(ixi^s, iw_r_e),ixi^l,ixo^l,idir,tmp,nth)
      grad_r_e(ixo^s,idir)=tmp(ixo^s)
      normgrad2(ixo^s)=normgrad2(ixo^s)+tmp(ixo^s)**2
    end do
    do idir = 1,ndim
      do jdir = 1,ndim
       if(idir==jdir)then
          nn_regularized(ixo^s,idir,jdir)=(grad_r_e(ixo^s,idir)*grad_r_e(ixo^s,jdir)+smalldouble**2)/(normgrad2(ixo^s)+smalldouble**2)
       else
          nn_regularized(ixo^s,idir,jdir)=(grad_r_e(ixo^s,idir)*grad_r_e(ixo^s,jdir))/(normgrad2(ixo^s)+smalldouble**2)
       endif
      enddo
    enddo
    ! get lambda and R  
    call fld_get_fluxlimiter_prim(w,x,ixi^l,ixo^l,lambda,fld_r,nth)
    ! store f_e= lambda + lambda^2 R^2
    tmp(ixo^s) = lambda(ixo^s)+(lambda(ixo^s)*fld_r(ixo^s))**2
    do idir = 1,ndim
      ! first compute the isotropic (diagonal) part
      eddington_tensor(ixo^s,idir,idir) = half*(one-tmp(ixo^s))
    enddo
    do idir = 1,ndim
      do jdir = 1,ndim
        ! initialize off-diagonal part here
        if(idir .ne. jdir) eddington_tensor(ixo^s,idir,jdir) = zero
        ! add part depending on unit vectors along gradient E
        eddington_tensor(ixo^s,idir,jdir) = eddington_tensor(ixo^s,idir,jdir)+&
            half*(3.d0*tmp(ixo^s)-one)*nn_regularized(ixo^s,idir,jdir)
      enddo
    enddo
  end subroutine fld_get_eddington
 
  !> Calling all subroutines to perform the multigrid method
  !> Communicates rad_e and diff_coeff to multigrid library
  !> Advance psa=psb+dtfactor*qdt*F_im(psa)
  subroutine fld_implicit_update(dtfactor,qdt,qtC,psa,psb)
    use mod_global_parameters
    use mod_forest
    use mod_multigrid_coupling
    type(state), target :: psa(max_blocks)
    type(state), target :: psb(max_blocks)
    double precision, intent(in) :: qdt
    double precision, intent(in) :: qtC
    double precision, intent(in) :: dtfactor
 
    integer, parameter           :: max_its = 100
    integer                      :: n,ixO^L,ix^D
    double precision             :: res, max_residual, lambda, fac
    integer :: iigrid, igrid
 
    ! Avoid setting a very restrictive limit to residual when time step small
    if(qdt < dtmin) then
      if(mype==0)then
          print *,'skipping implicit solve: dt too small!'
          print *,'Currently at time=',global_time,' time step=',qdt,' dtmin=',dtmin
      endif
      return
    endif
    max_residual = fld_diff_tol
 
    call mg_set_methods(mg)
    if(.not. mg%is_allocated) call mpistop("multigrid tree not allocated yet")
 
    ! Here we handle the global helmholtz problem with variable coefficient
    ! The equation we solve is div(D nabla Erad^(n+1)) -(1/dt)Erad^(n+1)=-(1/dt)Erad^n
    ! Helmholtz equation is div(eps nabla phi) -lambda phi = f
    !    hence eps is our variable coefficient D=fld_lambda*c/(kappa*rho)
    !    hence phi is Erad and lambda=1/dt
    lambda = 1.d0/(dtfactor *qdt)
    fac = 1.d0
    call vhelmholtz_set_lambda(lambda)
    call update_diffcoeff(psa)
    ! copy in the (variable) diffusion coefficient in mg_iveps
    call mg_copy_to_tree(i_diff_mg, mg_iveps, factor=fac, state_from=psa)
    ! copy in the Erad variable in mg_iphi (the one we solve for)
    call mg_copy_to_tree(iw_r_e, mg_iphi, factor=fac, state_from=psa)
    ! copy in RHS f factor as Erad with factor -(1/dt)
    call mg_copy_to_tree(iw_r_e, mg_irhs, factor=-lambda, state_from=psb)
    if(time_advance)then
       call mg_restrict(mg, mg_iveps)
       call mg_fill_ghost_cells(mg, mg_iveps)
    endif
    call mg_fas_fmg(mg, .true., max_res=res)
    do n = 1, max_its
      if(res < max_residual) exit
      call mg_fas_vcycle(mg, max_res=res)
    end do
    if((res .lt. 0.d0) .or. (res .ge. max_residual)) then
      if (mg%my_rank == 0) then 
        write(*,*) it, ' residual from MG ', res
        write(*,*) it, ' max_residual in MG ', max_residual
        write(*,*) it, ' qdt in MG ', qdt, ' versus dtmin=',dtmin
        write(*,*) it, ' dtfactor*qdt in MG ', qdt*dtfactor
      endif
      call mpistop("no convergence in MG")
    end if
    if(res .eq. 0.d0) then
      if (mg%my_rank == 0) write(*,*) it, 'ZERO  residual from MG ', res
    endif
    ! copy back the Erad variable in iw_r_e
    call mg_copy_from_tree_gc(mg_iphi, iw_r_e, state_to=psa)
 
    if(fix_small_values)then
       ixo^l=ixm^ll;
       do iigrid=1,igridstail; igrid=igrids(iigrid);
         {do ix^d = ixomin^d,ixomax^d\ }
           psa(igrid)%w(ix^d,iw_r_e)= max(psa(igrid)%w(ix^d,iw_r_e),small_r_e)
         {enddo\}
       end do
    endif
 
  end subroutine fld_implicit_update
 
  subroutine update_diffcoeff(psa)
    use mod_global_parameters
    type(state), target :: psa(max_blocks)
 
    integer :: iigrid, igrid, ixO^L
 
    ! we will need diffusion coefficients in i-1 i i+1
    ixo^l=ixm^ll^ladd1;
    !$OMP PARALLEL DO PRIVATE(igrid)
    do iigrid=1,igridstail; igrid=igrids(iigrid);
        call fld_get_diffcoef_central(psa(igrid)%w, psa(igrid)%x, ixg^ll, ixo^l)
    end do
    !$OMP END PARALLEL DO
 
  end subroutine update_diffcoeff
 
  !> inplace update of psa==>F_im(psa)
  subroutine fld_evaluate_implicit(qtC,psa)
    use mod_global_parameters
    type(state), target :: psa(max_blocks)
    double precision, intent(in) :: qtC
    integer :: iigrid, igrid
    integer :: ixO^L
 
    call update_diffcoeff(psa)
 
    ixo^l=ixm^ll;
    !$OMP PARALLEL DO PRIVATE(igrid)
    do iigrid=1,igridstail; igrid=igrids(iigrid);
       ^d&dxlevel(^d)=rnode(rpdx^d_,igrid);
       call evaluate_diffterm_onegrid(ixg^ll,ixo^l,psa(igrid)%w)
    end do
    !$OMP END PARALLEL DO
 
  end subroutine fld_evaluate_implicit
 
  !> inplace update of psa==>F_im(psa)
  subroutine evaluate_diffterm_onegrid(ixI^L,ixO^L,w)
    use mod_global_parameters
    integer, intent(in)             :: ixI^L, ixO^L
    double precision, intent(inout) :: w(ixI^S, 1:nw)
 
    double precision :: divF(ixI^S)
    integer :: idir, jxO^L, hxO^L
 
    if(.not.slab)call mpistop("laplacian coded up for uniform cartesian grid")
 
    ! Here we use diffusion coefficients in positions i-1 i i+1 and exploit harmonic means i.e. 2ab/(a+b)
    ! since this is how the multigrid library handles the div(eps nabla phi) term in Helmholtz equation
    !   div(eps nabla phi) - lambda phi = f
    divf(ixo^s) = 0.d0
    do idir = 1,ndim
       hxo^l=ixo^l-kr(idir,^d);
       jxo^l=ixo^l+kr(idir,^d);
       divf(ixo^s) = divf(ixo^s) + &
           (w(jxo^s,iw_r_e)*two*w(ixo^s,i_diff_mg)*w(jxo^s,i_diff_mg)/(w(ixo^s,i_diff_mg) + w(jxo^s,i_diff_mg)) &
          -w(ixo^s,iw_r_e)*(two*w(ixo^s,i_diff_mg)*w(jxo^s,i_diff_mg)/(w(ixo^s,i_diff_mg) + w(jxo^s,i_diff_mg)) &
                           +two*w(ixo^s,i_diff_mg)*w(hxo^s,i_diff_mg)/(w(ixo^s,i_diff_mg) + w(hxo^s,i_diff_mg))) &
           +w(hxo^s,iw_r_e)*two*w(ixo^s,i_diff_mg)*w(hxo^s,i_diff_mg)/(w(ixo^s,i_diff_mg) + w(hxo^s,i_diff_mg)))/dxlevel(idir)**2
       ! below uses artihmetic mean, different from mg method
       !divF(ixO^S) = divF(ixO^S) + &
       !    (w(jxO^S,iw_r_e)*half*(w(ixO^S,i_diff_mg) + w(jxO^S,i_diff_mg)) &
       !   -w(ixO^S,iw_r_e)*(half*(w(ixO^S,i_diff_mg) + w(jxO^S,i_diff_mg)) &
       !                    +half*(w(ixO^S,i_diff_mg) + w(hxO^S,i_diff_mg))) &
       !    +w(hxO^S,iw_r_e)*half*(w(ixO^S,i_diff_mg) + w(hxO^S,i_diff_mg)))/dxlevel(idir)**2
    enddo
    w(ixo^s,iw_r_e) = divf(ixo^s)
 
  end subroutine evaluate_diffterm_onegrid
 
  !> Calculates cell-centered diffusion coefficient to be used in multigrid
  subroutine fld_get_diffcoef_central(w, x, ixI^L, ixO^L)
    use mod_global_parameters
    use mod_geometry
    use mod_usr_methods
    use mod_physics, only: phys_to_primitive
    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 :: cc
    double precision :: wprim(ixi^s,1:nw)
    double precision :: kappa(ixi^s),lambda(ixi^s),fld_r(ixi^s)
 
    cc = const_c/unit_velocity
    wprim(ixi^s,1:nw)=w(ixi^s,1:nw)
    ! ensure entries in entire ixI range
    call phys_to_primitive(ixi^l,ixi^l,wprim,x)
    call fld_get_opacity_prim(wprim, x, ixi^l, ixo^l, kappa)
    ! note that we use central difference here (last argument is 1 or 2)
    call fld_get_fluxlimiter_prim(wprim, x, ixi^l, ixo^l, lambda, fld_r, nth_for_diff_mg)
    w(ixo^s,i_diff_mg) = cc*lambda(ixo^s)/(kappa(ixo^s)*wprim(ixo^s,iw_rho))
    if(associated(usr_special_diffcoef)) call usr_special_diffcoef(w, wprim, x, ixi^l, ixo^l)
    if(minval(w(ixo^s,i_diff_mg))<smalldouble) then
        print *,'min diffcoef=',minval(w(ixo^s,i_diff_mg))
        call mpistop("too small diffusion coefficient")
    endif
    if(maxval(w(ixo^s,i_diff_mg))>bigdouble)  call mpistop("too large diffusion coefficient")
 
    if(fld_debug)then
      print *,'setting diffcoefs with data on',ixi^l
      print *,'min diffcoef=',minval(w(ixo^s,i_diff_mg))
      print *,'min lambda kappa rho fld_R'
      print *,minval(lambda(ixo^s))
      print *,minval(kappa(ixo^s))
      print *,minval(wprim(ixo^s,iw_rho))
      print *,minval(fld_r(ixo^s))
      print *,'max diffcoef=',maxval(w(ixo^s,i_diff_mg))
      print *,'max lambda kappa rho fld_R'
      print *,maxval(lambda(ixo^s))
      print *,maxval(kappa(ixo^s))
      print *,maxval(wprim(ixo^s,iw_rho))
      print *,maxval(fld_r(ixo^s))
      print *,'done setting diffcoefs in slot',i_diff_mg,' on range',ixo^l
    endif
 
  end subroutine fld_get_diffcoef_central
 
 
  !> Find the root of the 4th degree polynomial using the bisection method
  subroutine bisection_method(e_gas, E_rad, c0, c1)
    use mod_global_parameters
    double precision, intent(in)    :: c0, c1
    double precision, intent(in)    :: E_rad
    double precision, intent(inout) :: e_gas
    double precision :: bisect_a, bisect_b, bisect_c
    integer :: n, max_its
 
    n = 0
    max_its = 100
    bisect_a = zero
    bisect_b = min(dabs(c0/c1),dabs(c0)**(1.d0/4.d0))+smalldouble
    do while(dabs(bisect_b-bisect_a) .ge. fld_bisect_tol*min(e_gas,e_rad))
      bisect_c = (bisect_a + bisect_b)/two
      n = n +1
      if(n .gt. max_its) then
        call mpistop('No convergece in bisection scheme')
      endif
      if(polynomial_bisection(bisect_a, c0, c1)*&
      polynomial_bisection(bisect_b, c0, c1) .lt. zero) then
        if(polynomial_bisection(bisect_a, c0, c1)*&
        polynomial_bisection(bisect_c, c0, c1) .lt. zero) then
          bisect_b = bisect_c
        elseif(polynomial_bisection(bisect_b, c0, c1)*&
        polynomial_bisection(bisect_c, c0, c1) .lt. zero) then
          bisect_a = bisect_c
        elseif(polynomial_bisection(bisect_a, c0, c1) .eq. zero) then
          bisect_b = bisect_a
          bisect_c = bisect_a
          goto 2435
        elseif(polynomial_bisection(bisect_b, c0, c1) .eq. zero) then
          bisect_a = bisect_b
          bisect_c = bisect_b
          goto 2435
        elseif(polynomial_bisection(bisect_c, c0, c1) .eq. zero) then
          bisect_a = bisect_c
          bisect_b = bisect_c
          goto 2435
        else
          call mpistop("Problem with fld bisection method")
        endif
      elseif(polynomial_bisection(bisect_a, c0, c1) &
        - polynomial_bisection(bisect_b, c0, c1) .lt. fld_bisect_tol*polynomial_bisection(bisect_a, c0, c1)) then
        goto 2435
      else
        bisect_a = e_gas
        bisect_b = e_gas
        if(fld_debug)print*, "IGNORING GAS-RAD ENERGY EXCHANGE ", c0, c1
        if(fld_debug)print*, polynomial_bisection(bisect_a, c0, c1), polynomial_bisection(bisect_b, c0, c1)
        call mpistop('issues in bisection scheme')
        if(polynomial_bisection(bisect_a, c0, c1) .le. smalldouble) then
          bisect_b = bisect_a
        elseif(polynomial_bisection(bisect_a, c0, c1) .le. smalldouble) then
          bisect_a = bisect_b
        endif
        goto 2435
      endif
    enddo
      2435 e_gas = (bisect_a + bisect_b)/two
  end subroutine bisection_method
 
  !> Find the root of the 4th degree polynomial using the Newton method
  subroutine newton_method(e_gas, E_rad, c0, c1)
    use mod_global_parameters
    double precision, intent(in)    :: c0, c1
    double precision, intent(in)    :: E_rad
    double precision, intent(inout) :: e_gas
    double precision :: xval, yval, der, deltax
    integer :: ii
 
    yval = bigdouble
    xval = e_gas
    der = one
    deltax = one
    ii = 0
    !> Compare error with dx = dx/dy dy
    do while(dabs(deltax) .gt. fld_bisect_tol)
      yval = polynomial_bisection(xval, c0, c1)
      der  = dpolynomial_bisection(xval, c0, c1)
      deltax = -yval/der
      xval = xval + deltax
      ii = ii + 1
      if(ii .gt. 1d3) then
        if(fld_debug)print*, 'skip to bisection algorithm'
        call bisection_method(e_gas, e_rad, c0, c1)
        return
      endif
    enddo
    e_gas = xval
  end subroutine newton_method
 
  !> Find the root of the 4th degree polynomial using the Halley method
  subroutine halley_method(e_gas, E_rad, c0, c1)
    use mod_global_parameters
    double precision, intent(in)    :: c0, c1
    double precision, intent(in)    :: E_rad
    double precision, intent(inout) :: e_gas
    double precision :: xval, yval, der, dder, deltax
    integer :: ii
 
    yval = bigdouble
    xval = e_gas
    der = one
    dder = one
    deltax = one
    ii = 0
    !> Compare error with dx = dx/dy dy
    do while (dabs(deltax) .gt. fld_bisect_tol)
      yval = polynomial_bisection(xval, c0, c1)
      der  = dpolynomial_bisection(xval, c0, c1)
      dder = ddpolynomial_bisection(xval, c0, c1)
      deltax = -two*yval*der/(two*der**2 - yval*dder)
      xval = xval + deltax
      ii = ii + 1
      if(ii .gt. 1d3) then
        if(fld_debug)print*, 'skip to Newton algorithm'
        !call mpistop("iterates to 1000, entering Newton method")
        call newton_method(e_gas, e_rad, c0, c1)
        return
      endif
    enddo
    e_gas = xval
  end subroutine halley_method
 
  !> Evaluate polynomial at argument e_gas
  function polynomial_bisection(e_gas, c0, c1) result(val)
    use mod_global_parameters
    double precision, intent(in) :: e_gas
    double precision, intent(in) :: c0, c1
    double precision :: val
 
    val = e_gas**4.d0 + c1*e_gas - c0
  end function polynomial_bisection
 
  !> Evaluate first derivative of polynomial at argument e_gas
  function dpolynomial_bisection(e_gas, c0, c1) result(der)
    use mod_global_parameters
    double precision, intent(in) :: e_gas
    double precision, intent(in) :: c0, c1
    double precision :: der
 
    der = 4.d0*e_gas**3.d0 + c1
  end function dpolynomial_bisection
 
  !> Evaluate second derivative of polynomial at argument e_gas
  function ddpolynomial_bisection(e_gas, c0, c1) result(dder)
    use mod_global_parameters
    double precision, intent(in) :: e_gas
    double precision, intent(in) :: c0, c1
    double precision :: dder
 
    dder = 4.d0*3.d0*e_gas**2.d0
  end function ddpolynomial_bisection
end module mod_fld