MPI-AMRVAC  3.1
The MPI - Adaptive Mesh Refinement - Versatile Advection Code (development version)
mod_twofl_phys.t
Go to the documentation of this file.
1 !> Magneto-hydrodynamics module
3 
4 #include "amrvac.h"
5 
6  use mod_physics
7  use mod_global_parameters, only: std_len
12  use mod_comm_lib, only: mpistop
13 
14  implicit none
15  private
16  !! E_c = E_kin + E_mag + E_int
17  !! E_n = E_kin + E_int
18  integer, public, parameter :: eq_energy_tot=2
19  !! E_c = E_int
20  !! E_n = E_int
21  integer, public, parameter :: eq_energy_int=1
22  !! E_n, E_c are calculated from density as c_adiab rho^gamma
23  !! No energy equation => no variable assigned for it
24  integer, public, parameter :: eq_energy_none=0
25  !! E_c = E_kin + E_int
26  !! E_n = E_kin + E_int
27  integer, public, parameter :: eq_energy_ki=3
28 
29  integer, public, protected :: twofl_eq_energy = eq_energy_tot
30 
31  !> Whether hyperdiffusivity is used
32  logical, public, protected :: twofl_hyperdiffusivity = .false.
33  logical, public, protected :: twofl_dump_hyperdiffusivity_coef = .false.
34  double precision, public, protected, allocatable :: c_shk(:)
35  double precision, public, protected, allocatable :: c_hyp(:)
36 
37  !> Whether thermal conduction is used
38  logical, public, protected :: twofl_thermal_conduction_c = .false.
39  !> type of TC used: 1: adapted module (mhd implementation), 2: adapted module (hd implementation)
40  integer, parameter, private :: mhd_tc =1
41  integer, parameter, private :: hd_tc =2
42  integer, protected :: use_twofl_tc_c = mhd_tc
43 
44  !> Whether radiative cooling is added
45  logical, public, protected :: twofl_radiative_cooling_c = .false.
46  type(rc_fluid), public, allocatable :: rc_fl_c
47 
48  !> Whether viscosity is added
49  logical, public, protected :: twofl_viscosity = .false.
50 
51  !> Whether gravity is added: common flag for charges and neutrals
52  logical, public, protected :: twofl_gravity = .false.
53 
54  !> whether dump full variables (when splitting is used) in a separate dat file
55  logical, public, protected :: twofl_dump_full_vars = .false.
56 
57  !> Whether Hall-MHD is used
58  logical, public, protected :: twofl_hall = .false.
59 
60  type(tc_fluid), public, allocatable :: tc_fl_c
61  type(te_fluid), public, allocatable :: te_fl_c
62 
63  type(tc_fluid), allocatable :: tc_fl_n
64  logical, public, protected :: twofl_thermal_conduction_n = .false.
65  logical, public, protected :: twofl_radiative_cooling_n = .false.
66  type(rc_fluid), allocatable :: rc_fl_n
67 
68  !> Whether TRAC method is used
69  logical, public, protected :: twofl_trac = .false.
70 
71  !> Whether GLM-MHD is used
72  logical, public, protected :: twofl_glm = .false.
73 
74  !> Which TRAC method is used
75  integer, public, protected :: twofl_trac_type=1
76 
77  !> Height of the mask used in the TRAC method
78  double precision, public, protected :: twofl_trac_mask = 0.d0
79 
80  !> Whether divB cleaning sources are added splitting from fluid solver
81  logical, public, protected :: source_split_divb = .false.
82 
83  !> GLM-MHD parameter: ratio of the diffusive and advective time scales for div b
84  !> taking values within [0, 1]
85  double precision, public :: twofl_glm_alpha = 0.5d0
86 
87  !> MHD fourth order
88  logical, public, protected :: twofl_4th_order = .false.
89 
90  !> Index of the density (in the w array)
91  integer, public :: rho_c_
92 
93  !> Indices of the momentum density
94  integer, allocatable, public :: mom_c(:)
95 
96  !> Index of the energy density (-1 if not present)
97  integer, public :: e_c_=-1
98 
99  !> Index of the cutoff temperature for the TRAC method
100  integer, public :: tcoff_c_
101  integer, public :: tweight_c_
102 
103  !> Indices of the GLM psi
104  integer, public, protected :: psi_
105 
106  !> equi vars flags
107  logical, public :: has_equi_rho_c0 = .false.
108  logical, public :: has_equi_pe_c0 = .false.
109 
110  !> equi vars indices in the state%equi_vars array
111  integer, public :: equi_rho_c0_ = -1
112  integer, public :: equi_pe_c0_ = -1
113  logical, public :: twofl_equi_thermal_c = .false.
114 
115  logical, public :: twofl_equi_thermal = .false.
116  !neutrals:
117 
118  integer, public :: rho_n_
119  integer, allocatable, public :: mom_n(:)
120  integer, public :: e_n_
121  integer, public :: tcoff_n_
122  integer, public :: tweight_n_
123  logical, public :: has_equi_rho_n0 = .false.
124  logical, public :: has_equi_pe_n0 = .false.
125  integer, public :: equi_rho_n0_ = -1
126  integer, public :: equi_pe_n0_ = -1
127 
128  ! related to collisions:
129  !> collisional alpha
130  double precision, public :: twofl_alpha_coll = 0d0
131  logical, public :: twofl_alpha_coll_constant = .true.
132  !> whether include thermal exchange collisional terms
133  logical, public :: twofl_coll_inc_te = .true.
134  !> whether include ionization/recombination inelastic collisional terms
135  logical, public :: twofl_coll_inc_ionrec = .false.
136  logical, public :: twofl_equi_thermal_n = .false.
137  double precision, public :: dtcollpar = -1d0 !negative value does not impose restriction on the timestep
138  !> whether dump collisional terms in a separte dat file
139  logical, public, protected :: twofl_dump_coll_terms = .false.
140 
141  ! TODO Helium abundance not used, radiative cooling init uses it
142  ! not in parameters list anymore
143  double precision, public, protected :: he_abundance = 0d0
144  ! two fluid is only H plasma
145  double precision, public, protected :: rc = 2d0
146  double precision, public, protected :: rn = 1d0
147 
148  !> The adiabatic index
149  double precision, public :: twofl_gamma = 5.d0/3.0d0
150 
151  !> The adiabatic constant
152  double precision, public :: twofl_adiab = 1.0d0
153 
154  !> The MHD resistivity
155  double precision, public :: twofl_eta = 0.0d0
156 
157  !> The MHD hyper-resistivity
158  double precision, public :: twofl_eta_hyper = 0.0d0
159 
160  !> The MHD Hall coefficient
161  double precision, public :: twofl_etah = 0.0d0
162 
163  !> The small_est allowed energy
164  double precision, protected :: small_e
165 
166  !> Method type to clean divergence of B
167  character(len=std_len), public, protected :: typedivbfix = 'linde'
168 
169  !> Method type of constrained transport
170  character(len=std_len), public, protected :: type_ct = 'uct_contact'
171 
172  !> Whether divB is computed with a fourth order approximation
173  logical, public, protected :: twofl_divb_4thorder = .false.
174 
175  !> Method type in a integer for good performance
176  integer :: type_divb
177 
178  !> Coefficient of diffusive divB cleaning
179  double precision :: divbdiff = 0.8d0
180 
181  !> Update all equations due to divB cleaning
182  character(len=std_len) :: typedivbdiff = 'all'
183 
184  !> clean initial divB
185  logical, public :: clean_initial_divb = .false.
186 
187  !> Add divB wave in Roe solver
188  logical, public :: divbwave = .true.
189 
190  !> To control divB=0 fix for boundary
191  logical, public, protected :: boundary_divbfix(2*^nd)=.true.
192 
193  !> To skip * layer of ghost cells during divB=0 fix for boundary
194  integer, public, protected :: boundary_divbfix_skip(2*^nd)=0
195 
196  !> B0 field is force-free
197  logical, public, protected :: b0field_forcefree=.true.
198 
199  logical :: twofl_cbounds_species = .true.
200 
201  !> added from modules: gravity
202  !> source split or not
203  logical :: grav_split= .false.
204 
205  !> gamma minus one and its inverse
206  double precision :: gamma_1, inv_gamma_1
207 
208  ! DivB cleaning methods
209  integer, parameter :: divb_none = 0
210  integer, parameter :: divb_multigrid = -1
211  integer, parameter :: divb_glm = 1
212  integer, parameter :: divb_powel = 2
213  integer, parameter :: divb_janhunen = 3
214  integer, parameter :: divb_linde = 4
215  integer, parameter :: divb_lindejanhunen = 5
216  integer, parameter :: divb_lindepowel = 6
217  integer, parameter :: divb_lindeglm = 7
218  integer, parameter :: divb_ct = 8
219 
220  ! Public methods
221  public :: twofl_phys_init
222  public :: twofl_to_conserved
223  public :: twofl_to_primitive
224  public :: get_divb
225  public :: get_rhoc_tot
226  public :: twofl_get_v_c_idim
227  ! TODO needed for the roe, see if can be used for n
229  public :: get_rhon_tot
230  public :: get_alpha_coll
231  public :: get_gamma_ion_rec
232  public :: twofl_get_v_n_idim
233  public :: get_current
234  public :: twofl_get_pthermal_c
235  public :: twofl_get_pthermal_n
236  public :: twofl_face_to_center
237  public :: get_normalized_divb
238  public :: b_from_vector_potential
239  public :: usr_mask_gamma_ion_rec
240  public :: usr_mask_alpha
241 
242  {^nooned
244  }
245 
246  abstract interface
247 
248  subroutine implicit_mult_factor_subroutine(ixI^L, ixO^L, step_dt, JJ, res)
249  integer, intent(in) :: ixi^l, ixo^l
250  double precision, intent(in) :: step_dt
251  double precision, intent(in) :: jj(ixi^s)
252  double precision, intent(out) :: res(ixi^s)
253 
254  end subroutine implicit_mult_factor_subroutine
255 
256  subroutine mask_subroutine(ixI^L,ixO^L,w,x,res)
258  integer, intent(in) :: ixi^l, ixo^l
259  double precision, intent(in) :: x(ixi^s,1:ndim)
260  double precision, intent(in) :: w(ixi^s,1:nw)
261  double precision, intent(inout) :: res(ixi^s)
262  end subroutine mask_subroutine
263 
264  subroutine mask_subroutine2(ixI^L,ixO^L,w,x,res1, res2)
266  integer, intent(in) :: ixI^L, ixO^L
267  double precision, intent(in) :: x(ixI^S,1:ndim)
268  double precision, intent(in) :: w(ixI^S,1:nw)
269  double precision, intent(inout) :: res1(ixI^S),res2(ixI^S)
270  end subroutine mask_subroutine2
271 
272  end interface
273 
274  procedure(implicit_mult_factor_subroutine), pointer :: calc_mult_factor => null()
275  integer, protected :: twofl_implicit_calc_mult_method = 1
276  procedure(mask_subroutine), pointer :: usr_mask_alpha => null()
277  procedure(mask_subroutine2), pointer :: usr_mask_gamma_ion_rec => null()
278 
279 contains
280 
281  !> Read this module"s parameters from a file
282  subroutine twofl_read_params(files)
284  character(len=*), intent(in) :: files(:)
285  integer :: n
286 
287  namelist /twofl_list/ twofl_eq_energy, twofl_gamma, twofl_adiab,&
291  typedivbdiff, type_ct, divbwave, si_unit, b0field,&
298  twofl_dump_coll_terms,twofl_implicit_calc_mult_method,&
301  twofl_trac, twofl_trac_type, twofl_trac_mask,twofl_cbounds_species
302 
303  do n = 1, size(files)
304  open(unitpar, file=trim(files(n)), status="old")
305  read(unitpar, twofl_list, end=111)
306 111 close(unitpar)
307  end do
308 
309  end subroutine twofl_read_params
310 
311  subroutine twofl_init_hyper(files)
314  character(len=*), intent(in) :: files(:)
315  integer :: n
316 
317  namelist /hyperdiffusivity_list/ c_shk, c_hyp
318 
319  do n = 1, size(files)
320  open(unitpar, file=trim(files(n)), status="old")
321  read(unitpar, hyperdiffusivity_list, end=113)
322 113 close(unitpar)
323  end do
324 
325  call hyperdiffusivity_init()
326 
327  !!DEBUG
328  if(mype .eq. 0) then
329  print*, "Using Hyperdiffusivity"
330  print*, "C_SHK ", c_shk(:)
331  print*, "C_HYP ", c_hyp(:)
332  endif
333 
334  end subroutine twofl_init_hyper
335 
336  !> Write this module's parameters to a snapsoht
337  subroutine twofl_write_info(fh)
339  integer, intent(in) :: fh
340  integer, parameter :: n_par = 1
341  double precision :: values(n_par)
342  character(len=name_len) :: names(n_par)
343  integer, dimension(MPI_STATUS_SIZE) :: st
344  integer :: er
345 
346  call mpi_file_write(fh, n_par, 1, mpi_integer, st, er)
347 
348  names(1) = "gamma"
349  values(1) = twofl_gamma
350  call mpi_file_write(fh, values, n_par, mpi_double_precision, st, er)
351  call mpi_file_write(fh, names, n_par * name_len, mpi_character, st, er)
352  end subroutine twofl_write_info
353 
354  subroutine twofl_phys_init()
358  use mod_viscosity, only: viscosity_init
359  !use mod_gravity, only: gravity_init
362  {^nooned
364  }
365  integer :: itr, idir
366 
367  call twofl_read_params(par_files)
368  physics_type = "twofl"
369  if (twofl_cbounds_species) then
370  number_species = 2
371  endif
372  phys_energy=.true.
373  !> Solve total energy equation or not
374  ! for the two fluid the true value means
375  ! E_charges = E_mag + E_kin_charges + E_int_charges
376  ! E_neutrals = E_kin_neutrals + E_int_neutrals
377  phys_total_energy=.false.
378 
379  !> Solve internal energy instead of total energy
380  ! for the two fluid the true value means
381  ! E_charges = E_int_charges
382  ! E_neutrals = E_int_neutrals
383  phys_internal_e=.false.
384 
385  ! For the two fluid phys_energy=.true. and phys_internal_e=.false. and phys_total_energy = .false. means
386  ! E_charges = E_kin_charges + E_int_charges
387  ! E_neutrals = E_kin_neutrals + E_int_neutrals
388  phys_gamma = twofl_gamma
389 
390  if(twofl_eq_energy == eq_energy_int) then
391  phys_internal_e = .true.
392  elseif(twofl_eq_energy == eq_energy_tot) then
393  phys_total_energy = .true.
394  elseif(twofl_eq_energy == eq_energy_none) then
395  phys_energy = .false.
396  endif
397 
400 
401  if(.not. phys_energy) then
404  if(mype==0) write(*,*) 'WARNING: set twofl_thermal_conduction_n=F when twofl_energy=F'
405  end if
408  if(mype==0) write(*,*) 'WARNING: set twofl_radiative_cooling_n=F when twofl_energy=F'
409  end if
412  if(mype==0) write(*,*) 'WARNING: set twofl_thermal_conduction_c=F when twofl_energy=F'
413  end if
416  if(mype==0) write(*,*) 'WARNING: set twofl_radiative_cooling_c=F when twofl_energy=F'
417  end if
418  if(twofl_trac) then
419  twofl_trac=.false.
420  if(mype==0) write(*,*) 'WARNING: set twofl_trac=F when twofl_energy=F'
421  end if
422  end if
423  {^ifoned
424  if(twofl_trac .and. twofl_trac_type .gt. 1) then
426  if(mype==0) write(*,*) 'WARNING: set twofl_trac_type=1 for 1D simulation'
427  end if
428  }
429  if(twofl_trac .and. twofl_trac_type .le. 3) then
430  twofl_trac_mask=bigdouble
431  if(mype==0) write(*,*) 'WARNING: set twofl_trac_mask==bigdouble for global TRAC method'
432  end if
434 
435  ! set default gamma for polytropic/isothermal process
436  if(ndim==1) typedivbfix='none'
437  select case (typedivbfix)
438  case ('none')
439  type_divb = divb_none
440  {^nooned
441  case ('multigrid')
442  type_divb = divb_multigrid
443  use_multigrid = .true.
444  mg%operator_type = mg_laplacian
445  phys_global_source_after => twofl_clean_divb_multigrid
446  }
447  case ('glm')
448  twofl_glm = .true.
449  need_global_cmax = .true.
450  type_divb = divb_glm
451  case ('powel', 'powell')
452  type_divb = divb_powel
453  case ('janhunen')
454  type_divb = divb_janhunen
455  case ('linde')
456  type_divb = divb_linde
457  case ('lindejanhunen')
458  type_divb = divb_lindejanhunen
459  case ('lindepowel')
460  type_divb = divb_lindepowel
461  case ('lindeglm')
462  twofl_glm = .true.
463  need_global_cmax = .true.
464  type_divb = divb_lindeglm
465  case ('ct')
466  type_divb = divb_ct
467  stagger_grid = .true.
468  case default
469  call mpistop('Unknown divB fix')
470  end select
471 
472  allocate(start_indices(number_species))
473  allocate(stop_indices(number_species))
474  start_indices(1)=1
475  !allocate charges first and the same order as in mhd module
476  rho_c_ = var_set_fluxvar("rho_c", "rho_c")
477  !set variables from mod_variables to point to charges vars
478  iw_rho = rho_c_
479 
480  allocate(mom_c(ndir))
481  do idir=1,ndir
482  mom_c(idir) = var_set_fluxvar("m_c","v_c",idir)
483  enddo
484 
485  allocate(iw_mom(ndir))
486  iw_mom(1:ndir) = mom_c(1:ndir)
487 
488  ! Set index of energy variable
489  if (phys_energy) then
490  e_c_ = var_set_fluxvar("e_c", "p_c")
491  iw_e = e_c_
492  else
493  e_c_ = -1
494  end if
495 
496  ! ambipolar sts assumes mag and energy charges are continuous
497  allocate(mag(ndir))
498  mag(:) = var_set_bfield(ndir)
499 
500  if (twofl_glm) then
501  psi_ = var_set_fluxvar('psi', 'psi', need_bc=.false.)
502  else
503  psi_ = -1
504  end if
505 
506  ! set cutoff temperature when using the TRAC method, as well as an auxiliary weight
507  tweight_c_ = -1
508  if(twofl_trac) then
509  tcoff_c_ = var_set_wextra()
510  iw_tcoff = tcoff_c_
511  if(twofl_trac_type > 2) then
512  tweight_c_ = var_set_wextra()
513  endif
514  else
515  tcoff_c_ = -1
516  end if
517 
518  !now allocate neutrals
519 
520  ! TODO so far number_species is only used to treat them differently
521  ! in the solvers (different cbounds)
522  if (twofl_cbounds_species) then
523  stop_indices(1)=nwflux
524  start_indices(2)=nwflux+1
525  endif
526 
527  ! Determine flux variables
528  rho_n_ = var_set_fluxvar("rho_n", "rho_n")
529  allocate(mom_n(ndir))
530  do idir=1,ndir
531  mom_n(idir) = var_set_fluxvar("m_n","v_n",idir)
532  enddo
533  if (phys_energy) then
534  e_n_ = var_set_fluxvar("e_n", "p_n")
535  else
536  e_n_ = -1
537  end if
538 
539  tweight_n_ = -1
540  if(twofl_trac) then
541  tcoff_n_ = var_set_wextra()
542  if(twofl_trac_type > 2) then
543  tweight_n_ = var_set_wextra()
544  endif
545  else
546  tcoff_n_ = -1
547  end if
548 
549  stop_indices(number_species)=nwflux
550 
551  ! set indices of equi vars and update number_equi_vars
552  number_equi_vars = 0
553  if(has_equi_rho_n0) then
556  endif
557  if(has_equi_pe_n0) then
560  phys_equi_pe=.true.
561  endif
562  if(has_equi_rho_c0) then
565  iw_equi_rho = equi_rho_c0_
566  endif
567  if(has_equi_pe_c0) then
570  iw_equi_p = equi_pe_c0_
571  phys_equi_pe=.true.
572  endif
573 
574  ! set number of variables which need update ghostcells
575  nwgc=nwflux+nwaux
576 
577  ! determine number of stagger variables
578  nws=ndim
579 
580  ! Check whether custom flux types have been defined
581  if (.not. allocated(flux_type)) then
582  allocate(flux_type(ndir, nw))
583  flux_type = flux_default
584  else if (any(shape(flux_type) /= [ndir, nw])) then
585  call mpistop("phys_check error: flux_type has wrong shape")
586  end if
587 
588  if(ndim>1) then
589  if(twofl_glm) then
590  flux_type(:,psi_)=flux_special
591  do idir=1,ndir
592  flux_type(idir,mag(idir))=flux_special
593  end do
594  else
595  do idir=1,ndir
596  flux_type(idir,mag(idir))=flux_tvdlf
597  end do
598  end if
599  end if
600 
601  phys_get_dt => twofl_get_dt
602  phys_get_cmax => twofl_get_cmax
603  phys_get_a2max => twofl_get_a2max
604  !phys_get_tcutoff => twofl_get_tcutoff_c
605  if(twofl_cbounds_species) then
606  if (mype .eq. 0) print*, "Using different cbounds for each species nspecies = ", number_species
607  phys_get_cbounds => twofl_get_cbounds_species
608  phys_get_h_speed => twofl_get_h_speed_species
609  else
610  if (mype .eq. 0) print*, "Using same cbounds for all species"
611  phys_get_cbounds => twofl_get_cbounds_one
612  phys_get_h_speed => twofl_get_h_speed_one
613  endif
614  phys_get_flux => twofl_get_flux
615  phys_add_source_geom => twofl_add_source_geom
616  phys_add_source => twofl_add_source
617  phys_to_conserved => twofl_to_conserved
618  phys_to_primitive => twofl_to_primitive
619  phys_check_params => twofl_check_params
620  phys_check_w => twofl_check_w
621  phys_write_info => twofl_write_info
622  phys_handle_small_values => twofl_handle_small_values
623  !set equilibrium variables for the new grid
624  if(number_equi_vars>0) then
625  phys_set_equi_vars => set_equi_vars_grid
626  endif
627  ! convert_type is not known here, so associate the corresp. subroutine in check_params
628  if(type_divb==divb_glm) then
629  phys_modify_wlr => twofl_modify_wlr
630  end if
631 
632  ! if using ct stagger grid, boundary divb=0 is not done here
633  if(stagger_grid) then
634  phys_get_ct_velocity => twofl_get_ct_velocity
635  phys_update_faces => twofl_update_faces
636  phys_face_to_center => twofl_face_to_center
637  phys_modify_wlr => twofl_modify_wlr
638  else if(ndim>1) then
639  phys_boundary_adjust => twofl_boundary_adjust
640  end if
641 
642  {^nooned
643  ! clean initial divb
644  if(clean_initial_divb) phys_clean_divb => twofl_clean_divb_multigrid
645  }
646 
647  ! Whether diagonal ghost cells are required for the physics
648  if(type_divb < divb_linde) phys_req_diagonal = .false.
649 
650  ! derive units from basic units
651  call twofl_physical_units()
652 
653  if(.not. phys_energy .and. (twofl_thermal_conduction_c&
654  .or. twofl_thermal_conduction_n)) then
655  call mpistop("thermal conduction needs twofl_energy=T")
656  end if
657 
658  ! initialize thermal conduction module
660  .or. twofl_thermal_conduction_n) then
661  phys_req_diagonal = .true.
662  call sts_init()
664  endif
666  allocate(tc_fl_c)
667  if(has_equi_pe_c0 .and. has_equi_rho_c0) then
668  tc_fl_c%get_temperature_from_eint => twofl_get_temperature_from_eint_c_with_equi
669  if(phys_internal_e) then
670  tc_fl_c%get_temperature_from_conserved => twofl_get_temperature_from_eint_c_with_equi
671  else
672  if(twofl_eq_energy == eq_energy_ki) then
673  tc_fl_c%get_temperature_from_conserved => twofl_get_temperature_from_eki_c_with_equi
674  else
675  tc_fl_c%get_temperature_from_conserved => twofl_get_temperature_from_etot_c_with_equi
676  endif
677  endif
678  if(twofl_equi_thermal_c) then
679  tc_fl_c%has_equi = .true.
680  tc_fl_c%get_temperature_equi => twofl_get_temperature_c_equi
681  tc_fl_c%get_rho_equi => twofl_get_rho_c_equi
682  else
683  tc_fl_c%has_equi = .false.
684  endif
685  else
686  if(phys_internal_e) then
687  tc_fl_c%get_temperature_from_conserved => twofl_get_temperature_from_eint_c
688  else
689  if(twofl_eq_energy == eq_energy_ki) then
690  tc_fl_c%get_temperature_from_conserved => twofl_get_temperature_from_eki_c
691  else
692  tc_fl_c%get_temperature_from_conserved => twofl_get_temperature_from_etot_c
693  endif
694  endif
695  tc_fl_c%get_temperature_from_eint => twofl_get_temperature_from_eint_c
696  endif
697  if(use_twofl_tc_c .eq. mhd_tc) then
700  else if(use_twofl_tc_c .eq. hd_tc) then
703  endif
704  if(.not. phys_internal_e) then
706  endif
708  tc_fl_c%get_rho => get_rhoc_tot
709  tc_fl_c%e_ = e_c_
710  tc_fl_c%Tcoff_ = tcoff_c_
711  end if
713  allocate(tc_fl_n)
715  if(has_equi_pe_n0 .and. has_equi_rho_n0) then
716  tc_fl_n%get_temperature_from_eint => twofl_get_temperature_from_eint_n_with_equi
717  if(twofl_equi_thermal_n) then
718  tc_fl_n%has_equi = .true.
719  tc_fl_n%get_temperature_equi => twofl_get_temperature_n_equi
720  tc_fl_n%get_rho_equi => twofl_get_rho_n_equi
721  else
722  tc_fl_n%has_equi = .false.
723  endif
724  else
725  tc_fl_n%get_temperature_from_eint => twofl_get_temperature_from_eint_n
726  endif
727  if(phys_internal_e) then
728  if(has_equi_pe_n0 .and. has_equi_rho_n0) then
729  tc_fl_n%get_temperature_from_conserved => twofl_get_temperature_from_eint_n_with_equi
730  else
731  tc_fl_n%get_temperature_from_conserved => twofl_get_temperature_from_eint_n
732  endif
734  else
735  if(has_equi_pe_n0 .and. has_equi_rho_n0) then
736  tc_fl_n%get_temperature_from_conserved => twofl_get_temperature_from_etot_n_with_equi
737  else
738  tc_fl_n%get_temperature_from_conserved => twofl_get_temperature_from_etot_n
739  endif
742  endif
744  tc_fl_n%get_rho => get_rhon_tot
745  tc_fl_n%e_ = e_n_
746  tc_fl_n%Tcoff_ = tcoff_n_
747  end if
748 
749 
750  if(.not. phys_energy .and. (twofl_radiative_cooling_c&
751  .or. twofl_radiative_cooling_n)) then
752  call mpistop("radiative cooling needs twofl_energy=T")
753  end if
754 
755  if(twofl_equi_thermal .and. (.not. has_equi_pe_c0 .or. .not. has_equi_pe_n0)) then
756  call mpistop("twofl_equi_thermal=T has_equi_pe_n0 and has _equi_pe_c0=T")
757  endif
758 
759  ! initialize thermal conduction module
761  .or. twofl_radiative_cooling_n) then
762  ! Initialize radiative cooling module
763  call radiative_cooling_init_params(twofl_gamma,he_abundance)
765  allocate(rc_fl_c)
767  rc_fl_c%get_rho => get_rhoc_tot
768  rc_fl_c%get_pthermal => twofl_get_pthermal_c
769  rc_fl_c%get_var_Rfactor => rfactor_c
770  rc_fl_c%e_ = e_c_
771  rc_fl_c%Tcoff_ = tcoff_c_
773  rc_fl_c%has_equi = .true.
774  rc_fl_c%get_rho_equi => twofl_get_rho_c_equi
775  rc_fl_c%get_pthermal_equi => twofl_get_pe_c_equi
776  else
777  rc_fl_c%has_equi = .false.
778  end if
779  end if
780  end if
781  allocate(te_fl_c)
782  te_fl_c%get_rho=> get_rhoc_tot
783  te_fl_c%get_pthermal=> twofl_get_pthermal_c
784  te_fl_c%get_var_Rfactor => rfactor_c
785 {^ifthreed
786  phys_te_images => twofl_te_images
787 }
788 
789  ! Initialize viscosity module
790  !!TODO
791  !if (twofl_viscosity) call viscosity_init(phys_wider_stencil,phys_req_diagonal)
792 
793  ! Initialize gravity module
794  if(twofl_gravity) then
795  ! call gravity_init()
797  end if
798 
799  ! Initialize particles module
800  ! For Hall, we need one more reconstructed layer since currents are computed
801  ! in getflux: assuming one additional ghost layer (two for FOURTHORDER) was
802  ! added in nghostcells.
803  if (twofl_hall) then
804  phys_req_diagonal = .true.
805  if (twofl_4th_order) then
806  phys_wider_stencil = 2
807  else
808  phys_wider_stencil = 1
809  end if
810  end if
811 
812  if(twofl_hyperdiffusivity) then
813  allocate(c_shk(1:nwflux))
814  allocate(c_hyp(1:nwflux))
816  end if
817 
818  end subroutine twofl_phys_init
819 
820 {^ifthreed
821  subroutine twofl_te_images
824 
825  select case(convert_type)
826  case('EIvtiCCmpi','EIvtuCCmpi')
828  case('ESvtiCCmpi','ESvtuCCmpi')
830  case('SIvtiCCmpi','SIvtuCCmpi')
832  case('WIvtiCCmpi','WIvtuCCmpi')
834  case default
835  call mpistop("Error in synthesize emission: Unknown convert_type")
836  end select
837  end subroutine twofl_te_images
838 }
839 
840  ! wrappers for STS functions in thermal_conductivity module
841  ! which take as argument the tc_fluid (defined in the physics module)
842  subroutine twofl_sts_set_source_tc_c_mhd(ixI^L,ixO^L,w,x,wres,fix_conserve_at_step,my_dt,igrid,nflux)
844  use mod_fix_conserve
846  integer, intent(in) :: ixI^L, ixO^L, igrid, nflux
847  double precision, intent(in) :: x(ixI^S,1:ndim)
848  double precision, intent(inout) :: wres(ixI^S,1:nw), w(ixI^S,1:nw)
849  double precision, intent(in) :: my_dt
850  logical, intent(in) :: fix_conserve_at_step
851  call sts_set_source_tc_mhd(ixi^l,ixo^l,w,x,wres,fix_conserve_at_step,my_dt,igrid,nflux,tc_fl_c)
852  end subroutine twofl_sts_set_source_tc_c_mhd
853 
854  subroutine twofl_sts_set_source_tc_c_hd(ixI^L,ixO^L,w,x,wres,fix_conserve_at_step,my_dt,igrid,nflux)
856  use mod_fix_conserve
858  integer, intent(in) :: ixI^L, ixO^L, igrid, nflux
859  double precision, intent(in) :: x(ixI^S,1:ndim)
860  double precision, intent(inout) :: wres(ixI^S,1:nw), w(ixI^S,1:nw)
861  double precision, intent(in) :: my_dt
862  logical, intent(in) :: fix_conserve_at_step
863  call sts_set_source_tc_hd(ixi^l,ixo^l,w,x,wres,fix_conserve_at_step,my_dt,igrid,nflux,tc_fl_c)
864  end subroutine twofl_sts_set_source_tc_c_hd
865 
866  function twofl_get_tc_dt_mhd_c(w,ixI^L,ixO^L,dx^D,x) result(dtnew)
867  !Check diffusion time limit dt < dx_i**2/((gamma-1)*tc_k_para_i/rho)
868  !where tc_k_para_i=tc_k_para*B_i**2/B**2
869  !and T=p/rho
872 
873  integer, intent(in) :: ixi^l, ixo^l
874  double precision, intent(in) :: dx^d, x(ixi^s,1:ndim)
875  double precision, intent(in) :: w(ixi^s,1:nw)
876  double precision :: dtnew
877 
878  dtnew=get_tc_dt_mhd(w,ixi^l,ixo^l,dx^d,x,tc_fl_c)
879  end function twofl_get_tc_dt_mhd_c
880 
881  function twofl_get_tc_dt_hd_c(w,ixI^L,ixO^L,dx^D,x) result(dtnew)
882  !Check diffusion time limit dt < dx_i**2/((gamma-1)*tc_k_para_i/rho)
883  !where tc_k_para_i=tc_k_para*B_i**2/B**2
884  !and T=p/rho
887 
888  integer, intent(in) :: ixi^l, ixo^l
889  double precision, intent(in) :: dx^d, x(ixi^s,1:ndim)
890  double precision, intent(in) :: w(ixi^s,1:nw)
891  double precision :: dtnew
892 
893  dtnew=get_tc_dt_hd(w,ixi^l,ixo^l,dx^d,x,tc_fl_c)
894  end function twofl_get_tc_dt_hd_c
895 
896  subroutine twofl_tc_handle_small_e_c(w, x, ixI^L, ixO^L, step)
898  use mod_small_values
899 
900  integer, intent(in) :: ixI^L,ixO^L
901  double precision, intent(inout) :: w(ixI^S,1:nw)
902  double precision, intent(in) :: x(ixI^S,1:ndim)
903  integer, intent(in) :: step
904 
905  character(len=140) :: error_msg
906 
907  write(error_msg,"(a,i3)") "Charges thermal conduction step ", step
908  call twofl_handle_small_ei_c(w,x,ixi^l,ixo^l,e_c_,error_msg)
909  end subroutine twofl_tc_handle_small_e_c
910 
911  subroutine twofl_sts_set_source_tc_n_hd(ixI^L,ixO^L,w,x,wres,fix_conserve_at_step,my_dt,igrid,nflux)
913  use mod_fix_conserve
915  integer, intent(in) :: ixI^L, ixO^L, igrid, nflux
916  double precision, intent(in) :: x(ixI^S,1:ndim)
917  double precision, intent(inout) :: wres(ixI^S,1:nw), w(ixI^S,1:nw)
918  double precision, intent(in) :: my_dt
919  logical, intent(in) :: fix_conserve_at_step
920  call sts_set_source_tc_hd(ixi^l,ixo^l,w,x,wres,fix_conserve_at_step,my_dt,igrid,nflux,tc_fl_n)
921  end subroutine twofl_sts_set_source_tc_n_hd
922 
923  subroutine twofl_tc_handle_small_e_n(w, x, ixI^L, ixO^L, step)
925 
926  integer, intent(in) :: ixI^L,ixO^L
927  double precision, intent(inout) :: w(ixI^S,1:nw)
928  double precision, intent(in) :: x(ixI^S,1:ndim)
929  integer, intent(in) :: step
930 
931  character(len=140) :: error_msg
932 
933  write(error_msg,"(a,i3)") "Neutral thermal conduction step ", step
934  call twofl_handle_small_ei_n(w,x,ixi^l,ixo^l,e_n_,error_msg)
935  end subroutine twofl_tc_handle_small_e_n
936 
937  function twofl_get_tc_dt_hd_n(w,ixI^L,ixO^L,dx^D,x) result(dtnew)
938  !Check diffusion time limit dt < dx_i**2/((gamma-1)*tc_k_para_i/rho)
939  !where tc_k_para_i=tc_k_para*B_i**2/B**2
940  !and T=p/rho
943 
944  integer, intent(in) :: ixi^l, ixo^l
945  double precision, intent(in) :: dx^d, x(ixi^s,1:ndim)
946  double precision, intent(in) :: w(ixi^s,1:nw)
947  double precision :: dtnew
948 
949  dtnew=get_tc_dt_hd(w,ixi^l,ixo^l,dx^d,x,tc_fl_n)
950  end function twofl_get_tc_dt_hd_n
951 
952  subroutine tc_n_params_read_hd(fl)
954  use mod_global_parameters, only: unitpar
955  type(tc_fluid), intent(inout) :: fl
956  integer :: n
957  logical :: tc_saturate=.false.
958  double precision :: tc_k_para=0d0
959 
960  namelist /tc_n_list/ tc_saturate, tc_k_para
961 
962  do n = 1, size(par_files)
963  open(unitpar, file=trim(par_files(n)), status="old")
964  read(unitpar, tc_n_list, end=111)
965 111 close(unitpar)
966  end do
967  fl%tc_saturate = tc_saturate
968  fl%tc_k_para = tc_k_para
969 
970  end subroutine tc_n_params_read_hd
971 
972  subroutine rc_params_read_n(fl)
974  use mod_constants, only: bigdouble
975  type(rc_fluid), intent(inout) :: fl
976  integer :: n
977  ! list parameters
978  integer :: ncool = 4000
979  double precision :: cfrac=0.1d0
980 
981  !> Name of cooling curve
982  character(len=std_len) :: coolcurve='JCorona'
983 
984  !> Name of cooling method
985  character(len=std_len) :: coolmethod='exact'
986 
987  !> Fixed temperature not lower than tlow
988  logical :: Tfix=.false.
989 
990  !> Lower limit of temperature
991  double precision :: tlow=bigdouble
992 
993  !> Add cooling source in a split way (.true.) or un-split way (.false.)
994  logical :: rc_split=.false.
995 
996  namelist /rc_list_n/ coolcurve, coolmethod, ncool, cfrac, tlow, tfix, rc_split
997 
998  do n = 1, size(par_files)
999  open(unitpar, file=trim(par_files(n)), status="old")
1000  read(unitpar, rc_list_n, end=111)
1001 111 close(unitpar)
1002  end do
1003 
1004  fl%ncool=ncool
1005  fl%coolcurve=coolcurve
1006  fl%coolmethod=coolmethod
1007  fl%tlow=tlow
1008  fl%Tfix=tfix
1009  fl%rc_split=rc_split
1010  fl%cfrac=cfrac
1011  end subroutine rc_params_read_n
1012 
1013  !end wrappers
1014 
1015  ! fill in tc_fluid fields from namelist
1016  subroutine tc_c_params_read_mhd(fl)
1018  type(tc_fluid), intent(inout) :: fl
1019 
1020  integer :: n
1021 
1022  ! list parameters
1023  logical :: tc_perpendicular=.false.
1024  logical :: tc_saturate=.false.
1025  double precision :: tc_k_para=0d0
1026  double precision :: tc_k_perp=0d0
1027  character(len=std_len) :: tc_slope_limiter="MC"
1028 
1029  namelist /tc_c_list/ tc_perpendicular, tc_saturate, tc_slope_limiter, tc_k_para, tc_k_perp
1030  do n = 1, size(par_files)
1031  open(unitpar, file=trim(par_files(n)), status="old")
1032  read(unitpar, tc_c_list, end=111)
1033 111 close(unitpar)
1034  end do
1035 
1036  fl%tc_perpendicular = tc_perpendicular
1037  fl%tc_saturate = tc_saturate
1038  fl%tc_k_para = tc_k_para
1039  fl%tc_k_perp = tc_k_perp
1040  select case(tc_slope_limiter)
1041  case ('no','none')
1042  fl%tc_slope_limiter = 0
1043  case ('MC')
1044  ! montonized central limiter Woodward and Collela limiter (eq.3.51h), a factor of 2 is pulled out
1045  fl%tc_slope_limiter = 1
1046  case('minmod')
1047  ! minmod limiter
1048  fl%tc_slope_limiter = 2
1049  case ('superbee')
1050  ! Roes superbee limiter (eq.3.51i)
1051  fl%tc_slope_limiter = 3
1052  case ('koren')
1053  ! Barry Koren Right variant
1054  fl%tc_slope_limiter = 4
1055  case default
1056  call mpistop("Unknown tc_slope_limiter, choose MC, minmod")
1057  end select
1058  end subroutine tc_c_params_read_mhd
1059 
1060  subroutine tc_c_params_read_hd(fl)
1062  use mod_global_parameters, only: unitpar
1063  type(tc_fluid), intent(inout) :: fl
1064  integer :: n
1065  logical :: tc_saturate=.false.
1066  double precision :: tc_k_para=0d0
1067 
1068  namelist /tc_c_list/ tc_saturate, tc_k_para
1069 
1070  do n = 1, size(par_files)
1071  open(unitpar, file=trim(par_files(n)), status="old")
1072  read(unitpar, tc_c_list, end=111)
1073 111 close(unitpar)
1074  end do
1075  fl%tc_saturate = tc_saturate
1076  fl%tc_k_para = tc_k_para
1077 
1078  end subroutine tc_c_params_read_hd
1079 
1080 !! end th cond
1081 
1082 !!rad cool
1083  subroutine rc_params_read_c(fl)
1085  use mod_constants, only: bigdouble
1086  type(rc_fluid), intent(inout) :: fl
1087  integer :: n
1088  ! list parameters
1089  integer :: ncool = 4000
1090  double precision :: cfrac=0.1d0
1091 
1092  !> Name of cooling curve
1093  character(len=std_len) :: coolcurve='JCcorona'
1094 
1095  !> Name of cooling method
1096  character(len=std_len) :: coolmethod='exact'
1097 
1098  !> Fixed temperature not lower than tlow
1099  logical :: Tfix=.false.
1100 
1101  !> Lower limit of temperature
1102  double precision :: tlow=bigdouble
1103 
1104  !> Add cooling source in a split way (.true.) or un-split way (.false.)
1105  logical :: rc_split=.false.
1106 
1107 
1108  namelist /rc_list_c/ coolcurve, coolmethod, ncool, cfrac, tlow, tfix, rc_split
1109 
1110  do n = 1, size(par_files)
1111  open(unitpar, file=trim(par_files(n)), status="old")
1112  read(unitpar, rc_list_c, end=111)
1113 111 close(unitpar)
1114  end do
1115 
1116  fl%ncool=ncool
1117  fl%coolcurve=coolcurve
1118  fl%coolmethod=coolmethod
1119  fl%tlow=tlow
1120  fl%Tfix=tfix
1121  fl%rc_split=rc_split
1122  fl%cfrac=cfrac
1123  end subroutine rc_params_read_c
1124 
1125 !! end rad cool
1126 
1127  !> sets the equilibrium variables
1128  subroutine set_equi_vars_grid_faces(igrid,x,ixI^L,ixO^L)
1131  use mod_usr_methods
1132  integer, intent(in) :: igrid, ixI^L, ixO^L
1133  double precision, intent(in) :: x(ixI^S,1:ndim)
1134 
1135  double precision :: delx(ixI^S,1:ndim)
1136  double precision :: xC(ixI^S,1:ndim),xshift^D
1137  integer :: idims, ixC^L, hxO^L, ix, idims2
1138 
1139  if(slab_uniform)then
1140  ^d&delx(ixi^s,^d)=rnode(rpdx^d_,igrid)\
1141  else
1142  ! for all non-cartesian and stretched cartesian coordinates
1143  delx(ixi^s,1:ndim)=ps(igrid)%dx(ixi^s,1:ndim)
1144  endif
1145 
1146 
1147  do idims=1,ndim
1148  hxo^l=ixo^l-kr(idims,^d);
1149  if(stagger_grid) then
1150  ! ct needs all transverse cells
1151  ixcmax^d=ixomax^d+nghostcells-nghostcells*kr(idims,^d); ixcmin^d=hxomin^d-nghostcells+nghostcells*kr(idims,^d);
1152  else
1153  ! ixC is centered index in the idims direction from ixOmin-1/2 to ixOmax+1/2
1154  ixcmax^d=ixomax^d; ixcmin^d=hxomin^d;
1155  end if
1156  ! always xshift=0 or 1/2
1157  xshift^d=half*(one-kr(^d,idims));
1158  do idims2=1,ndim
1159  select case(idims2)
1160  {case(^d)
1161  do ix = ixc^lim^d
1162  ! xshift=half: this is the cell center coordinate
1163  ! xshift=0: this is the cell edge i+1/2 coordinate
1164  xc(ix^d%ixC^s,^d)=x(ix^d%ixC^s,^d)+(half-xshift^d)*delx(ix^d%ixC^s,^d)
1165  end do\}
1166  end select
1167  end do
1168  call usr_set_equi_vars(ixi^l,ixc^l,xc,ps(igrid)%equi_vars(ixi^s,1:number_equi_vars,idims))
1169  end do
1170 
1171  end subroutine set_equi_vars_grid_faces
1172 
1173  !> sets the equilibrium variables
1174  subroutine set_equi_vars_grid(igrid)
1176  use mod_usr_methods
1177 
1178  integer, intent(in) :: igrid
1179 
1180  !values at the center
1181  call usr_set_equi_vars(ixg^ll,ixg^ll,ps(igrid)%x,ps(igrid)%equi_vars(ixg^t,1:number_equi_vars,0))
1182 
1183  !values at the interfaces
1184  call set_equi_vars_grid_faces(igrid,ps(igrid)%x,ixg^ll,ixm^ll)
1185 
1186  end subroutine set_equi_vars_grid
1187 
1188  ! w, wnew conserved
1189  function convert_vars_splitting(ixI^L,ixO^L, w, x, nwc) result(wnew)
1191  integer, intent(in) :: ixi^l,ixo^l, nwc
1192  double precision, intent(in) :: w(ixi^s, 1:nw)
1193  double precision, intent(in) :: x(ixi^s,1:ndim)
1194  double precision :: wnew(ixo^s, 1:nwc)
1195  double precision :: rho(ixi^s)
1196 
1197  call get_rhon_tot(w,x,ixi^l,ixo^l,rho(ixi^s))
1198  wnew(ixo^s,rho_n_) = rho(ixo^s)
1199  wnew(ixo^s,mom_n(:)) = w(ixo^s,mom_n(:))
1200  call get_rhoc_tot(w,x,ixi^l,ixo^l,rho(ixi^s))
1201  wnew(ixo^s,rho_c_) = rho(ixo^s)
1202  wnew(ixo^s,mom_c(:)) = w(ixo^s,mom_c(:))
1203 
1204  if (b0field) then
1205  ! add background magnetic field B0 to B
1206  wnew(ixo^s,mag(:))=w(ixo^s,mag(:))+block%B0(ixo^s,:,0)
1207  else
1208  wnew(ixo^s,mag(:))=w(ixo^s,mag(:))
1209  end if
1210 
1211  if(phys_energy) then
1212  wnew(ixo^s,e_n_) = w(ixo^s,e_n_)
1213  if(has_equi_pe_n0) then
1214  wnew(ixo^s,e_n_) = wnew(ixo^s,e_n_) + block%equi_vars(ixo^s,equi_pe_n0_,0)* inv_gamma_1
1215  endif
1216  wnew(ixo^s,e_c_) = w(ixo^s,e_c_)
1217  if(has_equi_pe_c0) then
1218  wnew(ixo^s,e_c_) = wnew(ixo^s,e_c_) + block%equi_vars(ixo^s,equi_pe_c0_,0)* inv_gamma_1
1219  endif
1220  if(b0field .and. phys_total_energy) then
1221  wnew(ixo^s,e_c_)=wnew(ixo^s,e_c_)+0.5d0*sum(block%B0(ixo^s,:,0)**2,dim=ndim+1) &
1222  + sum(w(ixo^s,mag(:))*block%B0(ixo^s,:,0),dim=ndim+1)
1223  endif
1224  endif
1225 
1226  end function convert_vars_splitting
1227 
1228  !> copied from mod_gravity
1229  subroutine grav_params_read(files)
1230  use mod_global_parameters, only: unitpar
1231  character(len=*), intent(in) :: files(:)
1232  integer :: n
1233 
1234  namelist /grav_list/ grav_split
1235 
1236  do n = 1, size(files)
1237  open(unitpar, file=trim(files(n)), status="old")
1238  read(unitpar, grav_list, end=111)
1239 111 close(unitpar)
1240  end do
1241 
1242  end subroutine grav_params_read
1243 
1246  use mod_convert, only: add_convert_method
1247  integer :: ii
1248  do ii = 1,ndim
1249  if(ii==1) then
1250  call add_convert_method(dump_hyperdiffusivity_coef_x, nw, cons_wnames(1:nw), "hyper_x")
1251  elseif(ii==2) then
1252  call add_convert_method(dump_hyperdiffusivity_coef_y, nw, cons_wnames(1:nw), "hyper_y")
1253  else
1254  call add_convert_method(dump_hyperdiffusivity_coef_z, nw, cons_wnames(1:nw), "hyper_z")
1255  endif
1256  enddo
1257  end subroutine associate_dump_hyper
1258 
1261  use mod_usr_methods
1262  use mod_convert, only: add_convert_method
1263 
1264  ! after user parameter setting
1265  gamma_1=twofl_gamma-1.d0
1266  if (.not. phys_energy) then
1267  if (twofl_gamma <= 0.0d0) call mpistop ("Error: twofl_gamma <= 0")
1268  if (twofl_adiab < 0.0d0) call mpistop ("Error: twofl_adiab < 0")
1270  else
1271  if (twofl_gamma <= 0.0d0 .or. twofl_gamma == 1.0d0) &
1272  call mpistop ("Error: twofl_gamma <= 0 or twofl_gamma == 1")
1273  inv_gamma_1=1.d0/gamma_1
1274  small_e = small_pressure * inv_gamma_1
1275  end if
1276 
1277  ! this has to be done here as use_imex_scheme is not set in init subroutine,
1278  ! but here it is
1279  if(use_imex_scheme) then
1280  if(has_collisions()) then
1281  ! implicit collisional terms update
1282  phys_implicit_update => twofl_implicit_coll_terms_update
1283  phys_evaluate_implicit => twofl_evaluate_implicit
1284  if(mype .eq. 1) then
1285  print*, "IMPLICIT UPDATE with calc_mult_factor", twofl_implicit_calc_mult_method
1286  endif
1287  if(twofl_implicit_calc_mult_method == 1) then
1289  else
1290  calc_mult_factor => calc_mult_factor2
1291  endif
1292  endif
1293  else
1294  ! check dtcoll par for explicit implementation of the coll. terms
1295  if(dtcollpar .le. 0d0 .or. dtcollpar .ge. 1d0) then
1296  if (mype .eq. 0) print*, "Explicit update of coll terms requires 0<dtcollpar<1, dtcollpar set to 0.8."
1297  dtcollpar = 0.8
1298  endif
1299 
1300  endif
1301 ! if(H_ion_fr == 0d0 .and. He_ion_fr == 0d0) then
1302 ! call mpistop("H_ion_fr or He_ion_fr must be > 0 or use hd module")
1303 ! endif
1304 ! if(H_ion_fr == 1d0 .and. He_ion_fr == 1d0) then
1305 ! call mpistop("H_ion_fr or He_ion_fr must be < 1 or use mhd module")
1306 ! endif
1307  if (number_equi_vars > 0 .and. .not. associated(usr_set_equi_vars)) then
1308  call mpistop("usr_set_equi_vars has to be implemented in the user file")
1309  endif
1310  if(convert .or. autoconvert) then
1311  if(convert_type .eq. 'dat_generic_mpi') then
1312  if(twofl_dump_full_vars) then
1313  if(mype .eq. 0) print*, " add conversion method: split -> full "
1314  call add_convert_method(convert_vars_splitting, nw, cons_wnames, "new")
1315  endif
1316  if(twofl_dump_coll_terms) then
1317  if(mype .eq. 0) print*, " add conversion method: dump coll terms "
1318  call add_convert_method(dump_coll_terms, 3, (/"alpha ", "gamma_rec", "gamma_ion"/), "_coll")
1319  endif
1321  if(mype .eq. 0) print*, " add conversion method: dump hyperdiffusivity coeff. "
1322  call associate_dump_hyper()
1323  endif
1324  endif
1325  endif
1326  end subroutine twofl_check_params
1327 
1330  double precision :: mp,kB,miu0,c_lightspeed
1331  !double precision :: a,b,c,d
1332  double precision :: a,b
1333  ! Derive scaling units
1334  if(si_unit) then
1335  mp=mp_si
1336  kb=kb_si
1337  miu0=miu0_si
1338  c_lightspeed=c_si
1339  else
1340  mp=mp_cgs
1341  kb=kb_cgs
1342  miu0=4.d0*dpi
1343  c_lightspeed=const_c
1344  end if
1345 
1346  a=1d0
1347  b=1d0
1348  rc=2d0
1349  rn=1d0
1350 
1351  !now the unit choice:
1352  !unit 1 from number density or density -> mH
1353  !unit 2 from
1354 
1355  if(unit_density/=1.d0) then
1357  else
1358  ! unit of numberdensity is independent by default
1360  end if
1361  if(unit_velocity/=1.d0) then
1365  else if(unit_pressure/=1.d0) then
1369  else if(unit_magneticfield/=1.d0) then
1373  else if(unit_temperature/=1.d0) then
1377  end if
1378  if(unit_time/=1.d0) then
1380  else
1381  ! unit of length is independent by default
1383  end if
1384  ! Additional units needed for the particles
1385  c_norm=c_lightspeed/unit_velocity
1387  if (.not. si_unit) unit_charge = unit_charge*const_c
1389  end subroutine twofl_physical_units
1390 
1391  subroutine twofl_check_w(primitive,ixI^L,ixO^L,w,flag)
1393 
1394  logical, intent(in) :: primitive
1395  integer, intent(in) :: ixI^L, ixO^L
1396  double precision, intent(in) :: w(ixI^S,nw)
1397  double precision :: tmp(ixI^S)
1398  logical, intent(inout) :: flag(ixI^S,1:nw)
1399 
1400  flag=.false.
1401 
1402  if(has_equi_rho_n0) then
1403  tmp(ixo^s) = w(ixo^s,rho_n_) + block%equi_vars(ixo^s,equi_rho_n0_,0)
1404  else
1405  tmp(ixo^s) = w(ixo^s,rho_n_)
1406  endif
1407  where(tmp(ixo^s) < small_density) flag(ixo^s,rho_n_) = .true.
1408  if(has_equi_rho_c0) then
1409  tmp(ixo^s) = w(ixo^s,rho_c_) + block%equi_vars(ixo^s,equi_rho_c0_,0)
1410  else
1411  tmp(ixo^s) = w(ixo^s,rho_c_)
1412  endif
1413  where(tmp(ixo^s) < small_density) flag(ixo^s,rho_c_) = .true.
1414  if(phys_energy) then
1415  if(primitive) then
1416  tmp(ixo^s) = w(ixo^s,e_n_)
1417  if(has_equi_pe_n0) then
1418  tmp(ixo^s) = tmp(ixo^s)+block%equi_vars(ixo^s,equi_pe_n0_,0)
1419  endif
1420  where(tmp(ixo^s) < small_pressure) flag(ixo^s,e_n_) = .true.
1421  tmp(ixo^s) = w(ixo^s,e_c_)
1422  if(has_equi_pe_c0) then
1423  tmp(ixo^s) = tmp(ixo^s)+block%equi_vars(ixo^s,equi_pe_c0_,0)
1424  endif
1425  where(tmp(ixo^s) < small_pressure) flag(ixo^s,e_c_) = .true.
1426  else
1427  if(phys_internal_e) then
1428  tmp(ixo^s)=w(ixo^s,e_n_)
1429  if(has_equi_pe_n0) then
1430  tmp(ixo^s) = tmp(ixo^s)+block%equi_vars(ixo^s,equi_pe_n0_,0)*inv_gamma_1
1431  endif
1432  where(tmp(ixo^s) < small_e) flag(ixo^s,e_n_) = .true.
1433  tmp(ixo^s)=w(ixo^s,e_c_)
1434  if(has_equi_pe_c0) then
1435  tmp(ixo^s) = tmp(ixo^s)+block%equi_vars(ixo^s,equi_pe_c0_,0)*inv_gamma_1
1436  endif
1437  where(tmp(ixo^s) < small_e) flag(ixo^s,e_c_) = .true.
1438  else
1439  !neutrals
1440  tmp(ixo^s)=w(ixo^s,e_n_)-&
1441  twofl_kin_en_n(w,ixi^l,ixo^l)
1442  if(has_equi_pe_n0) then
1443  tmp(ixo^s) = tmp(ixo^s)+block%equi_vars(ixo^s,equi_pe_n0_,0)*inv_gamma_1
1444  endif
1445  where(tmp(ixo^s) < small_e) flag(ixo^s,e_n_) = .true.
1446  if(phys_total_energy) then
1447  tmp(ixo^s)=w(ixo^s,e_c_)-&
1448  twofl_kin_en_c(w,ixi^l,ixo^l)-twofl_mag_en(w,ixi^l,ixo^l)
1449  else
1450  tmp(ixo^s)=w(ixo^s,e_c_)-&
1451  twofl_kin_en_c(w,ixi^l,ixo^l)
1452  end if
1453  if(has_equi_pe_c0) then
1454  tmp(ixo^s) = tmp(ixo^s)+block%equi_vars(ixo^s,equi_pe_c0_,0)*inv_gamma_1
1455  endif
1456  where(tmp(ixo^s) < small_e) flag(ixo^s,e_c_) = .true.
1457  end if
1458  endif
1459  end if
1460 
1461  end subroutine twofl_check_w
1462 
1463  !> Transform primitive variables into conservative ones
1464  subroutine twofl_to_conserved(ixI^L,ixO^L,w,x)
1466  integer, intent(in) :: ixi^l, ixo^l
1467  double precision, intent(inout) :: w(ixi^s, nw)
1468  double precision, intent(in) :: x(ixi^s, 1:ndim)
1469  integer :: idir
1470  double precision :: rhoc(ixi^s)
1471  double precision :: rhon(ixi^s)
1472 
1473  !if (fix_small_values) then
1474  ! call twofl_handle_small_values(.true., w, x, ixI^L, ixO^L, 'twofl_to_conserved')
1475  !end if
1476 
1477  call get_rhon_tot(w,x,ixi^l,ixo^l,rhon)
1478  call get_rhoc_tot(w,x,ixi^l,ixo^l,rhoc)
1479 
1480  ! Calculate total energy from pressure, kinetic and magnetic energy
1481  if(phys_energy) then
1482  if(phys_internal_e) then
1483  w(ixo^s,e_n_)=w(ixo^s,e_n_)*inv_gamma_1
1484  w(ixo^s,e_c_)=w(ixo^s,e_c_)*inv_gamma_1
1485  else
1486  w(ixo^s,e_n_)=w(ixo^s,e_n_)*inv_gamma_1&
1487  +half*sum(w(ixo^s,mom_n(:))**2,dim=ndim+1)*rhon(ixo^s)
1488  if(phys_total_energy) then
1489  w(ixo^s,e_c_)=w(ixo^s,e_c_)*inv_gamma_1&
1490  +half*sum(w(ixo^s,mom_c(:))**2,dim=ndim+1)*rhoc(ixo^s)&
1491  +twofl_mag_en(w, ixi^l, ixo^l)
1492  else
1493  ! kinetic energy + internal energy is evolved
1494  w(ixo^s,e_c_)=w(ixo^s,e_c_)*inv_gamma_1&
1495  +half*sum(w(ixo^s,mom_c(:))**2,dim=ndim+1)*rhoc(ixo^s)
1496  end if
1497  end if
1498  end if
1499 
1500  ! Convert velocity to momentum
1501  do idir = 1, ndir
1502  w(ixo^s, mom_n(idir)) = rhon(ixo^s) * w(ixo^s, mom_n(idir))
1503  w(ixo^s, mom_c(idir)) = rhoc(ixo^s) * w(ixo^s, mom_c(idir))
1504  end do
1505  end subroutine twofl_to_conserved
1506 
1507  !> Transform conservative variables into primitive ones
1508  subroutine twofl_to_primitive(ixI^L,ixO^L,w,x)
1510  integer, intent(in) :: ixi^l, ixo^l
1511  double precision, intent(inout) :: w(ixi^s, nw)
1512  double precision, intent(in) :: x(ixi^s, 1:ndim)
1513  integer :: idir
1514  double precision :: rhoc(ixi^s)
1515  double precision :: rhon(ixi^s)
1516 
1517  if (fix_small_values) then
1518  call twofl_handle_small_values(.false., w, x, ixi^l, ixo^l, 'twofl_to_primitive')
1519  end if
1520 
1521  call get_rhon_tot(w,x,ixi^l,ixo^l,rhon)
1522  call get_rhoc_tot(w,x,ixi^l,ixo^l,rhoc)
1523 
1524  if(phys_energy) then
1525  if(phys_internal_e) then
1526  w(ixo^s,e_n_)=w(ixo^s,e_n_)*gamma_1
1527  w(ixo^s,e_c_)=w(ixo^s,e_c_)*gamma_1
1528  else
1529  ! neutrals evolved energy = ke + e_int
1530  w(ixo^s,e_n_)=gamma_1*(w(ixo^s,e_n_)&
1531  -twofl_kin_en_n(w,ixi^l,ixo^l))
1532  ! charges
1533  if(phys_total_energy) then
1534  ! evolved energy = ke + e_int + e_mag
1535  w(ixo^s,e_c_)=gamma_1*(w(ixo^s,e_c_)&
1536  -twofl_kin_en_c(w,ixi^l,ixo^l)&
1537  -twofl_mag_en(w,ixi^l,ixo^l))
1538  else
1539  ! evolved energy = ke + e_int
1540  w(ixo^s,e_c_)=gamma_1*(w(ixo^s,e_c_)&
1541  -twofl_kin_en_c(w,ixi^l,ixo^l))
1542  end if
1543  end if
1544  end if
1545 
1546  ! Convert momentum to velocity
1547  do idir = 1, ndir
1548  w(ixo^s, mom_c(idir)) = w(ixo^s, mom_c(idir))/rhoc(ixo^s)
1549  w(ixo^s, mom_n(idir)) = w(ixo^s, mom_n(idir))/rhon(ixo^s)
1550  end do
1551 
1552  end subroutine twofl_to_primitive
1553 
1554 !!USED IN TC
1555  !> Transform internal energy to total energy
1556  subroutine twofl_ei_to_e_c(ixI^L,ixO^L,w,x)
1558  integer, intent(in) :: ixI^L, ixO^L
1559  double precision, intent(inout) :: w(ixI^S, nw)
1560  double precision, intent(in) :: x(ixI^S, 1:ndim)
1561 
1562  ! Calculate total energy from internal, kinetic and magnetic energy
1563  if(twofl_eq_energy == eq_energy_ki) then
1564  w(ixo^s,e_c_)=w(ixo^s,e_c_)&
1565  +twofl_kin_en_c(w,ixi^l,ixo^l)
1566  else
1567  w(ixo^s,e_c_)=w(ixo^s,e_c_)&
1568  +twofl_kin_en_c(w,ixi^l,ixo^l)&
1569  +twofl_mag_en(w,ixi^l,ixo^l)
1570  endif
1571  end subroutine twofl_ei_to_e_c
1572 
1573  !> Transform total energy to internal energy
1574  subroutine twofl_e_to_ei_c(ixI^L,ixO^L,w,x)
1576  integer, intent(in) :: ixI^L, ixO^L
1577  double precision, intent(inout) :: w(ixI^S, nw)
1578  double precision, intent(in) :: x(ixI^S, 1:ndim)
1579 
1580  if(twofl_eq_energy == eq_energy_ki) then
1581  w(ixo^s,e_c_)=w(ixo^s,e_c_)&
1582  -twofl_kin_en_c(w,ixi^l,ixo^l)
1583  else
1584  ! Calculate ei = e - ek - eb
1585  w(ixo^s,e_c_)=w(ixo^s,e_c_)&
1586  -twofl_kin_en_c(w,ixi^l,ixo^l)&
1587  -twofl_mag_en(w,ixi^l,ixo^l)
1588  endif
1589  end subroutine twofl_e_to_ei_c
1590 
1591  !Neutrals
1592  subroutine twofl_ei_to_e_n(ixI^L,ixO^L,w,x)
1594  integer, intent(in) :: ixI^L, ixO^L
1595  double precision, intent(inout) :: w(ixI^S, nw)
1596  double precision, intent(in) :: x(ixI^S, 1:ndim)
1597 
1598  ! Calculate total energy from internal and kinetic energy
1599 
1600  w(ixo^s,e_n_)=w(ixo^s,e_n_)+twofl_kin_en_n(w,ixi^l,ixo^l)
1601 
1602  end subroutine twofl_ei_to_e_n
1603 
1604  !> Transform total energy to internal energy
1605  subroutine twofl_e_to_ei_n(ixI^L,ixO^L,w,x)
1607  integer, intent(in) :: ixI^L, ixO^L
1608  double precision, intent(inout) :: w(ixI^S, nw)
1609  double precision, intent(in) :: x(ixI^S, 1:ndim)
1610 
1611  ! Calculate ei = e - ek
1612  w(ixo^s,e_n_)=w(ixo^s,e_n_)-twofl_kin_en_n(w,ixi^l,ixo^l)
1613 
1614  call twofl_handle_small_ei_n(w,x,ixi^l,ixo^l,e_n_,"e_to_ei_n")
1615  end subroutine twofl_e_to_ei_n
1616 
1617  subroutine twofl_handle_small_values(primitive, w, x, ixI^L, ixO^L, subname)
1619  use mod_small_values
1620  logical, intent(in) :: primitive
1621  integer, intent(in) :: ixI^L,ixO^L
1622  double precision, intent(inout) :: w(ixI^S,1:nw)
1623  double precision, intent(in) :: x(ixI^S,1:ndim)
1624  character(len=*), intent(in) :: subname
1625 
1626  integer :: idir
1627  logical :: flag(ixI^S,1:nw)
1628  double precision :: tmp2(ixI^S)
1629  double precision :: tmp1(ixI^S)
1630 
1631  call twofl_check_w(primitive, ixi^l, ixo^l, w, flag)
1632 
1633  if(any(flag)) then
1634  select case (small_values_method)
1635  case ("replace")
1636  if(has_equi_rho_c0) then
1637  where(flag(ixo^s,rho_c_)) w(ixo^s,rho_c_) = &
1638  small_density-block%equi_vars(ixo^s,equi_rho_c0_,0)
1639  else
1640  where(flag(ixo^s,rho_c_)) w(ixo^s,rho_c_) = small_density
1641  end if
1642  if(has_equi_rho_n0) then
1643  where(flag(ixo^s,rho_n_)) w(ixo^s,rho_n_) = &
1644  small_density-block%equi_vars(ixo^s,equi_rho_n0_,0)
1645  else
1646  where(flag(ixo^s,rho_n_)) w(ixo^s,rho_n_) = small_density
1647  end if
1648  do idir = 1, ndir
1649  if(small_values_fix_iw(mom_n(idir))) then
1650  where(flag(ixo^s,rho_n_)) w(ixo^s, mom_n(idir)) = 0.0d0
1651  end if
1652  if(small_values_fix_iw(mom_c(idir))) then
1653  where(flag(ixo^s,rho_c_)) w(ixo^s, mom_c(idir)) = 0.0d0
1654  end if
1655  end do
1656 
1657  if(phys_energy) then
1658  if(primitive) then
1659  if(has_equi_pe_n0) then
1660  tmp1(ixo^s) = small_pressure - &
1661  block%equi_vars(ixo^s,equi_pe_n0_,0)
1662  else
1663  tmp1(ixo^s) = small_pressure
1664  end if
1665  if(has_equi_pe_c0) then
1666  tmp2(ixo^s) = small_e - &
1667  block%equi_vars(ixo^s,equi_pe_c0_,0)
1668  else
1669  tmp2(ixo^s) = small_pressure
1670  end if
1671  else
1672  ! conserved
1673  if(has_equi_pe_n0) then
1674  tmp1(ixo^s) = small_e - &
1675  block%equi_vars(ixo^s,equi_pe_n0_,0)*inv_gamma_1
1676  else
1677  tmp1(ixo^s) = small_e
1678  end if
1679  if(has_equi_pe_c0) then
1680  tmp2(ixo^s) = small_e - &
1681  block%equi_vars(ixo^s,equi_pe_c0_,0)*inv_gamma_1
1682  else
1683  tmp2(ixo^s) = small_e
1684  end if
1685  if(phys_internal_e) then
1686  where(flag(ixo^s,e_n_))
1687  w(ixo^s,e_n_)=tmp1(ixo^s)
1688  end where
1689  where(flag(ixo^s,e_c_))
1690  w(ixo^s,e_c_)=tmp2(ixo^s)
1691  end where
1692  else
1693  where(flag(ixo^s,e_n_))
1694  w(ixo^s,e_n_) = tmp1(ixo^s)+&
1695  twofl_kin_en_n(w,ixi^l,ixo^l)
1696  end where
1697  if(phys_total_energy) then
1698  where(flag(ixo^s,e_c_))
1699  w(ixo^s,e_c_) = tmp2(ixo^s)+&
1700  twofl_kin_en_c(w,ixi^l,ixo^l)+&
1701  twofl_mag_en(w,ixi^l,ixo^l)
1702  end where
1703  else
1704  where(flag(ixo^s,e_c_))
1705  w(ixo^s,e_c_) = tmp2(ixo^s)+&
1706  twofl_kin_en_c(w,ixi^l,ixo^l)
1707  end where
1708  end if
1709  end if
1710  end if
1711  end if
1712  case ("average")
1713  call small_values_average(ixi^l, ixo^l, w, x, flag)
1714  case default
1715  if(.not.primitive) then
1716  !convert w to primitive
1717  ! Calculate pressure = (gamma-1) * (e-ek-eb)
1718  if(phys_energy) then
1719  if(phys_internal_e) then
1720  w(ixo^s,e_c_)=w(ixo^s,e_c_)*gamma_1
1721  w(ixo^s,e_n_)=w(ixo^s,e_n_)*gamma_1
1722  else
1723  w(ixo^s,e_n_)=gamma_1*(w(ixo^s,e_n_)&
1724  -twofl_kin_en_n(w,ixi^l,ixo^l))
1725  if(phys_total_energy) then
1726  w(ixo^s,e_c_)=gamma_1*(w(ixo^s,e_c_)&
1727  -twofl_kin_en_c(w,ixi^l,ixo^l)&
1728  -twofl_mag_en(w,ixi^l,ixo^l))
1729  else
1730  w(ixo^s,e_c_)=gamma_1*(w(ixo^s,e_c_)&
1731  -twofl_kin_en_c(w,ixi^l,ixo^l))
1732 
1733  end if
1734  end if
1735  end if
1736  ! Convert momentum to velocity
1737  if(has_equi_rho_n0) then
1738  tmp1(ixo^s) = w(ixo^s,rho_n_) + block%equi_vars(ixo^s,equi_rho_n0_,0)
1739  else
1740  tmp1(ixo^s) = w(ixo^s,rho_n_)
1741  end if
1742 
1743  if(has_equi_rho_c0) then
1744  tmp2(ixo^s) = w(ixo^s,rho_c_) + block%equi_vars(ixo^s,equi_rho_c0_,0)
1745  else
1746  tmp2(ixo^s) = w(ixo^s,rho_c_)
1747  end if
1748  do idir = 1, ndir
1749  w(ixo^s, mom_n(idir)) = w(ixo^s, mom_n(idir))/tmp1(ixo^s)
1750  w(ixo^s, mom_c(idir)) = w(ixo^s, mom_c(idir))/tmp2(ixo^s)
1751  end do
1752  end if
1753  call small_values_error(w, x, ixi^l, ixo^l, flag, subname)
1754  end select
1755  end if
1756  end subroutine twofl_handle_small_values
1757 
1758  !> Calculate cmax_idim=csound+abs(v_idim) within ixO^L
1759  subroutine twofl_get_cmax(w,x,ixI^L,ixO^L,idim,cmax)
1761 
1762  integer, intent(in) :: ixI^L, ixO^L, idim
1763  ! w in primitive form
1764  double precision, intent(in) :: w(ixI^S, nw), x(ixI^S,1:ndim)
1765  double precision, intent(inout) :: cmax(ixI^S)
1766  double precision :: cmax2(ixI^S),rhon(ixI^S)
1767 
1768  call twofl_get_csound_c_idim(w,x,ixi^l,ixo^l,idim,cmax)
1769  call get_rhon_tot(w,x,ixi^l,ixo^l,rhon)
1770  if(phys_energy) then
1771  if(has_equi_pe_n0) then
1772  cmax2(ixo^s)=sqrt(twofl_gamma*(w(ixo^s,e_n_)+&
1773  block%equi_vars(ixo^s,equi_pe_n0_,b0i))/rhon(ixo^s))
1774  else
1775  cmax2(ixo^s)=sqrt(twofl_gamma*w(ixo^s,e_n_)/rhon(ixo^s))
1776  end if
1777  else
1778  cmax2(ixo^s)=sqrt(twofl_gamma*twofl_adiab*rhon(ixo^s)**gamma_1)
1779  end if
1780  cmax(ixo^s)=max(abs(w(ixo^s,mom_n(idim)))+cmax2(ixo^s),&
1781  abs(w(ixo^s,mom_c(idim)))+cmax(ixo^s))
1782 
1783  end subroutine twofl_get_cmax
1784 
1785  subroutine twofl_get_a2max(w,x,ixI^L,ixO^L,a2max)
1787 
1788  integer, intent(in) :: ixI^L, ixO^L
1789  double precision, intent(in) :: w(ixI^S, nw), x(ixI^S,1:ndim)
1790  double precision, intent(inout) :: a2max(ndim)
1791  double precision :: a2(ixI^S,ndim,nw)
1792  integer :: gxO^L,hxO^L,jxO^L,kxO^L,i,j
1793 
1794  a2=zero
1795  do i = 1,ndim
1796  !> 4th order
1797  hxo^l=ixo^l-kr(i,^d);
1798  gxo^l=hxo^l-kr(i,^d);
1799  jxo^l=ixo^l+kr(i,^d);
1800  kxo^l=jxo^l+kr(i,^d);
1801  a2(ixo^s,i,1:nw)=abs(-w(kxo^s,1:nw)+16.d0*w(jxo^s,1:nw)&
1802  -30.d0*w(ixo^s,1:nw)+16.d0*w(hxo^s,1:nw)-w(gxo^s,1:nw))
1803  a2max(i)=maxval(a2(ixo^s,i,1:nw))/12.d0/dxlevel(i)**2
1804  end do
1805  end subroutine twofl_get_a2max
1806 
1807  ! COPIED from hd/moh_hd_phys
1808  !> get adaptive cutoff temperature for TRAC (Johnston 2019 ApJL, 873, L22)
1809  subroutine twofl_get_tcutoff_n(ixI^L,ixO^L,w,x,tco_local,Tmax_local)
1811  integer, intent(in) :: ixI^L,ixO^L
1812  double precision, intent(in) :: x(ixI^S,1:ndim),w(ixI^S,1:nw)
1813  double precision, intent(out) :: tco_local, Tmax_local
1814 
1815  double precision, parameter :: delta=0.25d0
1816  double precision :: tmp1(ixI^S),Te(ixI^S),lts(ixI^S)
1817  integer :: jxO^L,hxO^L
1818  logical :: lrlt(ixI^S)
1819 
1820  {^ifoned
1821  ! reuse lts as rhon
1822  call get_rhon_tot(w,x,ixi^l,ixi^l,lts)
1823  tmp1(ixi^s)=w(ixi^s,e_n_)-0.5d0*sum(w(ixi^s,mom_n(:))**2,dim=ndim+1)/lts(ixi^s)
1824  te(ixi^s)=tmp1(ixi^s)/lts(ixi^s)*(twofl_gamma-1.d0)
1825 
1826  tmax_local=maxval(te(ixo^s))
1827 
1828  hxo^l=ixo^l-1;
1829  jxo^l=ixo^l+1;
1830  lts(ixo^s)=0.5d0*abs(te(jxo^s)-te(hxo^s))/te(ixo^s)
1831  lrlt=.false.
1832  where(lts(ixo^s) > delta)
1833  lrlt(ixo^s)=.true.
1834  end where
1835  tco_local=zero
1836  if(any(lrlt(ixo^s))) then
1837  tco_local=maxval(te(ixo^s), mask=lrlt(ixo^s))
1838  end if
1839  }
1840  end subroutine twofl_get_tcutoff_n
1841 
1842  !> get adaptive cutoff temperature for TRAC (Johnston 2019 ApJL, 873, L22)
1843  subroutine twofl_get_tcutoff_c(ixI^L,ixO^L,w,x,Tco_local,Tmax_local)
1845  use mod_geometry
1846  integer, intent(in) :: ixI^L,ixO^L
1847  double precision, intent(in) :: x(ixI^S,1:ndim)
1848  double precision, intent(inout) :: w(ixI^S,1:nw)
1849  double precision, intent(out) :: Tco_local,Tmax_local
1850 
1851  double precision, parameter :: trac_delta=0.25d0
1852  double precision :: tmp1(ixI^S),Te(ixI^S),lts(ixI^S)
1853  double precision, dimension(ixI^S,1:ndir) :: bunitvec
1854  double precision, dimension(ixI^S,1:ndim) :: gradT
1855  double precision :: Bdir(ndim)
1856  double precision :: ltr(ixI^S),ltrc,ltrp,altr(ixI^S)
1857  integer :: idims,jxO^L,hxO^L,ixA^D,ixB^D
1858  integer :: jxP^L,hxP^L,ixP^L
1859  logical :: lrlt(ixI^S)
1860 
1861  ! reuse lts as rhoc
1862  call get_rhoc_tot(w,x,ixi^l,ixi^l,lts)
1863  if(phys_internal_e) then
1864  tmp1(ixi^s)=w(ixi^s,e_c_)
1865  else
1866  tmp1(ixi^s)=w(ixi^s,e_c_)-0.5d0*(sum(w(ixi^s,mom_c(:))**2,dim=ndim+1)/&
1867  lts(ixi^s)+sum(w(ixi^s,mag(:))**2,dim=ndim+1))
1868  end if
1869  te(ixi^s)=tmp1(ixi^s)/lts(ixi^s)*(twofl_gamma-1.d0)
1870  tmax_local=maxval(te(ixo^s))
1871 
1872  {^ifoned
1873  select case(twofl_trac_type)
1874  case(0)
1875  !> test case, fixed cutoff temperature
1876  w(ixi^s,tcoff_c_)=2.5d5/unit_temperature
1877  case(1)
1878  hxo^l=ixo^l-1;
1879  jxo^l=ixo^l+1;
1880  lts(ixo^s)=0.5d0*abs(te(jxo^s)-te(hxo^s))/te(ixo^s)
1881  lrlt=.false.
1882  where(lts(ixo^s) > trac_delta)
1883  lrlt(ixo^s)=.true.
1884  end where
1885  if(any(lrlt(ixo^s))) then
1886  tco_local=maxval(te(ixo^s), mask=lrlt(ixo^s))
1887  end if
1888  case(2)
1889  !> iijima et al. 2021, LTRAC method
1890  ltrc=1.5d0
1891  ltrp=2.5d0
1892  ixp^l=ixo^l^ladd1;
1893  hxo^l=ixo^l-1;
1894  jxo^l=ixo^l+1;
1895  hxp^l=ixp^l-1;
1896  jxp^l=ixp^l+1;
1897  lts(ixp^s)=0.5d0*abs(te(jxp^s)-te(hxp^s))/te(ixp^s)
1898  ltr(ixp^s)=max(one, (exp(lts(ixp^s))/ltrc)**ltrp)
1899  w(ixo^s,tcoff_c_)=te(ixo^s)*&
1900  (0.25*(ltr(jxo^s)+two*ltr(ixo^s)+ltr(hxo^s)))**0.4d0
1901  case default
1902  call mpistop("twofl_trac_type not allowed for 1D simulation")
1903  end select
1904  }
1905  {^nooned
1906  select case(twofl_trac_type)
1907  case(0)
1908  !> test case, fixed cutoff temperature
1909  w(ixi^s,tcoff_c_)=2.5d5/unit_temperature
1910  case(1,4,6)
1911  ! temperature gradient at cell centers
1912  do idims=1,ndim
1913  call gradient(te,ixi^l,ixo^l,idims,tmp1)
1914  gradt(ixo^s,idims)=tmp1(ixo^s)
1915  end do
1916  ! B vector
1917  if(b0field) then
1918  bunitvec(ixo^s,:)=w(ixo^s,iw_mag(:))+block%B0(ixo^s,:,0)
1919  else
1920  bunitvec(ixo^s,:)=w(ixo^s,iw_mag(:))
1921  end if
1922  if(twofl_trac_type .gt. 1) then
1923  ! B direction at cell center
1924  bdir=zero
1925  {do ixa^d=0,1\}
1926  ixb^d=(ixomin^d+ixomax^d-1)/2+ixa^d;
1927  bdir(1:ndim)=bdir(1:ndim)+bunitvec(ixb^d,1:ndim)
1928  {end do\}
1929  if(sum(bdir(:)**2) .gt. zero) then
1930  bdir(1:ndim)=bdir(1:ndim)/dsqrt(sum(bdir(:)**2))
1931  end if
1932  block%special_values(3:ndim+2)=bdir(1:ndim)
1933  end if
1934  tmp1(ixo^s)=dsqrt(sum(bunitvec(ixo^s,:)**2,dim=ndim+1))
1935  where(tmp1(ixo^s)/=0.d0)
1936  tmp1(ixo^s)=1.d0/tmp1(ixo^s)
1937  elsewhere
1938  tmp1(ixo^s)=bigdouble
1939  end where
1940  ! b unit vector: magnetic field direction vector
1941  do idims=1,ndim
1942  bunitvec(ixo^s,idims)=bunitvec(ixo^s,idims)*tmp1(ixo^s)
1943  end do
1944  ! temperature length scale inversed
1945  lts(ixo^s)=abs(sum(gradt(ixo^s,1:ndim)*bunitvec(ixo^s,1:ndim),dim=ndim+1))/te(ixo^s)
1946  ! fraction of cells size to temperature length scale
1947  if(slab_uniform) then
1948  lts(ixo^s)=minval(dxlevel)*lts(ixo^s)
1949  else
1950  lts(ixo^s)=minval(block%ds(ixo^s,:),dim=ndim+1)*lts(ixo^s)
1951  end if
1952  lrlt=.false.
1953  where(lts(ixo^s) > trac_delta)
1954  lrlt(ixo^s)=.true.
1955  end where
1956  if(any(lrlt(ixo^s))) then
1957  block%special_values(1)=maxval(te(ixo^s), mask=lrlt(ixo^s))
1958  else
1959  block%special_values(1)=zero
1960  end if
1961  block%special_values(2)=tmax_local
1962  case(2)
1963  !> iijima et al. 2021, LTRAC method
1964  ltrc=1.5d0
1965  ltrp=4.d0
1966  ixp^l=ixo^l^ladd1;
1967  ! temperature gradient at cell centers
1968  do idims=1,ndim
1969  call gradient(te,ixi^l,ixp^l,idims,tmp1)
1970  gradt(ixp^s,idims)=tmp1(ixp^s)
1971  end do
1972  ! B vector
1973  if(b0field) then
1974  bunitvec(ixp^s,:)=w(ixp^s,iw_mag(:))+block%B0(ixp^s,:,0)
1975  else
1976  bunitvec(ixp^s,:)=w(ixp^s,iw_mag(:))
1977  end if
1978  tmp1(ixp^s)=dsqrt(sum(bunitvec(ixp^s,:)**2,dim=ndim+1))
1979  where(tmp1(ixp^s)/=0.d0)
1980  tmp1(ixp^s)=1.d0/tmp1(ixp^s)
1981  elsewhere
1982  tmp1(ixp^s)=bigdouble
1983  end where
1984  ! b unit vector: magnetic field direction vector
1985  do idims=1,ndim
1986  bunitvec(ixp^s,idims)=bunitvec(ixp^s,idims)*tmp1(ixp^s)
1987  end do
1988  ! temperature length scale inversed
1989  lts(ixp^s)=abs(sum(gradt(ixp^s,1:ndim)*bunitvec(ixp^s,1:ndim),dim=ndim+1))/te(ixp^s)
1990  ! fraction of cells size to temperature length scale
1991  if(slab_uniform) then
1992  lts(ixp^s)=minval(dxlevel)*lts(ixp^s)
1993  else
1994  lts(ixp^s)=minval(block%ds(ixp^s,:),dim=ndim+1)*lts(ixp^s)
1995  end if
1996  ltr(ixp^s)=max(one, (exp(lts(ixp^s))/ltrc)**ltrp)
1997 
1998  altr(ixi^s)=zero
1999  do idims=1,ndim
2000  hxo^l=ixo^l-kr(idims,^d);
2001  jxo^l=ixo^l+kr(idims,^d);
2002  altr(ixo^s)=altr(ixo^s) &
2003  +0.25*(ltr(hxo^s)+two*ltr(ixo^s)+ltr(jxo^s))*bunitvec(ixo^s,idims)**2
2004  w(ixo^s,tcoff_c_)=te(ixo^s)*altr(ixo^s)**(0.4*ltrp)
2005  end do
2006  case(3,5)
2007  !> do nothing here
2008  case default
2009  call mpistop("unknown twofl_trac_type")
2010  end select
2011  }
2012  end subroutine twofl_get_tcutoff_c
2013 
2014  !> get H speed for H-correction to fix the carbuncle problem at grid-aligned shock front
2015  subroutine twofl_get_h_speed_one(wprim,x,ixI^L,ixO^L,idim,Hspeed)
2017 
2018  integer, intent(in) :: ixI^L, ixO^L, idim
2019  double precision, intent(in) :: wprim(ixI^S, nw)
2020  double precision, intent(in) :: x(ixI^S,1:ndim)
2021  double precision, intent(out) :: Hspeed(ixI^S,1:number_species)
2022 
2023  double precision :: csound(ixI^S,ndim),tmp(ixI^S)
2024  integer :: jxC^L, ixC^L, ixA^L, id, ix^D
2025 
2026  hspeed=0.d0
2027  ixa^l=ixo^l^ladd1;
2028  do id=1,ndim
2029  call twofl_get_csound_prim(wprim,x,ixi^l,ixa^l,id,tmp)
2030  csound(ixa^s,id)=tmp(ixa^s)
2031  end do
2032  ixcmax^d=ixomax^d;
2033  ixcmin^d=ixomin^d+kr(idim,^d)-1;
2034  jxcmax^d=ixcmax^d+kr(idim,^d);
2035  jxcmin^d=ixcmin^d+kr(idim,^d);
2036  hspeed(ixc^s,1)=0.5d0*abs(&
2037  0.5d0 * (wprim(jxc^s,mom_c(idim))+ wprim(jxc^s,mom_n(idim))) &
2038  +csound(jxc^s,idim)- &
2039  0.5d0 * (wprim(ixc^s,mom_c(idim)) + wprim(ixc^s,mom_n(idim)))&
2040  +csound(ixc^s,idim))
2041 
2042  do id=1,ndim
2043  if(id==idim) cycle
2044  ixamax^d=ixcmax^d+kr(id,^d);
2045  ixamin^d=ixcmin^d+kr(id,^d);
2046  hspeed(ixc^s,1)=max(hspeed(ixc^s,1),0.5d0*abs(&
2047  0.5d0 * (wprim(ixa^s,mom_c(id)) + wprim(ixa^s,mom_n(id)))&
2048  +csound(ixa^s,id)-&
2049  0.5d0 * (wprim(ixc^s,mom_c(id)) + wprim(ixc^s,mom_n(id)))&
2050  +csound(ixc^s,id)))
2051 
2052 
2053  ixamax^d=ixcmax^d-kr(id,^d);
2054  ixamin^d=ixcmin^d-kr(id,^d);
2055  hspeed(ixc^s,1)=max(hspeed(ixc^s,1),0.5d0*abs(&
2056  0.5d0 * (wprim(ixc^s,mom_c(id)) + wprim(ixc^s,mom_n(id)))&
2057  +csound(ixc^s,id)-&
2058  0.5d0 * (wprim(ixa^s,mom_c(id)) + wprim(ixa^s,mom_n(id)))&
2059  +csound(ixa^s,id)))
2060 
2061  end do
2062 
2063  do id=1,ndim
2064  if(id==idim) cycle
2065  ixamax^d=jxcmax^d+kr(id,^d);
2066  ixamin^d=jxcmin^d+kr(id,^d);
2067  hspeed(ixc^s,1)=max(hspeed(ixc^s,1),0.5d0*abs(&
2068  0.5d0 * (wprim(ixa^s,mom_c(id)) + wprim(ixa^s,mom_n(id)))&
2069  +csound(ixa^s,id)-&
2070  0.5d0 * (wprim(jxc^s,mom_c(id)) + wprim(jxc^s,mom_n(id)))&
2071  +csound(jxc^s,id)))
2072  ixamax^d=jxcmax^d-kr(id,^d);
2073  ixamin^d=jxcmin^d-kr(id,^d);
2074  hspeed(ixc^s,1)=max(hspeed(ixc^s,1),0.5d0*abs(&
2075  0.5d0 * (wprim(jxc^s,mom_c(id)) + wprim(jxc^s,mom_n(id)))&
2076  +csound(jxc^s,id)-&
2077  0.5d0 * (wprim(ixa^s,mom_c(id)) + wprim(ixa^s,mom_n(id)))&
2078  +csound(ixa^s,id)))
2079  end do
2080 
2081  end subroutine twofl_get_h_speed_one
2082 
2083  !> get H speed for H-correction to fix the carbuncle problem at grid-aligned shock front
2084  subroutine twofl_get_h_speed_species(wprim,x,ixI^L,ixO^L,idim,Hspeed)
2086 
2087  integer, intent(in) :: ixI^L, ixO^L, idim
2088  double precision, intent(in) :: wprim(ixI^S, nw)
2089  double precision, intent(in) :: x(ixI^S,1:ndim)
2090  double precision, intent(out) :: Hspeed(ixI^S,1:number_species)
2091 
2092  double precision :: csound(ixI^S,ndim),tmp(ixI^S)
2093  integer :: jxC^L, ixC^L, ixA^L, id, ix^D
2094 
2095  hspeed=0.d0
2096  ! charges
2097  ixa^l=ixo^l^ladd1;
2098  do id=1,ndim
2099  call twofl_get_csound_prim_c(wprim,x,ixi^l,ixa^l,id,tmp)
2100  csound(ixa^s,id)=tmp(ixa^s)
2101  end do
2102  ixcmax^d=ixomax^d;
2103  ixcmin^d=ixomin^d+kr(idim,^d)-1;
2104  jxcmax^d=ixcmax^d+kr(idim,^d);
2105  jxcmin^d=ixcmin^d+kr(idim,^d);
2106  hspeed(ixc^s,1)=0.5d0*abs(wprim(jxc^s,mom_c(idim))+csound(jxc^s,idim)-wprim(ixc^s,mom_c(idim))+csound(ixc^s,idim))
2107 
2108  do id=1,ndim
2109  if(id==idim) cycle
2110  ixamax^d=ixcmax^d+kr(id,^d);
2111  ixamin^d=ixcmin^d+kr(id,^d);
2112  hspeed(ixc^s,1)=max(hspeed(ixc^s,1),0.5d0*abs(wprim(ixa^s,mom_c(id))+csound(ixa^s,id)-wprim(ixc^s,mom_c(id))+csound(ixc^s,id)))
2113  ixamax^d=ixcmax^d-kr(id,^d);
2114  ixamin^d=ixcmin^d-kr(id,^d);
2115  hspeed(ixc^s,1)=max(hspeed(ixc^s,1),0.5d0*abs(wprim(ixc^s,mom_c(id))+csound(ixc^s,id)-wprim(ixa^s,mom_c(id))+csound(ixa^s,id)))
2116  end do
2117 
2118  do id=1,ndim
2119  if(id==idim) cycle
2120  ixamax^d=jxcmax^d+kr(id,^d);
2121  ixamin^d=jxcmin^d+kr(id,^d);
2122  hspeed(ixc^s,1)=max(hspeed(ixc^s,1),0.5d0*abs(wprim(ixa^s,mom_c(id))+csound(ixa^s,id)-wprim(jxc^s,mom_c(id))+csound(jxc^s,id)))
2123  ixamax^d=jxcmax^d-kr(id,^d);
2124  ixamin^d=jxcmin^d-kr(id,^d);
2125  hspeed(ixc^s,1)=max(hspeed(ixc^s,1),0.5d0*abs(wprim(jxc^s,mom_c(id))+csound(jxc^s,id)-wprim(ixa^s,mom_c(id))+csound(ixa^s,id)))
2126  end do
2127 
2128  ! neutrals
2129  ixa^l=ixo^l^ladd1;
2130  do id=1,ndim
2131  call twofl_get_csound_prim_n(wprim,x,ixi^l,ixa^l,id,tmp)
2132  csound(ixa^s,id)=tmp(ixa^s)
2133  end do
2134  ixcmax^d=ixomax^d;
2135  ixcmin^d=ixomin^d+kr(idim,^d)-1;
2136  jxcmax^d=ixcmax^d+kr(idim,^d);
2137  jxcmin^d=ixcmin^d+kr(idim,^d);
2138  hspeed(ixc^s,2)=0.5d0*abs(wprim(jxc^s,mom_n(idim))+csound(jxc^s,idim)-wprim(ixc^s,mom_n(idim))+csound(ixc^s,idim))
2139 
2140  do id=1,ndim
2141  if(id==idim) cycle
2142  ixamax^d=ixcmax^d+kr(id,^d);
2143  ixamin^d=ixcmin^d+kr(id,^d);
2144  hspeed(ixc^s,2)=max(hspeed(ixc^s,2),0.5d0*abs(wprim(ixa^s,mom_n(id))+csound(ixa^s,id)-wprim(ixc^s,mom_n(id))+csound(ixc^s,id)))
2145  ixamax^d=ixcmax^d-kr(id,^d);
2146  ixamin^d=ixcmin^d-kr(id,^d);
2147  hspeed(ixc^s,2)=max(hspeed(ixc^s,2),0.5d0*abs(wprim(ixc^s,mom_n(id))+csound(ixc^s,id)-wprim(ixa^s,mom_n(id))+csound(ixa^s,id)))
2148  end do
2149 
2150  do id=1,ndim
2151  if(id==idim) cycle
2152  ixamax^d=jxcmax^d+kr(id,^d);
2153  ixamin^d=jxcmin^d+kr(id,^d);
2154  hspeed(ixc^s,2)=max(hspeed(ixc^s,2),0.5d0*abs(wprim(ixa^s,mom_n(id))+csound(ixa^s,id)-wprim(jxc^s,mom_n(id))+csound(jxc^s,id)))
2155  ixamax^d=jxcmax^d-kr(id,^d);
2156  ixamin^d=jxcmin^d-kr(id,^d);
2157  hspeed(ixc^s,2)=max(hspeed(ixc^s,2),0.5d0*abs(wprim(jxc^s,mom_n(id))+csound(jxc^s,id)-wprim(ixa^s,mom_n(id))+csound(ixa^s,id)))
2158  end do
2159 
2160  end subroutine twofl_get_h_speed_species
2161 
2162  !> Estimating bounds for the minimum and maximum signal velocities
2163  subroutine twofl_get_cbounds_one(wLC,wRC,wLp,wRp,x,ixI^L,ixO^L,idim,Hspeed,cmax,cmin)
2166 
2167  integer, intent(in) :: ixI^L, ixO^L, idim
2168  double precision, intent(in) :: wLC(ixI^S, nw), wRC(ixI^S, nw)
2169  double precision, intent(in) :: wLp(ixI^S, nw), wRp(ixI^S, nw)
2170  double precision, intent(in) :: x(ixI^S,1:ndim)
2171  double precision, intent(inout) :: cmax(ixI^S,number_species)
2172  double precision, intent(inout), optional :: cmin(ixI^S,number_species)
2173  double precision, intent(in) :: Hspeed(ixI^S,1:number_species)
2174 
2175  double precision :: wmean(ixI^S,nw)
2176  double precision :: rhon(ixI^S)
2177  double precision :: rhoc(ixI^S)
2178  double precision, dimension(ixI^S) :: umean, dmean, csoundL, csoundR, tmp1,tmp2,tmp3
2179  integer :: ix^D
2180 
2181  select case (boundspeed)
2182  case (1)
2183  ! This implements formula (10.52) from "Riemann Solvers and Numerical
2184  ! Methods for Fluid Dynamics" by Toro.
2185  call get_rhoc_tot(wlp,x,ixi^l,ixo^l,rhoc)
2186  call get_rhon_tot(wlp,x,ixi^l,ixo^l,rhon)
2187  tmp1(ixo^s)=sqrt(abs(rhoc(ixo^s) +rhon(ixo^s)))
2188 
2189  call get_rhoc_tot(wrp,x,ixi^l,ixo^l,rhoc)
2190  call get_rhon_tot(wrp,x,ixi^l,ixo^l,rhon)
2191  tmp2(ixo^s)=sqrt(abs(rhoc(ixo^s) +rhon(ixo^s)))
2192 
2193  tmp3(ixo^s)=1.d0/(tmp1(ixo^s)+tmp2(ixo^s))
2194  umean(ixo^s)=(0.5*(wlp(ixo^s,mom_n(idim))+wlp(ixo^s,mom_c(idim)))*tmp1(ixo^s) + &
2195  0.5*(wrp(ixo^s,mom_n(idim))+wrp(ixo^s,mom_c(idim)))*tmp2(ixo^s))*tmp3(ixo^s)
2196  call twofl_get_csound_prim(wlp,x,ixi^l,ixo^l,idim,csoundl)
2197  call twofl_get_csound_prim(wrp,x,ixi^l,ixo^l,idim,csoundr)
2198 
2199  dmean(ixo^s)=(tmp1(ixo^s)*csoundl(ixo^s)**2+tmp2(ixo^s)*csoundr(ixo^s)**2)*tmp3(ixo^s)+&
2200  0.5d0*tmp1(ixo^s)*tmp2(ixo^s)*tmp3(ixo^s)**2*(&
2201  0.5*(wrp(ixo^s,mom_n(idim))+wrp(ixo^s,mom_c(idim)))- &
2202  0.5*(wlp(ixo^s,mom_n(idim))+wlp(ixo^s,mom_c(idim))))**2
2203  dmean(ixo^s)=sqrt(dmean(ixo^s))
2204  if(present(cmin)) then
2205  cmin(ixo^s,1)=umean(ixo^s)-dmean(ixo^s)
2206  cmax(ixo^s,1)=umean(ixo^s)+dmean(ixo^s)
2207  if(h_correction) then
2208  {do ix^db=ixomin^db,ixomax^db\}
2209  cmin(ix^d,1)=sign(one,cmin(ix^d,1))*max(abs(cmin(ix^d,1)),hspeed(ix^d,1))
2210  cmax(ix^d,1)=sign(one,cmax(ix^d,1))*max(abs(cmax(ix^d,1)),hspeed(ix^d,1))
2211  {end do\}
2212  end if
2213  else
2214  cmax(ixo^s,1)=abs(umean(ixo^s))+dmean(ixo^s)
2215  end if
2216  case (2)
2217  ! typeboundspeed=='cmaxmean'
2218  wmean(ixo^s,1:nwflux)=0.5d0*(wlc(ixo^s,1:nwflux)+wrc(ixo^s,1:nwflux))
2219  call get_rhon_tot(wmean,x,ixi^l,ixo^l,rhon)
2220  tmp2(ixo^s)=wmean(ixo^s,mom_n(idim))/rhon(ixo^s)
2221  call get_rhoc_tot(wmean,x,ixi^l,ixo^l,rhoc)
2222  tmp1(ixo^s)=wmean(ixo^s,mom_c(idim))/rhoc(ixo^s)
2223  call twofl_get_csound(wmean,x,ixi^l,ixo^l,idim,csoundr)
2224  if(present(cmin)) then
2225  cmax(ixo^s,1)=max(max(abs(tmp2(ixo^s)), abs(tmp1(ixo^s)) ) +csoundr(ixo^s),zero)
2226  cmin(ixo^s,1)=min(min(abs(tmp2(ixo^s)), abs(tmp1(ixo^s)) ) -csoundr(ixo^s),zero)
2227  if(h_correction) then
2228  {do ix^db=ixomin^db,ixomax^db\}
2229  cmin(ix^d,1)=sign(one,cmin(ix^d,1))*max(abs(cmin(ix^d,1)),hspeed(ix^d,1))
2230  cmax(ix^d,1)=sign(one,cmax(ix^d,1))*max(abs(cmax(ix^d,1)),hspeed(ix^d,1))
2231  {end do\}
2232  end if
2233  else
2234  cmax(ixo^s,1)= max(abs(tmp2(ixo^s)),abs(tmp1(ixo^s)))+csoundr(ixo^s)
2235  end if
2236  case (3)
2237  ! Miyoshi 2005 JCP 208, 315 equation (67)
2238  call twofl_get_csound(wlp,x,ixi^l,ixo^l,idim,csoundl)
2239  call twofl_get_csound(wrp,x,ixi^l,ixo^l,idim,csoundr)
2240  csoundl(ixo^s)=max(csoundl(ixo^s),csoundr(ixo^s))
2241  if(present(cmin)) then
2242  cmin(ixo^s,1)=min(0.5*(wlp(ixo^s,mom_c(idim))+ wrp(ixo^s,mom_n(idim))),&
2243  0.5*(wrp(ixo^s,mom_c(idim))+ wrp(ixo^s,mom_n(idim))))-csoundl(ixo^s)
2244  cmax(ixo^s,1)=max(0.5*(wlp(ixo^s,mom_c(idim))+ wrp(ixo^s,mom_n(idim))),&
2245  0.5*(wrp(ixo^s,mom_c(idim))+ wrp(ixo^s,mom_n(idim))))+csoundl(ixo^s)
2246  if(h_correction) then
2247  {do ix^db=ixomin^db,ixomax^db\}
2248  cmin(ix^d,1)=sign(one,cmin(ix^d,1))*max(abs(cmin(ix^d,1)),hspeed(ix^d,1))
2249  cmax(ix^d,1)=sign(one,cmax(ix^d,1))*max(abs(cmax(ix^d,1)),hspeed(ix^d,1))
2250  {end do\}
2251  end if
2252  else
2253  cmax(ixo^s,1)=max(0.5*(wlp(ixo^s,mom_c(idim))+ wrp(ixo^s,mom_n(idim))),&
2254  0.5*(wrp(ixo^s,mom_c(idim))+ wrp(ixo^s,mom_n(idim))))+csoundl(ixo^s)
2255  end if
2256  end select
2257 
2258  end subroutine twofl_get_cbounds_one
2259 
2260  !> Calculate fast magnetosonic wave speed
2261  subroutine twofl_get_csound_prim_c(w,x,ixI^L,ixO^L,idim,csound)
2263 
2264  integer, intent(in) :: ixI^L, ixO^L, idim
2265  double precision, intent(in) :: w(ixI^S, nw), x(ixI^S,1:ndim)
2266  double precision, intent(out):: csound(ixI^S)
2267  double precision :: cfast2(ixI^S), AvMinCs2(ixI^S), b2(ixI^S), kmax
2268  double precision :: inv_rho(ixO^S)
2269  double precision :: rhoc(ixI^S)
2270 
2271  integer :: ix1,ix2
2272 
2273 
2274  call get_rhoc_tot(w,x,ixi^l,ixo^l,rhoc)
2275  inv_rho(ixo^s)=1.d0/rhoc(ixo^s)
2276 
2277  if(phys_energy) then
2278  call twofl_get_pthermal_c_primitive(w,x,ixi^l,ixo^l,csound)
2279  csound(ixo^s)=twofl_gamma*csound(ixo^s)/rhoc(ixo^s)
2280  else
2281  call twofl_get_csound2_adiab_c(w,x,ixi^l,ixo^l,csound)
2282  endif
2283 
2284  ! store |B|^2 in v
2285  b2(ixo^s) = twofl_mag_en_all(w,ixi^l,ixo^l)
2286  cfast2(ixo^s) = b2(ixo^s) * inv_rho(ixo^s)+csound(ixo^s)
2287  avmincs2(ixo^s) = cfast2(ixo^s)**2-4.0d0*csound(ixo^s) &
2288  * twofl_mag_i_all(w,ixi^l,ixo^l,idim)**2 &
2289  * inv_rho(ixo^s)
2290 
2291  where(avmincs2(ixo^s)<zero)
2292  avmincs2(ixo^s)=zero
2293  end where
2294 
2295  avmincs2(ixo^s)=sqrt(avmincs2(ixo^s))
2296 
2297  if (.not. twofl_hall) then
2298  csound(ixo^s) = sqrt(half*(cfast2(ixo^s)+avmincs2(ixo^s)))
2299  else
2300  ! take the Hall velocity into account:
2301  ! most simple estimate, high k limit:
2302  ! largest wavenumber supported by grid: Nyquist (in practise can reduce by some factor)
2303  kmax = dpi/min({dxlevel(^d)},bigdouble)*half
2304  csound(ixo^s) = max(sqrt(half*(cfast2(ixo^s)+avmincs2(ixo^s))), &
2305  twofl_etah * sqrt(b2(ixo^s))*inv_rho(ixo^s)*kmax)
2306  end if
2307 
2308  end subroutine twofl_get_csound_prim_c
2309 
2310  !> Calculate fast magnetosonic wave speed
2311  subroutine twofl_get_csound_prim_n(w,x,ixI^L,ixO^L,idim,csound)
2313 
2314  integer, intent(in) :: ixI^L, ixO^L, idim
2315  double precision, intent(in) :: w(ixI^S, nw), x(ixI^S,1:ndim)
2316  double precision, intent(out):: csound(ixI^S)
2317  double precision :: rhon(ixI^S)
2318 
2319  if(phys_energy) then
2320  call get_rhon_tot(w,x,ixi^l,ixo^l,rhon)
2321  call twofl_get_pthermal_n_primitive(w,x,ixi^l,ixo^l,csound)
2322  csound(ixo^s)=twofl_gamma*csound(ixo^s)/rhon(ixo^s)
2323  else
2324  call twofl_get_csound2_adiab_n(w,x,ixi^l,ixo^l,csound)
2325  endif
2326  csound(ixo^s) = sqrt(csound(ixo^s))
2327 
2328  end subroutine twofl_get_csound_prim_n
2329 
2330  !> Estimating bounds for the minimum and maximum signal velocities
2331  subroutine twofl_get_cbounds_species(wLC,wRC,wLp,wRp,x,ixI^L,ixO^L,idim,Hspeed,cmax,cmin)
2334  use mod_variables
2335 
2336  integer, intent(in) :: ixI^L, ixO^L, idim
2337  double precision, intent(in) :: wLC(ixI^S, nw), wRC(ixI^S, nw)
2338  double precision, intent(in) :: wLp(ixI^S, nw), wRp(ixI^S, nw)
2339  double precision, intent(in) :: x(ixI^S,1:ndim)
2340  double precision, intent(inout) :: cmax(ixI^S,1:number_species)
2341  double precision, intent(inout), optional :: cmin(ixI^S,1:number_species)
2342  double precision, intent(in) :: Hspeed(ixI^S,1:number_species)
2343 
2344  double precision :: wmean(ixI^S,nw)
2345  double precision :: rho(ixI^S)
2346  double precision, dimension(ixI^S) :: umean, dmean, csoundL, csoundR, tmp1,tmp2,tmp3
2347  integer :: ix^D
2348 
2349  select case (boundspeed)
2350  case (1)
2351  ! This implements formula (10.52) from "Riemann Solvers and Numerical
2352  ! Methods for Fluid Dynamics" by Toro.
2353  ! charges
2354  call get_rhoc_tot(wlp,x,ixi^l,ixo^l,rho)
2355  tmp1(ixo^s)=sqrt(abs(rho(ixo^s)))
2356 
2357  call get_rhoc_tot(wrp,x,ixi^l,ixo^l,rho)
2358  tmp2(ixo^s)=sqrt(abs(rho(ixo^s)))
2359 
2360  tmp3(ixo^s)=1.d0/(tmp1(ixo^s)+tmp2(ixo^s))
2361  umean(ixo^s)=(wlp(ixo^s,mom_c(idim))*tmp1(ixo^s)+wrp(ixo^s,mom_c(idim))*tmp2(ixo^s))*tmp3(ixo^s)
2362  call twofl_get_csound_prim_c(wlp,x,ixi^l,ixo^l,idim,csoundl)
2363  call twofl_get_csound_prim_c(wrp,x,ixi^l,ixo^l,idim,csoundr)
2364 
2365 
2366  dmean(ixo^s)=(tmp1(ixo^s)*csoundl(ixo^s)**2+tmp2(ixo^s)*csoundr(ixo^s)**2)*tmp3(ixo^s)+&
2367  0.5d0*tmp1(ixo^s)*tmp2(ixo^s)*tmp3(ixo^s)**2*&
2368  (wrp(ixo^s,mom_c(idim)) - wlp(ixo^s,mom_c(idim)))**2
2369  dmean(ixo^s)=sqrt(dmean(ixo^s))
2370  if(present(cmin)) then
2371  cmin(ixo^s,1)=umean(ixo^s)-dmean(ixo^s)
2372  cmax(ixo^s,1)=umean(ixo^s)+dmean(ixo^s)
2373  if(h_correction) then
2374  {do ix^db=ixomin^db,ixomax^db\}
2375  cmin(ix^d,1)=sign(one,cmin(ix^d,1))*max(abs(cmin(ix^d,1)),hspeed(ix^d,1))
2376  cmax(ix^d,1)=sign(one,cmax(ix^d,1))*max(abs(cmax(ix^d,1)),hspeed(ix^d,1))
2377  {end do\}
2378  end if
2379  else
2380  cmax(ixo^s,1)=abs(umean(ixo^s))+dmean(ixo^s)
2381  end if
2382 
2383  ! neutrals
2384 
2385  call get_rhon_tot(wlp,x,ixi^l,ixo^l,rho)
2386  tmp1(ixo^s)=sqrt(abs(rho(ixo^s)))
2387 
2388  call get_rhon_tot(wrp,x,ixi^l,ixo^l,rho)
2389  tmp2(ixo^s)=sqrt(abs(rho(ixo^s)))
2390 
2391  tmp3(ixo^s)=1.d0/(tmp1(ixo^s)+tmp2(ixo^s))
2392  umean(ixo^s)=(wlp(ixo^s,mom_n(idim))*tmp1(ixo^s)+wrp(ixo^s,mom_n(idim))*tmp2(ixo^s))*tmp3(ixo^s)
2393  call twofl_get_csound_prim_n(wlp,x,ixi^l,ixo^l,idim,csoundl)
2394  call twofl_get_csound_prim_n(wrp,x,ixi^l,ixo^l,idim,csoundr)
2395 
2396 
2397  dmean(ixo^s)=(tmp1(ixo^s)*csoundl(ixo^s)**2+tmp2(ixo^s)*csoundr(ixo^s)**2)*tmp3(ixo^s)+&
2398  0.5d0*tmp1(ixo^s)*tmp2(ixo^s)*tmp3(ixo^s)**2*&
2399  (wrp(ixo^s,mom_n(idim)) - wlp(ixo^s,mom_n(idim)))**2
2400  dmean(ixo^s)=sqrt(dmean(ixo^s))
2401  if(present(cmin)) then
2402  cmin(ixo^s,2)=umean(ixo^s)-dmean(ixo^s)
2403  cmax(ixo^s,2)=umean(ixo^s)+dmean(ixo^s)
2404  if(h_correction) then
2405  {do ix^db=ixomin^db,ixomax^db\}
2406  cmin(ix^d,2)=sign(one,cmin(ix^d,2))*max(abs(cmin(ix^d,2)),hspeed(ix^d,2))
2407  cmax(ix^d,2)=sign(one,cmax(ix^d,2))*max(abs(cmax(ix^d,2)),hspeed(ix^d,2))
2408  {end do\}
2409  end if
2410  else
2411  cmax(ixo^s,2)=abs(umean(ixo^s))+dmean(ixo^s)
2412  end if
2413 
2414  case (2)
2415  ! typeboundspeed=='cmaxmean'
2416  wmean(ixo^s,1:nwflux)=0.5d0*(wlp(ixo^s,1:nwflux)+wrp(ixo^s,1:nwflux))
2417  ! charges
2418  tmp1(ixo^s)=wmean(ixo^s,mom_c(idim))
2419  call twofl_get_csound_c_idim(wmean,x,ixi^l,ixo^l,idim,csoundr)
2420  if(present(cmin)) then
2421  cmax(ixo^s,1)=max(abs(tmp1(ixo^s))+csoundr(ixo^s),zero)
2422  cmin(ixo^s,1)=min(abs(tmp1(ixo^s))-csoundr(ixo^s),zero)
2423  if(h_correction) then
2424  {do ix^db=ixomin^db,ixomax^db\}
2425  cmin(ix^d,1)=sign(one,cmin(ix^d,1))*max(abs(cmin(ix^d,1)),hspeed(ix^d,1))
2426  cmax(ix^d,1)=sign(one,cmax(ix^d,1))*max(abs(cmax(ix^d,1)),hspeed(ix^d,1))
2427  {end do\}
2428  end if
2429  else
2430  cmax(ixo^s,1)=abs(tmp1(ixo^s))+csoundr(ixo^s)
2431  end if
2432  !neutrals
2433 
2434  tmp1(ixo^s)=wmean(ixo^s,mom_n(idim))
2435  call twofl_get_csound_n(wmean,x,ixi^l,ixo^l,csoundr)
2436  if(present(cmin)) then
2437  cmax(ixo^s,2)=max(abs(tmp1(ixo^s))+csoundr(ixo^s),zero)
2438  cmin(ixo^s,2)=min(abs(tmp1(ixo^s))-csoundr(ixo^s),zero)
2439  if(h_correction) then
2440  {do ix^db=ixomin^db,ixomax^db\}
2441  cmin(ix^d,2)=sign(one,cmin(ix^d,2))*max(abs(cmin(ix^d,2)),hspeed(ix^d,2))
2442  cmax(ix^d,2)=sign(one,cmax(ix^d,2))*max(abs(cmax(ix^d,2)),hspeed(ix^d,2))
2443  {end do\}
2444  end if
2445  else
2446  cmax(ixo^s,2)= abs(tmp1(ixo^s))+csoundr(ixo^s)
2447  end if
2448  case (3)
2449  ! Miyoshi 2005 JCP 208, 315 equation (67)
2450  call twofl_get_csound_c_idim(wlp,x,ixi^l,ixo^l,idim,csoundl)
2451  call twofl_get_csound_c_idim(wrp,x,ixi^l,ixo^l,idim,csoundr)
2452  csoundl(ixo^s)=max(csoundl(ixo^s),csoundr(ixo^s))
2453  if(present(cmin)) then
2454  cmin(ixo^s,1)=min(wlp(ixo^s,mom_c(idim)),wrp(ixo^s,mom_c(idim)))-csoundl(ixo^s)
2455  cmax(ixo^s,1)=max(wlp(ixo^s,mom_c(idim)),wrp(ixo^s,mom_c(idim)))+csoundl(ixo^s)
2456  if(h_correction) then
2457  {do ix^db=ixomin^db,ixomax^db\}
2458  cmin(ix^d,1)=sign(one,cmin(ix^d,1))*max(abs(cmin(ix^d,1)),hspeed(ix^d,1))
2459  cmax(ix^d,1)=sign(one,cmax(ix^d,1))*max(abs(cmax(ix^d,1)),hspeed(ix^d,1))
2460  {end do\}
2461  end if
2462  else
2463  cmax(ixo^s,1)=max(wlp(ixo^s,mom_c(idim)),wrp(ixo^s,mom_c(idim)))+csoundl(ixo^s)
2464  end if
2465  call twofl_get_csound_n(wlp,x,ixi^l,ixo^l,csoundl)
2466  call twofl_get_csound_n(wrp,x,ixi^l,ixo^l,csoundr)
2467  csoundl(ixo^s)=max(csoundl(ixo^s),csoundr(ixo^s))
2468  if(present(cmin)) then
2469  cmin(ixo^s,2)=min(wlp(ixo^s,mom_n(idim)),wrp(ixo^s,mom_n(idim)))-csoundl(ixo^s)
2470  cmax(ixo^s,2)=max(wlp(ixo^s,mom_n(idim)),wrp(ixo^s,mom_n(idim)))+csoundl(ixo^s)
2471  if(h_correction) then
2472  {do ix^db=ixomin^db,ixomax^db\}
2473  cmin(ix^d,2)=sign(one,cmin(ix^d,2))*max(abs(cmin(ix^d,1)),hspeed(ix^d,2))
2474  cmax(ix^d,2)=sign(one,cmax(ix^d,2))*max(abs(cmax(ix^d,1)),hspeed(ix^d,2))
2475  {end do\}
2476  end if
2477  else
2478  cmax(ixo^s,2)=max(wlp(ixo^s,mom_n(idim)),wrp(ixo^s,mom_n(idim)))+csoundl(ixo^s)
2479  end if
2480 
2481  end select
2482 
2483  end subroutine twofl_get_cbounds_species
2484 
2485  !> prepare velocities for ct methods
2486  subroutine twofl_get_ct_velocity(vcts,wLp,wRp,ixI^L,ixO^L,idim,cmax,cmin)
2488 
2489  integer, intent(in) :: ixI^L, ixO^L, idim
2490  double precision, intent(in) :: wLp(ixI^S, nw), wRp(ixI^S, nw)
2491  double precision, intent(in) :: cmax(ixI^S)
2492  double precision, intent(in), optional :: cmin(ixI^S)
2493  type(ct_velocity), intent(inout):: vcts
2494 
2495  integer :: idimE,idimN
2496 
2497  ! calculate velocities related to different UCT schemes
2498  select case(type_ct)
2499  case('average')
2500  case('uct_contact')
2501  if(.not.allocated(vcts%vnorm)) allocate(vcts%vnorm(ixi^s,1:ndim))
2502  ! get average normal velocity at cell faces
2503  vcts%vnorm(ixo^s,idim)=0.5d0*(wlp(ixo^s,mom_c(idim))+wrp(ixo^s,mom_c(idim)))
2504  case('uct_hll')
2505  if(.not.allocated(vcts%vbarC)) then
2506  allocate(vcts%vbarC(ixi^s,1:ndir,2),vcts%vbarLC(ixi^s,1:ndir,2),vcts%vbarRC(ixi^s,1:ndir,2))
2507  allocate(vcts%cbarmin(ixi^s,1:ndim),vcts%cbarmax(ixi^s,1:ndim))
2508  end if
2509  ! Store magnitude of characteristics
2510  if(present(cmin)) then
2511  vcts%cbarmin(ixo^s,idim)=max(-cmin(ixo^s),zero)
2512  vcts%cbarmax(ixo^s,idim)=max( cmax(ixo^s),zero)
2513  else
2514  vcts%cbarmax(ixo^s,idim)=max( cmax(ixo^s),zero)
2515  vcts%cbarmin(ixo^s,idim)=vcts%cbarmax(ixo^s,idim)
2516  end if
2517 
2518  idimn=mod(idim,ndir)+1 ! 'Next' direction
2519  idime=mod(idim+1,ndir)+1 ! Electric field direction
2520  ! Store velocities
2521  vcts%vbarLC(ixo^s,idim,1)=wlp(ixo^s,mom_c(idimn))
2522  vcts%vbarRC(ixo^s,idim,1)=wrp(ixo^s,mom_c(idimn))
2523  vcts%vbarC(ixo^s,idim,1)=(vcts%cbarmax(ixo^s,idim)*vcts%vbarLC(ixo^s,idim,1) &
2524  +vcts%cbarmin(ixo^s,idim)*vcts%vbarRC(ixo^s,idim,1))&
2525  /(vcts%cbarmax(ixo^s,idim)+vcts%cbarmin(ixo^s,idim))
2526 
2527  vcts%vbarLC(ixo^s,idim,2)=wlp(ixo^s,mom_c(idime))
2528  vcts%vbarRC(ixo^s,idim,2)=wrp(ixo^s,mom_c(idime))
2529  vcts%vbarC(ixo^s,idim,2)=(vcts%cbarmax(ixo^s,idim)*vcts%vbarLC(ixo^s,idim,2) &
2530  +vcts%cbarmin(ixo^s,idim)*vcts%vbarRC(ixo^s,idim,1))&
2531  /(vcts%cbarmax(ixo^s,idim)+vcts%cbarmin(ixo^s,idim))
2532  case default
2533  call mpistop('choose average, uct_contact,or uct_hll for type_ct!')
2534  end select
2535 
2536  end subroutine twofl_get_ct_velocity
2537 
2538  subroutine twofl_get_csound_c_idim(w,x,ixI^L,ixO^L,idim,csound)
2540 
2541  integer, intent(in) :: ixI^L, ixO^L, idim
2542  ! w in primitive form
2543  double precision, intent(in) :: w(ixI^S, nw), x(ixI^S,1:ndim)
2544  double precision, intent(out):: csound(ixI^S)
2545  double precision :: cfast2(ixI^S), AvMinCs2(ixI^S), b2(ixI^S), kmax
2546  double precision :: inv_rho(ixO^S)
2547  double precision :: tmp(ixI^S)
2548 #if (!defined(ONE_FLUID) || ONE_FLUID==0) && (defined(A_TOT) && A_TOT == 1)
2549  double precision :: rhon(ixI^S)
2550 #endif
2551  call get_rhoc_tot(w,x,ixi^l,ixo^l,tmp)
2552 #if (!defined(ONE_FLUID) || ONE_FLUID==0) && (defined(A_TOT) && A_TOT == 1)
2553  call get_rhon_tot(w,x,ixi^l,ixo^l,rhon)
2554  inv_rho(ixo^s) = 1d0/(rhon(ixo^s)+tmp(ixo^s))
2555 #else
2556  inv_rho(ixo^s)=1.d0/tmp(ixo^s)
2557 #endif
2558 
2559  if(phys_energy) then
2560  csound(ixo^s)=twofl_gamma*w(ixo^s,e_c_)*inv_rho(ixo^s)
2561  else
2562  csound(ixo^s)=twofl_gamma*twofl_adiab*tmp(ixo^s)**gamma_1
2563  end if
2564 
2565  ! store |B|^2 in v
2566  b2(ixo^s) = twofl_mag_en_all(w,ixi^l,ixo^l)
2567 
2568  cfast2(ixo^s) = b2(ixo^s) * inv_rho(ixo^s)+csound(ixo^s)
2569  avmincs2(ixo^s) = cfast2(ixo^s)**2-4.0d0*csound(ixo^s) &
2570  * twofl_mag_i_all(w,ixi^l,ixo^l,idim)**2 &
2571  * inv_rho(ixo^s)
2572 
2573  where(avmincs2(ixo^s)<zero)
2574  avmincs2(ixo^s)=zero
2575  end where
2576 
2577  avmincs2(ixo^s)=sqrt(avmincs2(ixo^s))
2578 
2579  if (.not. twofl_hall) then
2580  csound(ixo^s) = sqrt(half*(cfast2(ixo^s)+avmincs2(ixo^s)))
2581  else
2582  ! take the Hall velocity into account:
2583  ! most simple estimate, high k limit:
2584  ! largest wavenumber supported by grid: Nyquist (in practise can reduce by some factor)
2585  kmax = dpi/min({dxlevel(^d)},bigdouble)*half
2586  csound(ixo^s) = max(sqrt(half*(cfast2(ixo^s)+avmincs2(ixo^s))), &
2587  twofl_etah * sqrt(b2(ixo^s))*inv_rho(ixo^s)*kmax)
2588  end if
2589 
2590  end subroutine twofl_get_csound_c_idim
2591 
2592  !> Calculate fast magnetosonic wave speed when cbounds_species=false
2593  subroutine twofl_get_csound_prim(w,x,ixI^L,ixO^L,idim,csound)
2595 
2596  integer, intent(in) :: ixI^L, ixO^L, idim
2597  double precision, intent(in) :: w(ixI^S, nw), x(ixI^S,1:ndim)
2598  double precision, intent(out):: csound(ixI^S)
2599  double precision :: cfast2(ixI^S), AvMinCs2(ixI^S), b2(ixI^S), kmax
2600  double precision :: inv_rho(ixO^S)
2601  double precision :: rhoc(ixI^S)
2602 #if (defined(A_TOT) && A_TOT == 1)
2603  double precision :: rhon(ixI^S)
2604 #endif
2605  call get_rhoc_tot(w,x,ixi^l,ixo^l,rhoc)
2606 #if (defined(A_TOT) && A_TOT == 1)
2607  call get_rhon_tot(w,x,ixi^l,ixo^l,rhon)
2608  inv_rho(ixo^s) = 1d0/(rhon(ixo^s)+rhoc(ixo^s))
2609 #else
2610  inv_rho(ixo^s)=1.d0/rhoc(ixo^s)
2611 #endif
2612 
2613  call twofl_get_csound2_primitive(w,x,ixi^l,ixo^l,csound)
2614 
2615  ! store |B|^2 in v
2616  b2(ixo^s) = twofl_mag_en_all(w,ixi^l,ixo^l)
2617  cfast2(ixo^s) = b2(ixo^s) * inv_rho(ixo^s)+csound(ixo^s)
2618  avmincs2(ixo^s) = cfast2(ixo^s)**2-4.0d0*csound(ixo^s) &
2619  * twofl_mag_i_all(w,ixi^l,ixo^l,idim)**2 &
2620  * inv_rho(ixo^s)
2621 
2622  where(avmincs2(ixo^s)<zero)
2623  avmincs2(ixo^s)=zero
2624  end where
2625 
2626  avmincs2(ixo^s)=sqrt(avmincs2(ixo^s))
2627 
2628  if (.not. twofl_hall) then
2629  csound(ixo^s) = sqrt(half*(cfast2(ixo^s)+avmincs2(ixo^s)))
2630  else
2631  ! take the Hall velocity into account:
2632  ! most simple estimate, high k limit:
2633  ! largest wavenumber supported by grid: Nyquist (in practise can reduce by some factor)
2634  kmax = dpi/min({dxlevel(^d)},bigdouble)*half
2635  csound(ixo^s) = max(sqrt(half*(cfast2(ixo^s)+avmincs2(ixo^s))), &
2636  twofl_etah * sqrt(b2(ixo^s))*inv_rho(ixo^s)*kmax)
2637  end if
2638 
2639  contains
2640  !TODO copy it inside
2641  subroutine twofl_get_csound2_primitive(w,x,ixI^L,ixO^L,csound2)
2643  integer, intent(in) :: ixI^L, ixO^L
2644  double precision, intent(in) :: w(ixI^S,nw)
2645  double precision, intent(in) :: x(ixI^S,1:ndim)
2646  double precision, intent(out) :: csound2(ixI^S)
2647  double precision :: pth_c(ixI^S)
2648  double precision :: pth_n(ixI^S)
2649 
2650  if(phys_energy) then
2651  call twofl_get_pthermal_c_primitive(w,x,ixi^l,ixo^l,pth_c)
2652  call twofl_get_pthermal_n_primitive(w,x,ixi^l,ixo^l,pth_n)
2653  call twofl_get_csound2_from_pthermal(w,x,ixi^l,ixo^l,pth_c,pth_n,csound2)
2654  else
2655  call twofl_get_csound2_adiab(w,x,ixi^l,ixo^l,csound2)
2656  endif
2657  end subroutine twofl_get_csound2_primitive
2658 
2659  end subroutine twofl_get_csound_prim
2660 
2661  subroutine twofl_get_csound2(w,x,ixI^L,ixO^L,csound2)
2663  integer, intent(in) :: ixI^L, ixO^L
2664  double precision, intent(in) :: w(ixI^S,nw)
2665  double precision, intent(in) :: x(ixI^S,1:ndim)
2666  double precision, intent(out) :: csound2(ixI^S)
2667  double precision :: pth_c(ixI^S)
2668  double precision :: pth_n(ixI^S)
2669 
2670  if(phys_energy) then
2671  call twofl_get_pthermal_c(w,x,ixi^l,ixo^l,pth_c)
2672  call twofl_get_pthermal_n(w,x,ixi^l,ixo^l,pth_n)
2673  call twofl_get_csound2_from_pthermal(w,x,ixi^l,ixo^l,pth_c,pth_n,csound2)
2674  else
2675  call twofl_get_csound2_adiab(w,x,ixi^l,ixo^l,csound2)
2676  endif
2677  end subroutine twofl_get_csound2
2678 
2679  subroutine twofl_get_csound2_adiab(w,x,ixI^L,ixO^L,csound2)
2681  integer, intent(in) :: ixI^L, ixO^L
2682  double precision, intent(in) :: w(ixI^S,nw)
2683  double precision, intent(in) :: x(ixI^S,1:ndim)
2684  double precision, intent(out) :: csound2(ixI^S)
2685  double precision :: rhoc(ixI^S)
2686  double precision :: rhon(ixI^S)
2687 
2688  call get_rhoc_tot(w,x,ixi^l,ixo^l,rhoc)
2689  call get_rhon_tot(w,x,ixi^l,ixo^l,rhon)
2690  csound2(ixo^s)=twofl_gamma*twofl_adiab*&
2691  max((rhoc(ixo^s)**twofl_gamma + rhon(ixo^s)**twofl_gamma)/(rhoc(ixo^s)+ rhon(ixo^s)),&
2692  rhon(ixo^s)**gamma_1,rhoc(ixo^s)**gamma_1)
2693  end subroutine twofl_get_csound2_adiab
2694 
2695  subroutine twofl_get_csound(w,x,ixI^L,ixO^L,idim,csound)
2697 
2698  integer, intent(in) :: ixI^L, ixO^L, idim
2699  double precision, intent(in) :: w(ixI^S, nw), x(ixI^S,1:ndim)
2700  double precision, intent(out):: csound(ixI^S)
2701  double precision :: cfast2(ixI^S), AvMinCs2(ixI^S), b2(ixI^S), kmax
2702  double precision :: inv_rho(ixO^S)
2703  double precision :: rhoc(ixI^S)
2704 #if (defined(A_TOT) && A_TOT == 1)
2705  double precision :: rhon(ixI^S)
2706 #endif
2707  call get_rhoc_tot(w,x,ixi^l,ixo^l,rhoc)
2708 #if (defined(A_TOT) && A_TOT == 1)
2709  call get_rhon_tot(w,x,ixi^l,ixo^l,rhon)
2710  inv_rho(ixo^s) = 1d0/(rhon(ixo^s)+rhoc(ixo^s))
2711 #else
2712  inv_rho(ixo^s)=1.d0/rhoc(ixo^s)
2713 #endif
2714 
2715  call twofl_get_csound2(w,x,ixi^l,ixo^l,csound)
2716 
2717  ! store |B|^2 in v
2718  b2(ixo^s) = twofl_mag_en_all(w,ixi^l,ixo^l)
2719 
2720  cfast2(ixo^s) = b2(ixo^s) * inv_rho(ixo^s)+csound(ixo^s)
2721  avmincs2(ixo^s) = cfast2(ixo^s)**2-4.0d0*csound(ixo^s) &
2722  * twofl_mag_i_all(w,ixi^l,ixo^l,idim)**2 &
2723  * inv_rho(ixo^s)
2724 
2725  where(avmincs2(ixo^s)<zero)
2726  avmincs2(ixo^s)=zero
2727  end where
2728 
2729  avmincs2(ixo^s)=sqrt(avmincs2(ixo^s))
2730 
2731  if (.not. twofl_hall) then
2732  csound(ixo^s) = sqrt(half*(cfast2(ixo^s)+avmincs2(ixo^s)))
2733  else
2734  ! take the Hall velocity into account:
2735  ! most simple estimate, high k limit:
2736  ! largest wavenumber supported by grid: Nyquist (in practise can reduce by some factor)
2737  kmax = dpi/min({dxlevel(^d)},bigdouble)*half
2738  csound(ixo^s) = max(sqrt(half*(cfast2(ixo^s)+avmincs2(ixo^s))), &
2739  twofl_etah * sqrt(b2(ixo^s))*inv_rho(ixo^s)*kmax)
2740  end if
2741 
2742  end subroutine twofl_get_csound
2743 
2744  subroutine twofl_get_csound2_from_pthermal(w,x,ixI^L,ixO^L,pth_c,pth_n,csound2)
2746  integer, intent(in) :: ixI^L, ixO^L
2747  double precision, intent(in) :: w(ixI^S,nw)
2748  double precision, intent(in) :: x(ixI^S,1:ndim)
2749  double precision, intent(in) :: pth_c(ixI^S)
2750  double precision, intent(in) :: pth_n(ixI^S)
2751  double precision, intent(out) :: csound2(ixI^S)
2752  double precision :: csound1(ixI^S),rhon(ixI^S),rhoc(ixI^S)
2753 
2754  call get_rhon_tot(w,x,ixi^l,ixo^l,rhon)
2755  call get_rhoc_tot(w,x,ixi^l,ixo^l,rhoc)
2756 #if !defined(C_TOT) || C_TOT == 0
2757  csound2(ixo^s)=twofl_gamma*max((pth_c(ixo^s) + pth_n(ixo^s))/(rhoc(ixo^s) + rhon(ixo^s)),&
2758  pth_n(ixo^s)/rhon(ixo^s), pth_c(ixo^s)/rhoc(ixo^s))
2759 #else
2760  csound2(ixo^s)=twofl_gamma*(csound2(ixo^s) + csound1(ixo^s))/(rhoc(ixo^s) + rhon(ixo^s))
2761 
2762 #endif
2763  end subroutine twofl_get_csound2_from_pthermal
2764 
2765 ! end cbounds_species=false
2766 
2767  subroutine twofl_get_csound_n(w,x,ixI^L,ixO^L,csound)
2769 
2770  integer, intent(in) :: ixI^L, ixO^L
2771  double precision, intent(in) :: w(ixI^S, nw), x(ixI^S,1:ndim)
2772  double precision, intent(out):: csound(ixI^S)
2773  double precision :: pe_n1(ixI^S)
2774  call twofl_get_csound2_n_from_conserved(w,x,ixi^l,ixo^l,csound)
2775  csound(ixo^s) = sqrt(csound(ixo^s))
2776  end subroutine twofl_get_csound_n
2777 
2778  !> separate routines so that it is faster
2779  !> Calculate temperature=p/rho when in e_ the internal energy is stored
2780  subroutine twofl_get_temperature_from_eint_n(w, x, ixI^L, ixO^L, res)
2782  integer, intent(in) :: ixI^L, ixO^L
2783  double precision, intent(in) :: w(ixI^S, 1:nw)
2784  double precision, intent(in) :: x(ixI^S, 1:ndim)
2785  double precision, intent(out):: res(ixI^S)
2786 
2787  res(ixo^s) = 1d0/rn * gamma_1 * w(ixo^s, e_n_) /w(ixo^s,rho_n_)
2788 
2789  end subroutine twofl_get_temperature_from_eint_n
2790 
2791  subroutine twofl_get_temperature_from_eint_n_with_equi(w, x, ixI^L, ixO^L, res)
2793  integer, intent(in) :: ixI^L, ixO^L
2794  double precision, intent(in) :: w(ixI^S, 1:nw)
2795  double precision, intent(in) :: x(ixI^S, 1:ndim)
2796  double precision, intent(out):: res(ixI^S)
2797 
2798  res(ixo^s) = 1d0/rn * (gamma_1 * w(ixo^s, e_n_) + block%equi_vars(ixo^s,equi_pe_n0_,b0i)) /&
2799  (w(ixo^s,rho_n_) +block%equi_vars(ixo^s,equi_rho_n0_,b0i))
2801 
2802 ! subroutine twofl_get_temperature_n_pert_from_tot(Te, ixI^L, ixO^L, res)
2803 ! use mod_global_parameters
2804 ! integer, intent(in) :: ixI^L, ixO^L
2805 ! double precision, intent(in) :: Te(ixI^S)
2806 ! double precision, intent(out):: res(ixI^S)
2807 ! res(ixO^S) = Te(ixO^S) -1d0/Rn * &
2808 ! block%equi_vars(ixO^S,equi_pe_n0_,0)/block%equi_vars(ixO^S,equi_rho_n0_,0)
2809 ! end subroutine twofl_get_temperature_n_pert_from_tot
2810 
2811  subroutine twofl_get_temperature_n_equi(w,x, ixI^L, ixO^L, res)
2813  integer, intent(in) :: ixI^L, ixO^L
2814  double precision, intent(in) :: w(ixI^S, 1:nw)
2815  double precision, intent(in) :: x(ixI^S, 1:ndim)
2816  double precision, intent(out):: res(ixI^S)
2817  res(ixo^s) = 1d0/rn * &
2818  block%equi_vars(ixo^s,equi_pe_n0_,b0i)/block%equi_vars(ixo^s,equi_rho_n0_,b0i)
2819  end subroutine twofl_get_temperature_n_equi
2820 
2821  subroutine twofl_get_rho_n_equi(w, x,ixI^L, ixO^L, res)
2823  integer, intent(in) :: ixI^L, ixO^L
2824  double precision, intent(in) :: w(ixI^S, 1:nw)
2825  double precision, intent(in) :: x(ixI^S, 1:ndim)
2826  double precision, intent(out):: res(ixI^S)
2827  res(ixo^s) = block%equi_vars(ixo^s,equi_rho_n0_,b0i)
2828  end subroutine twofl_get_rho_n_equi
2829 
2830  subroutine twofl_get_pe_n_equi(w, x, ixI^L, ixO^L, res)
2832  integer, intent(in) :: ixI^L, ixO^L
2833  double precision, intent(in) :: w(ixI^S, 1:nw)
2834  double precision, intent(in) :: x(ixI^S, 1:ndim)
2835  double precision, intent(out):: res(ixI^S)
2836  res(ixo^s) = block%equi_vars(ixo^s,equi_pe_n0_,b0i)
2837  end subroutine twofl_get_pe_n_equi
2838 
2839  !> Calculate temperature=p/rho when in e_ the total energy is stored
2840  !> this does not check the values of twofl_energy and twofl_internal_e,
2841  !> twofl_energy = .true. and twofl_internal_e = .false.
2842  !> also check small_values is avoided
2843  subroutine twofl_get_temperature_from_etot_n(w, x, ixI^L, ixO^L, res)
2845  integer, intent(in) :: ixI^L, ixO^L
2846  double precision, intent(in) :: w(ixI^S, 1:nw)
2847  double precision, intent(in) :: x(ixI^S, 1:ndim)
2848  double precision, intent(out):: res(ixI^S)
2849  res(ixo^s)=1d0/rn * (gamma_1*(w(ixo^s,e_n_)&
2850  - twofl_kin_en_n(w,ixi^l,ixo^l)))/w(ixo^s,rho_n_)
2851  end subroutine twofl_get_temperature_from_etot_n
2852 
2853  subroutine twofl_get_temperature_from_etot_n_with_equi(w, x, ixI^L, ixO^L, res)
2855  integer, intent(in) :: ixI^L, ixO^L
2856  double precision, intent(in) :: w(ixI^S, 1:nw)
2857  double precision, intent(in) :: x(ixI^S, 1:ndim)
2858  double precision, intent(out):: res(ixI^S)
2859  res(ixo^s)=1d0/rn * (gamma_1*(w(ixo^s,e_n_)&
2860  - twofl_kin_en_n(w,ixi^l,ixo^l)) + block%equi_vars(ixo^s,equi_pe_n0_,b0i))&
2861  /(w(ixo^s,rho_n_) +block%equi_vars(ixo^s,equi_rho_n0_,b0i))
2862 
2864 
2865  !> separate routines so that it is faster
2866  !> Calculate temperature=p/rho when in e_ the internal energy is stored
2867  subroutine twofl_get_temperature_from_eint_c(w, x, ixI^L, ixO^L, res)
2869  integer, intent(in) :: ixI^L, ixO^L
2870  double precision, intent(in) :: w(ixI^S, 1:nw)
2871  double precision, intent(in) :: x(ixI^S, 1:ndim)
2872  double precision, intent(out):: res(ixI^S)
2873 
2874  res(ixo^s) = 1d0/rc * gamma_1 * w(ixo^s, e_c_) /w(ixo^s,rho_c_)
2875 
2876  end subroutine twofl_get_temperature_from_eint_c
2877 
2878  subroutine twofl_get_temperature_from_eint_c_with_equi(w, x, ixI^L, ixO^L, res)
2880  integer, intent(in) :: ixI^L, ixO^L
2881  double precision, intent(in) :: w(ixI^S, 1:nw)
2882  double precision, intent(in) :: x(ixI^S, 1:ndim)
2883  double precision, intent(out):: res(ixI^S)
2884  res(ixo^s) = 1d0/rc * (gamma_1 * w(ixo^s, e_c_) + block%equi_vars(ixo^s,equi_pe_c0_,b0i)) /&
2885  (w(ixo^s,rho_c_) +block%equi_vars(ixo^s,equi_rho_c0_,b0i))
2887 
2888 ! subroutine twofl_get_temperature_c_pert_from_tot(Te, ixI^L, ixO^L, res)
2889 ! use mod_global_parameters
2890 ! integer, intent(in) :: ixI^L, ixO^L
2891 ! double precision, intent(in) :: Te(ixI^S)
2892 ! double precision, intent(out):: res(ixI^S)
2893 ! res(ixO^S) = Te(ixO^S) -1d0/Rc * &
2894 ! block%equi_vars(ixO^S,equi_pe_c0_,0)/block%equi_vars(ixO^S,equi_rho_c0_,0)
2895 ! end subroutine twofl_get_temperature_c_pert_from_tot
2896 
2897  subroutine twofl_get_temperature_c_equi(w,x, ixI^L, ixO^L, res)
2899  integer, intent(in) :: ixI^L, ixO^L
2900  double precision, intent(in) :: w(ixI^S, 1:nw)
2901  double precision, intent(in) :: x(ixI^S, 1:ndim)
2902  double precision, intent(out):: res(ixI^S)
2903  res(ixo^s) = 1d0/rc * &
2904  block%equi_vars(ixo^s,equi_pe_c0_,b0i)/block%equi_vars(ixo^s,equi_rho_c0_,b0i)
2905  end subroutine twofl_get_temperature_c_equi
2906 
2907  subroutine twofl_get_rho_c_equi(w, x, ixI^L, ixO^L, res)
2909  integer, intent(in) :: ixI^L, ixO^L
2910  double precision, intent(in) :: w(ixI^S, 1:nw)
2911  double precision, intent(in) :: x(ixI^S, 1:ndim)
2912  double precision, intent(out):: res(ixI^S)
2913  res(ixo^s) = block%equi_vars(ixo^s,equi_rho_c0_,b0i)
2914  end subroutine twofl_get_rho_c_equi
2915 
2916  subroutine twofl_get_pe_c_equi(w,x, ixI^L, ixO^L, res)
2918  integer, intent(in) :: ixI^L, ixO^L
2919  double precision, intent(in) :: w(ixI^S, 1:nw)
2920  double precision, intent(in) :: x(ixI^S, 1:ndim)
2921  double precision, intent(out):: res(ixI^S)
2922  res(ixo^s) = block%equi_vars(ixo^s,equi_pe_c0_,b0i)
2923  end subroutine twofl_get_pe_c_equi
2924 
2925  !> Calculate temperature=p/rho when in e_ the total energy is stored
2926  !> this does not check the values of twofl_energy and twofl_internal_e,
2927  !> twofl_energy = .true. and twofl_internal_e = .false.
2928  !> also check small_values is avoided
2929  subroutine twofl_get_temperature_from_etot_c(w, x, ixI^L, ixO^L, res)
2931  integer, intent(in) :: ixI^L, ixO^L
2932  double precision, intent(in) :: w(ixI^S, 1:nw)
2933  double precision, intent(in) :: x(ixI^S, 1:ndim)
2934  double precision, intent(out):: res(ixI^S)
2935  res(ixo^s)=1d0/rc * (gamma_1*(w(ixo^s,e_c_)&
2936  - twofl_kin_en_c(w,ixi^l,ixo^l)&
2937  - twofl_mag_en(w,ixi^l,ixo^l)))/w(ixo^s,rho_c_)
2938  end subroutine twofl_get_temperature_from_etot_c
2939  subroutine twofl_get_temperature_from_eki_c(w, x, ixI^L, ixO^L, res)
2941  integer, intent(in) :: ixI^L, ixO^L
2942  double precision, intent(in) :: w(ixI^S, 1:nw)
2943  double precision, intent(in) :: x(ixI^S, 1:ndim)
2944  double precision, intent(out):: res(ixI^S)
2945  res(ixo^s)=1d0/rc * (gamma_1*(w(ixo^s,e_c_)&
2946  - twofl_kin_en_c(w,ixi^l,ixo^l)))/w(ixo^s,rho_c_)
2947  end subroutine twofl_get_temperature_from_eki_c
2948 
2949  subroutine twofl_get_temperature_from_etot_c_with_equi(w, x, ixI^L, ixO^L, res)
2951  integer, intent(in) :: ixI^L, ixO^L
2952  double precision, intent(in) :: w(ixI^S, 1:nw)
2953  double precision, intent(in) :: x(ixI^S, 1:ndim)
2954  double precision, intent(out):: res(ixI^S)
2955  res(ixo^s)=1d0/rc * (gamma_1*(w(ixo^s,e_c_)&
2956  - twofl_kin_en_c(w,ixi^l,ixo^l)&
2957  - twofl_mag_en(w,ixi^l,ixo^l)) + block%equi_vars(ixo^s,equi_pe_c0_,b0i))&
2958  /(w(ixo^s,rho_c_) +block%equi_vars(ixo^s,equi_rho_c0_,b0i))
2959 
2961 
2962  subroutine twofl_get_temperature_from_eki_c_with_equi(w, x, ixI^L, ixO^L, res)
2964  integer, intent(in) :: ixI^L, ixO^L
2965  double precision, intent(in) :: w(ixI^S, 1:nw)
2966  double precision, intent(in) :: x(ixI^S, 1:ndim)
2967  double precision, intent(out):: res(ixI^S)
2968  res(ixo^s)=1d0/rc * (gamma_1*(w(ixo^s,e_c_)&
2969  - twofl_kin_en_c(w,ixi^l,ixo^l)) + block%equi_vars(ixo^s,equi_pe_c0_,b0i))&
2970  /(w(ixo^s,rho_c_) +block%equi_vars(ixo^s,equi_rho_c0_,b0i))
2971 
2973 
2974  subroutine twofl_get_csound2_adiab_n(w,x,ixI^L,ixO^L,csound2)
2976  integer, intent(in) :: ixI^L, ixO^L
2977  double precision, intent(in) :: w(ixI^S,nw)
2978  double precision, intent(in) :: x(ixI^S,1:ndim)
2979  double precision, intent(out) :: csound2(ixI^S)
2980  double precision :: rhon(ixI^S)
2981 
2982  call get_rhon_tot(w,x,ixi^l,ixo^l,rhon)
2983  csound2(ixo^s)=twofl_gamma*twofl_adiab*rhon(ixo^s)**gamma_1
2984 
2985  end subroutine twofl_get_csound2_adiab_n
2986 
2987  subroutine twofl_get_csound2_n_from_conserved(w,x,ixI^L,ixO^L,csound2)
2989  integer, intent(in) :: ixI^L, ixO^L
2990  double precision, intent(in) :: w(ixI^S,nw)
2991  double precision, intent(in) :: x(ixI^S,1:ndim)
2992  double precision, intent(out) :: csound2(ixI^S)
2993  double precision :: rhon(ixI^S)
2994 
2995  if(phys_energy) then
2996  call get_rhon_tot(w,x,ixi^l,ixo^l,rhon)
2997  call twofl_get_pthermal_n(w,x,ixi^l,ixo^l,csound2)
2998  csound2(ixo^s)=twofl_gamma*csound2(ixo^s)/rhon(ixo^s)
2999  else
3000  call twofl_get_csound2_adiab_n(w,x,ixi^l,ixo^l,csound2)
3001  endif
3002  end subroutine twofl_get_csound2_n_from_conserved
3003 
3004  !! TO DELETE
3005  subroutine twofl_get_csound2_n_from_primitive(w,x,ixI^L,ixO^L,csound2)
3007  integer, intent(in) :: ixI^L, ixO^L
3008  double precision, intent(in) :: w(ixI^S,nw)
3009  double precision, intent(in) :: x(ixI^S,1:ndim)
3010  double precision, intent(out) :: csound2(ixI^S)
3011  double precision :: rhon(ixI^S)
3012 
3013  if(phys_energy) then
3014  call get_rhon_tot(w,x,ixi^l,ixo^l,rhon)
3015  call twofl_get_pthermal_n_primitive(w,x,ixi^l,ixo^l,csound2)
3016  csound2(ixo^s)=twofl_gamma*csound2(ixo^s)/rhon(ixo^s)
3017  else
3018  call twofl_get_csound2_adiab_n(w,x,ixi^l,ixo^l,csound2)
3019  endif
3020  end subroutine twofl_get_csound2_n_from_primitive
3021 
3022  subroutine twofl_get_csound2_adiab_c(w,x,ixI^L,ixO^L,csound2)
3024  integer, intent(in) :: ixI^L, ixO^L
3025  double precision, intent(in) :: w(ixI^S,nw)
3026  double precision, intent(in) :: x(ixI^S,1:ndim)
3027  double precision, intent(out) :: csound2(ixI^S)
3028  double precision :: rhoc(ixI^S)
3029 
3030  call get_rhoc_tot(w,x,ixi^l,ixo^l,rhoc)
3031  csound2(ixo^s)=twofl_gamma*twofl_adiab* rhoc(ixo^s)**gamma_1
3032 
3033  end subroutine twofl_get_csound2_adiab_c
3034 
3035  subroutine twofl_get_csound2_c_from_conserved(w,x,ixI^L,ixO^L,csound2)
3037  integer, intent(in) :: ixi^l, ixo^l
3038  double precision, intent(in) :: w(ixi^s,nw)
3039  double precision, intent(in) :: x(ixi^s,1:ndim)
3040  double precision, intent(out) :: csound2(ixi^s)
3041  double precision :: rhoc(ixi^s)
3042 
3043  if(phys_energy) then
3044  call get_rhoc_tot(w,x,ixi^l,ixo^l,rhoc)
3045  call twofl_get_pthermal_c(w,x,ixi^l,ixo^l,csound2)
3046  csound2(ixo^s)=twofl_gamma*csound2(ixo^s)/rhoc(ixo^s)
3047  else
3048  call twofl_get_csound2_adiab_c(w,x,ixi^l,ixo^l,csound2)
3049  endif
3050  end subroutine twofl_get_csound2_c_from_conserved
3051 
3052  !> Calculate fluxes within ixO^L.
3053  subroutine twofl_get_flux(wC,w,x,ixI^L,ixO^L,idim,f)
3055  use mod_geometry
3056 
3057  integer, intent(in) :: ixI^L, ixO^L, idim
3058  ! conservative w
3059  double precision, intent(in) :: wC(ixI^S,nw)
3060  ! primitive w
3061  double precision, intent(in) :: w(ixI^S,nw)
3062  double precision, intent(in) :: x(ixI^S,1:ndim)
3063  double precision,intent(out) :: f(ixI^S,nwflux)
3064 
3065  double precision :: pgas(ixO^S), ptotal(ixO^S),tmp(ixI^S)
3066  double precision, allocatable:: vHall(:^D&,:)
3067  integer :: idirmin, iw, idir, jdir, kdir
3068 
3069  ! value at the interfaces, idim = block%iw0 --> b0i
3070  ! reuse tmp, used afterwards
3071  ! value at the interface so we can't put momentum
3072  call get_rhoc_tot(w,x,ixi^l,ixo^l,tmp)
3073  ! Get flux of density
3074  f(ixo^s,rho_c_)=w(ixo^s,mom_c(idim))*tmp(ixo^s)
3075  ! pgas is time dependent only
3076  if(phys_energy) then
3077  pgas(ixo^s)=w(ixo^s,e_c_)
3078  else
3079  pgas(ixo^s)=twofl_adiab*tmp(ixo^s)**twofl_gamma
3080  if(has_equi_pe_c0) then
3081  pgas(ixo^s)=pgas(ixo^s)-block%equi_vars(ixo^s,equi_pe_c0_,b0i)
3082  end if
3083  end if
3084 
3085  if (twofl_hall) then
3086  allocate(vhall(ixi^s,1:ndir))
3087  call twofl_getv_hall(w,x,ixi^l,ixo^l,vhall)
3088  end if
3089 
3090  if(b0field) tmp(ixo^s)=sum(block%B0(ixo^s,:,idim)*w(ixo^s,mag(:)),dim=ndim+1)
3091 
3092  ptotal(ixo^s) = pgas(ixo^s) + 0.5d0*sum(w(ixo^s, mag(:))**2, dim=ndim+1)
3093 
3094  ! Get flux of momentum
3095  ! f_i[m_k]=v_i*m_k-b_k*b_i [+ptotal if i==k]
3096  do idir=1,ndir
3097  if(idim==idir) then
3098  f(ixo^s,mom_c(idir))=ptotal(ixo^s)-w(ixo^s,mag(idim))*w(ixo^s,mag(idir))
3099  if(b0field) f(ixo^s,mom_c(idir))=f(ixo^s,mom_c(idir))+tmp(ixo^s)
3100  else
3101  f(ixo^s,mom_c(idir))= -w(ixo^s,mag(idir))*w(ixo^s,mag(idim))
3102  end if
3103  if (b0field) then
3104  f(ixo^s,mom_c(idir))=f(ixo^s,mom_c(idir))&
3105  -w(ixo^s,mag(idir))*block%B0(ixo^s,idim,idim)&
3106  -w(ixo^s,mag(idim))*block%B0(ixo^s,idir,idim)
3107  end if
3108  f(ixo^s,mom_c(idir))=f(ixo^s,mom_c(idir))+w(ixo^s,mom_c(idim))*wc(ixo^s,mom_c(idir))
3109  end do
3110 
3111  ! Get flux of energy
3112  ! f_i[e]=v_i*e+v_i*ptotal-b_i*(b_k*v_k)
3113  if(phys_energy) then
3114  if (phys_internal_e) then
3115  f(ixo^s,e_c_)=w(ixo^s,mom_c(idim))*wc(ixo^s,e_c_)
3116  else if(twofl_eq_energy == eq_energy_ki) then
3117 
3118  f(ixo^s,e_c_)=w(ixo^s,mom_c(idim))*(wc(ixo^s,e_c_)+pgas(ixo^s))
3119  else
3120  f(ixo^s,e_c_)=w(ixo^s,mom_c(idim))*(wc(ixo^s,e_c_)+ptotal(ixo^s))&
3121  -w(ixo^s,mag(idim))*sum(w(ixo^s,mag(:))*w(ixo^s,mom_c(:)),dim=ndim+1)
3122 
3123  if (b0field) then
3124  f(ixo^s,e_c_) = f(ixo^s,e_c_) &
3125  + w(ixo^s,mom_c(idim)) * tmp(ixo^s) &
3126  - sum(w(ixo^s,mom_c(:))*w(ixo^s,mag(:)),dim=ndim+1) * block%B0(ixo^s,idim,idim)
3127  end if
3128 
3129  if (twofl_hall) then
3130  ! f_i[e]= f_i[e] + vHall_i*(b_k*b_k) - b_i*(vHall_k*b_k)
3131  if (twofl_etah>zero) then
3132  f(ixo^s,e_c_) = f(ixo^s,e_c_) + vhall(ixo^s,idim) * &
3133  sum(w(ixo^s, mag(:))**2,dim=ndim+1) &
3134  - w(ixo^s,mag(idim)) * sum(vhall(ixo^s,:)*w(ixo^s,mag(:)),dim=ndim+1)
3135  if (b0field) then
3136  f(ixo^s,e_c_) = f(ixo^s,e_c_) &
3137  + vhall(ixo^s,idim) * tmp(ixo^s) &
3138  - sum(vhall(ixo^s,:)*w(ixo^s,mag(:)),dim=ndim+1) * block%B0(ixo^s,idim,idim)
3139  end if
3140  end if
3141  end if
3142  end if !total_energy
3143  ! add flux of equilibrium internal energy corresponding to pe_c0
3144  if(has_equi_pe_c0) then
3145 #if !defined(E_RM_W0) || E_RM_W0 == 1
3146  f(ixo^s,e_c_)= f(ixo^s,e_c_) &
3147  + w(ixo^s,mom_c(idim)) * block%equi_vars(ixo^s,equi_pe_c0_,idim) * inv_gamma_1
3148 #else
3149  if(phys_internal_e) then
3150  f(ixo^s,e_c_)= f(ixo^s,e_c_) &
3151  + w(ixo^s,mom_c(idim)) * block%equi_vars(ixo^s,equi_pe_c0_,idim) * inv_gamma_1
3152  else
3153  f(ixo^s,e_c_)= f(ixo^s,e_c_) &
3154  + w(ixo^s,mom_c(idim)) * block%equi_vars(ixo^s,equi_pe_c0_,idim) * twofl_gamma * inv_gamma_1
3155  end if
3156 #endif
3157  end if
3158  end if !phys_energy
3159 
3160  ! compute flux of magnetic field
3161  ! f_i[b_k]=v_i*b_k-v_k*b_i
3162  do idir=1,ndir
3163  if (idim==idir) then
3164  ! f_i[b_i] should be exactly 0, so we do not use the transport flux
3165  if (twofl_glm) then
3166  f(ixo^s,mag(idir))=w(ixo^s,psi_)
3167  else
3168  f(ixo^s,mag(idir))=zero
3169  end if
3170  else
3171  f(ixo^s,mag(idir))=w(ixo^s,mom_c(idim))*w(ixo^s,mag(idir))-w(ixo^s,mag(idim))*w(ixo^s,mom_c(idir))
3172 
3173  if (b0field) then
3174  f(ixo^s,mag(idir))=f(ixo^s,mag(idir))&
3175  +w(ixo^s,mom_c(idim))*block%B0(ixo^s,idir,idim)&
3176  -w(ixo^s,mom_c(idir))*block%B0(ixo^s,idim,idim)
3177  end if
3178 
3179  if (twofl_hall) then
3180  ! f_i[b_k] = f_i[b_k] + vHall_i*b_k - vHall_k*b_i
3181  if (twofl_etah>zero) then
3182  if (b0field) then
3183  f(ixo^s,mag(idir)) = f(ixo^s,mag(idir)) &
3184  - vhall(ixo^s,idir)*(w(ixo^s,mag(idim))+block%B0(ixo^s,idim,idim)) &
3185  + vhall(ixo^s,idim)*(w(ixo^s,mag(idir))+block%B0(ixo^s,idir,idim))
3186  else
3187  f(ixo^s,mag(idir)) = f(ixo^s,mag(idir)) &
3188  - vhall(ixo^s,idir)*w(ixo^s,mag(idim)) &
3189  + vhall(ixo^s,idim)*w(ixo^s,mag(idir))
3190  end if
3191  end if
3192  end if
3193 
3194  end if
3195  end do
3196 
3197  if (twofl_glm) then
3198  !f_i[psi]=Ch^2*b_{i} Eq. 24e and Eq. 38c Dedner et al 2002 JCP, 175, 645
3199  f(ixo^s,psi_) = cmax_global**2*w(ixo^s,mag(idim))
3200  end if
3201 
3202  if (twofl_hall) then
3203  deallocate(vhall)
3204  end if
3205 
3206  !!neutrals
3207  call get_rhon_tot(w,x,ixi^l,ixo^l,tmp)
3208  f(ixo^s,rho_n_)=w(ixo^s,mom_n(idim))*tmp(ixo^s)
3209  if(phys_energy) then
3210  pgas(ixo^s) = w(ixo^s, e_n_)
3211  else
3212  pgas(ixo^s)=twofl_adiab*tmp(ixo^s)**twofl_gamma
3213  if(has_equi_pe_n0) then
3214  pgas(ixo^s)=pgas(ixo^s)-block%equi_vars(ixo^s,equi_pe_n0_,b0i)
3215  end if
3216  end if
3217  ! Momentum flux is v_i*m_i, +p in direction idim
3218  do idir = 1, ndir
3219  !if(idim==idir) then
3220  ! f(ixO^S,mom_c(idir)) = pgas(ixO^S)
3221  !else
3222  ! f(ixO^S,mom_c(idir)) = 0.0d0
3223  !end if
3224  !f(ixO^S,mom_c(idir))=f(ixO^S,mom_c(idir))+w(ixO^S,mom_c(idim))*wC(ixO^S,mom_c(idir))
3225  f(ixo^s, mom_n(idir)) = w(ixo^s,mom_n(idim)) * wc(ixo^s, mom_n(idir))
3226  end do
3227 
3228  f(ixo^s, mom_n(idim)) = f(ixo^s, mom_n(idim)) + pgas(ixo^s)
3229 
3230  if(phys_energy) then
3231  !reuse pgas for storing a in the term: div (u_n * a) and make multiplication at the end
3232  pgas(ixo^s) = wc(ixo^s,e_n_)
3233  if(.not. phys_internal_e) then
3234  ! add pressure perturbation
3235  pgas(ixo^s) = pgas(ixo^s) + w(ixo^s,e_n_)
3236  end if
3237  ! add flux of equilibrium internal energy corresponding to pe_n0
3238  if(has_equi_pe_n0) then
3239 #if !defined(E_RM_W0) || E_RM_W0 == 1
3240  pgas(ixo^s) = pgas(ixo^s) + block%equi_vars(ixo^s,equi_pe_n0_,idim) * inv_gamma_1
3241 #else
3242  pgas(ixo^s) = pgas(ixo^s) + block%equi_vars(ixo^s,equi_pe_n0_,idim) * twofl_gamma * inv_gamma_1
3243 #endif
3244  end if
3245  ! add u_n * a in the flux
3246  f(ixo^s, e_n_) = w(ixo^s,mom_n(idim)) * pgas(ixo^s)
3247 
3248  ! Viscosity fluxes - viscInDiv
3249  !if (hd_viscosity) then
3250  ! call visc_get_flux_prim(w, x, ixI^L, ixO^L, idim, f, phys_energy)
3251  !endif
3252  end if
3253 
3254  end subroutine twofl_get_flux
3255 
3256  !> w[iws]=w[iws]+qdt*S[iws,wCT] where S is the source based on wCT within ixO
3257  subroutine twofl_add_source(qdt,dtfactor,ixI^L,ixO^L,wCT,wCTprim,w,x,qsourcesplit,active)
3261  !use mod_gravity, only: gravity_add_source
3262 
3263  integer, intent(in) :: ixI^L, ixO^L
3264  double precision, intent(in) :: qdt,dtfactor
3265  double precision, intent(in) :: wCT(ixI^S,1:nw),wCTprim(ixI^S,1:nw),x(ixI^S,1:ndim)
3266  double precision, intent(inout) :: w(ixI^S,1:nw)
3267  logical, intent(in) :: qsourcesplit
3268  logical, intent(inout) :: active
3269 
3270  if (.not. qsourcesplit) then
3271  ! Source for solving internal energy
3272  if(phys_internal_e) then
3273  active = .true.
3274  call internal_energy_add_source_n(qdt,ixi^l,ixo^l,wct,w,x)
3275  call internal_energy_add_source_c(qdt,ixi^l,ixo^l,wct,w,x,e_c_)
3276  else
3277 #if !defined(E_RM_W0) || E_RM_W0==1
3278  ! add -p0 div v source terms when equi are present
3279  if(has_equi_pe_n0) then
3280  active = .true.
3281  call add_pe_n0_divv(qdt,ixi^l,ixo^l,wct,w,x)
3282  endif
3283  if(has_equi_pe_c0) then
3284  active = .true.
3285  call add_pe_c0_divv(qdt,ixi^l,ixo^l,wct,w,x)
3286  endif
3287 #endif
3288  if(twofl_eq_energy == eq_energy_ki) then
3289  active = .true.
3290  call add_source_lorentz_work(qdt,ixi^l,ixo^l,w,wct,x)
3291  endif
3292  endif
3293 
3294  ! Source for B0 splitting
3295  if (b0field) then
3296  active = .true.
3297  call add_source_b0split(qdt,ixi^l,ixo^l,wct,w,x)
3298  end if
3299 
3300  ! Sources for resistivity in eqs. for e, B1, B2 and B3
3301  if (abs(twofl_eta)>smalldouble)then
3302  active = .true.
3303  call add_source_res2(qdt,ixi^l,ixo^l,wct,w,x)
3304  end if
3305 
3306  if (twofl_eta_hyper>0.d0)then
3307  active = .true.
3308  call add_source_hyperres(qdt,ixi^l,ixo^l,wct,w,x)
3309  end if
3310  !it is not added in a split manner
3311  if(.not. use_imex_scheme .and. has_collisions()) then
3312  active = .true.
3313  call twofl_explicit_coll_terms_update(qdt,ixi^l,ixo^l,w,wct,x)
3314  endif
3315 
3316  if(twofl_hyperdiffusivity) then
3317  active = .true.
3318  call add_source_hyperdiffusive(qdt,ixi^l,ixo^l,w,wct,x)
3319  endif
3320 
3321  end if
3322 
3323  {^nooned
3324  if(source_split_divb .eqv. qsourcesplit) then
3325  ! Sources related to div B
3326  select case (type_divb)
3327  case (divb_none)
3328  ! Do nothing
3329  case (divb_glm)
3330  active = .true.
3331  call add_source_glm(qdt,ixi^l,ixo^l,wct,w,x)
3332  case (divb_powel)
3333  active = .true.
3334  call add_source_powel(qdt,ixi^l,ixo^l,wct,w,x)
3335  case (divb_janhunen)
3336  active = .true.
3337  call add_source_janhunen(qdt,ixi^l,ixo^l,wct,w,x)
3338  case (divb_linde)
3339  active = .true.
3340  call add_source_linde(qdt,ixi^l,ixo^l,wct,w,x)
3341  case (divb_lindejanhunen)
3342  active = .true.
3343  call add_source_linde(qdt,ixi^l,ixo^l,wct,w,x)
3344  call add_source_janhunen(qdt,ixi^l,ixo^l,wct,w,x)
3345  case (divb_lindepowel)
3346  active = .true.
3347  call add_source_linde(qdt,ixi^l,ixo^l,wct,w,x)
3348  call add_source_powel(qdt,ixi^l,ixo^l,wct,w,x)
3349  case (divb_lindeglm)
3350  active = .true.
3351  call add_source_linde(qdt,ixi^l,ixo^l,wct,w,x)
3352  call add_source_glm(qdt,ixi^l,ixo^l,wct,w,x)
3353  case (divb_ct)
3354  continue ! Do nothing
3355  case (divb_multigrid)
3356  continue ! Do nothing
3357  case default
3358  call mpistop('Unknown divB fix')
3359  end select
3360  end if
3361  }
3362 
3363  if(twofl_radiative_cooling_c) then
3364  call radiative_cooling_add_source(qdt,ixi^l,ixo^l,wct,wctprim,&
3365  w,x,qsourcesplit,active,rc_fl_c)
3366  end if
3367  if(twofl_radiative_cooling_n) then
3368  call radiative_cooling_add_source(qdt,ixi^l,ixo^l,wct,wctprim,&
3369  w,x,qsourcesplit,active,rc_fl_n)
3370  end if
3371 !
3372 ! if(twofl_viscosity) then
3373 ! call viscosity_add_source(qdt,ixI^L,ixO^L,wCT,&
3374 ! w,x,phys_energy,qsourcesplit,active)
3375 ! end if
3376 !
3377  if(twofl_gravity) then
3378  call gravity_add_source(qdt,ixi^l,ixo^l,wct,&
3379  w,x,twofl_eq_energy .eq. eq_energy_ki .or. phys_total_energy,qsourcesplit,active)
3380  end if
3381 
3382  end subroutine twofl_add_source
3383 
3384  subroutine add_pe_n0_divv(qdt,ixI^L,ixO^L,wCT,w,x)
3386  use mod_geometry
3387 
3388  integer, intent(in) :: ixI^L, ixO^L
3389  double precision, intent(in) :: qdt
3390  double precision, intent(in) :: wCT(ixI^S,1:nw), x(ixI^S,1:ndim)
3391  double precision, intent(inout) :: w(ixI^S,1:nw)
3392  double precision :: v(ixI^S,1:ndir)
3393 
3394  call twofl_get_v_n(wct,x,ixi^l,ixi^l,v)
3395  call add_geom_pdivv(qdt,ixi^l,ixo^l,v,-block%equi_vars(ixi^s,equi_pe_n0_,0),w,x,e_n_)
3396 
3397  end subroutine add_pe_n0_divv
3398 
3399  subroutine add_pe_c0_divv(qdt,ixI^L,ixO^L,wCT,w,x)
3401  use mod_geometry
3402 
3403  integer, intent(in) :: ixI^L, ixO^L
3404  double precision, intent(in) :: qdt
3405  double precision, intent(in) :: wCT(ixI^S,1:nw), x(ixI^S,1:ndim)
3406  double precision, intent(inout) :: w(ixI^S,1:nw)
3407  double precision :: v(ixI^S,1:ndir)
3408 
3409  call twofl_get_v_c(wct,x,ixi^l,ixi^l,v)
3410  call add_geom_pdivv(qdt,ixi^l,ixo^l,v,-block%equi_vars(ixi^s,equi_pe_c0_,0),w,x,e_c_)
3411 
3412  end subroutine add_pe_c0_divv
3413 
3414  subroutine add_geom_pdivv(qdt,ixI^L,ixO^L,v,p,w,x,ind)
3416  use mod_geometry
3417 
3418  integer, intent(in) :: ixI^L, ixO^L,ind
3419  double precision, intent(in) :: qdt
3420  double precision, intent(in) :: p(ixI^S), v(ixI^S,1:ndir), x(ixI^S,1:ndim)
3421  double precision, intent(inout) :: w(ixI^S,1:nw)
3422  double precision :: divv(ixI^S)
3423 
3424  if(slab_uniform) then
3425  if(nghostcells .gt. 2) then
3426  call divvector(v,ixi^l,ixo^l,divv,sixthorder=.true.)
3427  else
3428  call divvector(v,ixi^l,ixo^l,divv,fourthorder=.true.)
3429  end if
3430  else
3431  call divvector(v,ixi^l,ixo^l,divv)
3432  end if
3433  w(ixo^s,ind)=w(ixo^s,ind)+qdt*p(ixo^s)*divv(ixo^s)
3434  end subroutine add_geom_pdivv
3435 
3436  !> Compute the Lorentz force (JxB)
3437  subroutine get_lorentz(ixI^L,ixO^L,w,JxB)
3439  integer, intent(in) :: ixI^L, ixO^L
3440  double precision, intent(in) :: w(ixI^S,1:nw)
3441  double precision, intent(inout) :: JxB(ixI^S,3)
3442  double precision :: a(ixI^S,3), b(ixI^S,3), tmp(ixI^S,3)
3443  integer :: idir, idirmin
3444  ! For ndir=2 only 3rd component of J can exist, ndir=1 is impossible for MHD
3445  double precision :: current(ixI^S,7-2*ndir:3)
3446 
3447  b=0.0d0
3448  do idir = 1, ndir
3449  b(ixo^s, idir) = twofl_mag_i_all(w, ixi^l, ixo^l,idir)
3450  end do
3451 
3452  ! store J current in a
3453  call get_current(w,ixi^l,ixo^l,idirmin,current)
3454 
3455  a=0.0d0
3456  do idir=7-2*ndir,3
3457  a(ixo^s,idir)=current(ixo^s,idir)
3458  end do
3459 
3460  call cross_product(ixi^l,ixo^l,a,b,jxb)
3461  end subroutine get_lorentz
3462 
3463  subroutine add_source_lorentz_work(qdt,ixI^L,ixO^L,w,wCT,x)
3465  integer, intent(in) :: ixI^L, ixO^L
3466  double precision, intent(in) :: qdt
3467  double precision, intent(in) :: wCT(ixI^S,1:nw), x(ixI^S,1:ndim)
3468  double precision, intent(inout) :: w(ixI^S,1:nw)
3469  double precision :: a(ixI^S,3), b(ixI^S,1:ndir)
3470 
3471  call get_lorentz(ixi^l, ixo^l,wct,a)
3472  call twofl_get_v_c(wct,x,ixi^l,ixo^l,b)
3473  w(ixo^s,e_c_)=w(ixo^s,e_c_)+qdt*sum(a(ixo^s,1:ndir)*b(ixo^s,1:ndir),dim=ndim+1)
3474 
3475  end subroutine add_source_lorentz_work
3476 
3477  !> Calculate v_n vector
3478  subroutine twofl_get_v_n(w,x,ixI^L,ixO^L,v)
3480 
3481  integer, intent(in) :: ixI^L, ixO^L
3482  double precision, intent(in) :: w(ixI^S,nw), x(ixI^S,1:ndim)
3483  double precision, intent(out) :: v(ixI^S,ndir)
3484  double precision :: rhon(ixI^S)
3485  integer :: idir
3486 
3487  call get_rhon_tot(w,x,ixi^l,ixo^l,rhon)
3488 
3489  do idir=1,ndir
3490  v(ixo^s,idir) = w(ixo^s, mom_n(idir)) / rhon(ixo^s)
3491  end do
3492 
3493  end subroutine twofl_get_v_n
3494 
3495  subroutine get_rhon_tot(w,x,ixI^L,ixO^L,rhon)
3497  integer, intent(in) :: ixi^l, ixo^l
3498  double precision, intent(in) :: w(ixi^s,1:nw), x(ixi^s,1:ndim)
3499  double precision, intent(out) :: rhon(ixi^s)
3500  if(has_equi_rho_n0) then
3501  rhon(ixo^s) = w(ixo^s,rho_n_) + block%equi_vars(ixo^s,equi_rho_n0_,b0i)
3502  else
3503  rhon(ixo^s) = w(ixo^s,rho_n_)
3504  endif
3505 
3506  end subroutine get_rhon_tot
3507 
3508  subroutine twofl_get_pthermal_n(w,x,ixI^L,ixO^L,pth)
3511  integer, intent(in) :: ixi^l, ixo^l
3512  double precision, intent(in) :: w(ixi^s,1:nw)
3513  double precision, intent(in) :: x(ixi^s,1:ndim)
3514  double precision, intent(out) :: pth(ixi^s)
3515 
3516  integer :: ix^d, iw
3517 
3518  if(phys_energy) then
3519  if(phys_internal_e) then
3520  pth(ixo^s)=gamma_1*w(ixo^s,e_n_)
3521  else
3522  pth(ixo^s)=gamma_1*(w(ixo^s,e_n_)&
3523  - twofl_kin_en_n(w,ixi^l,ixo^l))
3524  end if
3525  if(has_equi_pe_n0) then
3526  pth(ixo^s) = pth(ixo^s) + block%equi_vars(ixo^s,equi_pe_n0_,b0i)
3527  endif
3528  else
3529  call get_rhon_tot(w,x,ixi^l,ixo^l,pth)
3530  pth(ixo^s)=twofl_adiab*pth(ixo^s)**twofl_gamma
3531  end if
3532 
3533  if (fix_small_values) then
3534  {do ix^db= ixo^lim^db\}
3535  if(pth(ix^d)<small_pressure) then
3536  pth(ix^d)=small_pressure
3537  end if
3538  {enddo^d&\}
3539  else if (check_small_values) then
3540  {do ix^db= ixo^lim^db\}
3541  if(pth(ix^d)<small_pressure) then
3542  write(*,*) "Error: small value of gas pressure",pth(ix^d),&
3543  " encountered when call twofl_get_pthermal_n"
3544  write(*,*) "Iteration: ", it, " Time: ", global_time
3545  write(*,*) "Location: ", x(ix^d,:)
3546  write(*,*) "Cell number: ", ix^d
3547  do iw=1,nw
3548  write(*,*) trim(cons_wnames(iw)),": ",w(ix^d,iw)
3549  end do
3550  ! use erroneous arithmetic operation to crash the run
3551  if(trace_small_values) write(*,*) sqrt(pth(ix^d)-bigdouble)
3552  write(*,*) "Saving status at the previous time step"
3553  crash=.true.
3554  end if
3555  {enddo^d&\}
3556  end if
3557 
3558  end subroutine twofl_get_pthermal_n
3559 
3560  subroutine twofl_get_pthermal_n_primitive(w,x,ixI^L,ixO^L,pth)
3562  integer, intent(in) :: ixI^L, ixO^L
3563  double precision, intent(in) :: w(ixI^S,1:nw)
3564  double precision, intent(in) :: x(ixI^S,1:ndim)
3565  double precision, intent(out) :: pth(ixI^S)
3566 
3567  if(phys_energy) then
3568  if(has_equi_pe_n0) then
3569  pth(ixo^s) = w(ixo^s,e_n_) + block%equi_vars(ixo^s,equi_pe_n0_,b0i)
3570  else
3571  pth(ixo^s) = w(ixo^s,e_n_)
3572  endif
3573  else
3574  call get_rhon_tot(w,x,ixi^l,ixo^l,pth)
3575  pth(ixo^s)=twofl_adiab*pth(ixo^s)**twofl_gamma
3576  end if
3577  end subroutine twofl_get_pthermal_n_primitive
3578 
3579  !> Calculate v component
3580  subroutine twofl_get_v_n_idim(w,x,ixI^L,ixO^L,idim,v)
3582 
3583  integer, intent(in) :: ixi^l, ixo^l, idim
3584  double precision, intent(in) :: w(ixi^s,nw), x(ixi^s,1:ndim)
3585  double precision, intent(out) :: v(ixi^s)
3586  double precision :: rhon(ixi^s)
3587 
3588  call get_rhon_tot(w,x,ixi^l,ixo^l,rhon)
3589  v(ixo^s) = w(ixo^s, mom_n(idim)) / rhon(ixo^s)
3590 
3591  end subroutine twofl_get_v_n_idim
3592 
3593  subroutine internal_energy_add_source_n(qdt,ixI^L,ixO^L,wCT,w,x)
3595  use mod_geometry
3596 
3597  integer, intent(in) :: ixI^L, ixO^L
3598  double precision, intent(in) :: qdt
3599  double precision, intent(in) :: wCT(ixI^S,1:nw), x(ixI^S,1:ndim)
3600  double precision, intent(inout) :: w(ixI^S,1:nw)
3601  double precision :: pth(ixI^S),v(ixI^S,1:ndir),divv(ixI^S)
3602 
3603  call twofl_get_pthermal_n(wct,x,ixi^l,ixo^l,pth)
3604  call twofl_get_v_n(wct,x,ixi^l,ixi^l,v)
3605  call add_geom_pdivv(qdt,ixi^l,ixo^l,v,-pth,w,x,e_n_)
3606 
3607  if(fix_small_values .and. .not. has_equi_pe_n0) then
3608  call twofl_handle_small_ei_n(w,x,ixi^l,ixo^l,e_n_,'internal_energy_add_source')
3609  end if
3610  end subroutine internal_energy_add_source_n
3611 
3612  !> Calculate v_c vector
3613  subroutine twofl_get_v_c(w,x,ixI^L,ixO^L,v)
3615 
3616  integer, intent(in) :: ixI^L, ixO^L
3617  double precision, intent(in) :: w(ixI^S,nw), x(ixI^S,1:ndim)
3618  double precision, intent(out) :: v(ixI^S,ndir)
3619  double precision :: rhoc(ixI^S)
3620  integer :: idir
3621 
3622  call get_rhoc_tot(w,x,ixi^l,ixo^l,rhoc)
3623  do idir=1,ndir
3624  v(ixo^s,idir) = w(ixo^s, mom_c(idir)) / rhoc(ixo^s)
3625  end do
3626 
3627  end subroutine twofl_get_v_c
3628 
3629  subroutine get_rhoc_tot(w,x,ixI^L,ixO^L,rhoc)
3631  integer, intent(in) :: ixi^l, ixo^l
3632  double precision, intent(in) :: w(ixi^s,1:nw), x(ixi^s,1:ndim)
3633  double precision, intent(out) :: rhoc(ixi^s)
3634  if(has_equi_rho_c0) then
3635  rhoc(ixo^s) = w(ixo^s,rho_c_) + block%equi_vars(ixo^s,equi_rho_c0_,b0i)
3636  else
3637  rhoc(ixo^s) = w(ixo^s,rho_c_)
3638  endif
3639 
3640  end subroutine get_rhoc_tot
3641 
3642  subroutine twofl_get_pthermal_c(w,x,ixI^L,ixO^L,pth)
3645  integer, intent(in) :: ixi^l, ixo^l
3646  double precision, intent(in) :: w(ixi^s,1:nw)
3647  double precision, intent(in) :: x(ixi^s,1:ndim)
3648  double precision, intent(out) :: pth(ixi^s)
3649  integer :: ix^d, iw
3650 
3651  if(phys_energy) then
3652  if(phys_internal_e) then
3653  pth(ixo^s)=gamma_1*w(ixo^s,e_c_)
3654  elseif(phys_total_energy) then
3655  pth(ixo^s)=gamma_1*(w(ixo^s,e_c_)&
3656  - twofl_kin_en_c(w,ixi^l,ixo^l)&
3657  - twofl_mag_en(w,ixi^l,ixo^l))
3658  else
3659  pth(ixo^s)=gamma_1*(w(ixo^s,e_c_)&
3660  - twofl_kin_en_c(w,ixi^l,ixo^l))
3661  end if
3662  if(has_equi_pe_c0) then
3663  pth(ixo^s) = pth(ixo^s) + block%equi_vars(ixo^s,equi_pe_c0_,b0i)
3664  endif
3665  else
3666  call get_rhoc_tot(w,x,ixi^l,ixo^l,pth)
3667  pth(ixo^s)=twofl_adiab*pth(ixo^s)**twofl_gamma
3668  end if
3669 
3670  if (fix_small_values) then
3671  {do ix^db= ixo^lim^db\}
3672  if(pth(ix^d)<small_pressure) then
3673  pth(ix^d)=small_pressure
3674  end if
3675  {enddo^d&\}
3676  else if (check_small_values) then
3677  {do ix^db= ixo^lim^db\}
3678  if(pth(ix^d)<small_pressure) then
3679  write(*,*) "Error: small value of gas pressure",pth(ix^d),&
3680  " encountered when call twofl_get_pe_c1"
3681  write(*,*) "Iteration: ", it, " Time: ", global_time
3682  write(*,*) "Location: ", x(ix^d,:)
3683  write(*,*) "Cell number: ", ix^d
3684  do iw=1,nw
3685  write(*,*) trim(cons_wnames(iw)),": ",w(ix^d,iw)
3686  end do
3687  ! use erroneous arithmetic operation to crash the run
3688  if(trace_small_values) write(*,*) sqrt(pth(ix^d)-bigdouble)
3689  write(*,*) "Saving status at the previous time step"
3690  crash=.true.
3691  end if
3692  {enddo^d&\}
3693  end if
3694 
3695  end subroutine twofl_get_pthermal_c
3696 
3697  subroutine twofl_get_pthermal_c_primitive(w,x,ixI^L,ixO^L,pth)
3699  integer, intent(in) :: ixI^L, ixO^L
3700  double precision, intent(in) :: w(ixI^S,1:nw)
3701  double precision, intent(in) :: x(ixI^S,1:ndim)
3702  double precision, intent(out) :: pth(ixI^S)
3703 
3704  if(phys_energy) then
3705  if(has_equi_pe_c0) then
3706  pth(ixo^s) = w(ixo^s,e_c_) + block%equi_vars(ixo^s,equi_pe_c0_,b0i)
3707  else
3708  pth(ixo^s) = w(ixo^s,e_c_)
3709  endif
3710  else
3711  call get_rhoc_tot(w,x,ixi^l,ixo^l,pth)
3712  pth(ixo^s)=twofl_adiab*pth(ixo^s)**twofl_gamma
3713  end if
3714  end subroutine twofl_get_pthermal_c_primitive
3715 
3716  !> Calculate v_c component
3717  subroutine twofl_get_v_c_idim(w,x,ixI^L,ixO^L,idim,v)
3719 
3720  integer, intent(in) :: ixi^l, ixo^l, idim
3721  double precision, intent(in) :: w(ixi^s,nw), x(ixi^s,1:ndim)
3722  double precision, intent(out) :: v(ixi^s)
3723  double precision :: rhoc(ixi^s)
3724 
3725  call get_rhoc_tot(w,x,ixi^l,ixo^l,rhoc)
3726  v(ixo^s) = w(ixo^s, mom_c(idim)) / rhoc(ixo^s)
3727 
3728  end subroutine twofl_get_v_c_idim
3729 
3730  subroutine internal_energy_add_source_c(qdt,ixI^L,ixO^L,wCT,w,x,ie)
3732  use mod_geometry
3733 
3734  integer, intent(in) :: ixI^L, ixO^L,ie
3735  double precision, intent(in) :: qdt
3736  double precision, intent(in) :: wCT(ixI^S,1:nw), x(ixI^S,1:ndim)
3737  double precision, intent(inout) :: w(ixI^S,1:nw)
3738  double precision :: pth(ixI^S),v(ixI^S,1:ndir),divv(ixI^S)
3739 
3740  call twofl_get_pthermal_c(wct,x,ixi^l,ixo^l,pth)
3741  call twofl_get_v_c(wct,x,ixi^l,ixi^l,v)
3742  call add_geom_pdivv(qdt,ixi^l,ixo^l,v,-pth,w,x,ie)
3743  if(fix_small_values .and. .not. has_equi_pe_c0) then
3744  call twofl_handle_small_ei_c(w,x,ixi^l,ixo^l,ie,'internal_energy_add_source')
3745  end if
3746  end subroutine internal_energy_add_source_c
3747 
3748  !> handle small or negative internal energy
3749  subroutine twofl_handle_small_ei_c(w, x, ixI^L, ixO^L, ie, subname)
3751  use mod_small_values
3752  integer, intent(in) :: ixI^L,ixO^L, ie
3753  double precision, intent(inout) :: w(ixI^S,1:nw)
3754  double precision, intent(in) :: x(ixI^S,1:ndim)
3755  character(len=*), intent(in) :: subname
3756 
3757  integer :: idir
3758  logical :: flag(ixI^S,1:nw)
3759  double precision :: rhoc(ixI^S)
3760  double precision :: rhon(ixI^S)
3761 
3762  flag=.false.
3763  if(has_equi_pe_c0) then
3764  where(w(ixo^s,ie)+block%equi_vars(ixo^s,equi_pe_c0_,0)*inv_gamma_1<small_e)&
3765  flag(ixo^s,ie)=.true.
3766  else
3767  where(w(ixo^s,ie)<small_e) flag(ixo^s,ie)=.true.
3768  endif
3769  if(any(flag(ixo^s,ie))) then
3770  select case (small_values_method)
3771  case ("replace")
3772  if(has_equi_pe_c0) then
3773  where(flag(ixo^s,ie)) w(ixo^s,ie)=small_e - &
3774  block%equi_vars(ixo^s,equi_pe_c0_,0)*inv_gamma_1
3775  else
3776  where(flag(ixo^s,ie)) w(ixo^s,ie)=small_e
3777  endif
3778  case ("average")
3779  call small_values_average(ixi^l, ixo^l, w, x, flag, ie)
3780  case default
3781  ! small values error shows primitive variables
3782  ! to_primitive subroutine cannot be used as this error handling
3783  ! is also used in TC where e_to_ei is explicitly called
3784  w(ixo^s,e_n_)=w(ixo^s,e_n_)*gamma_1
3785  call get_rhon_tot(w,x,ixi^l,ixo^l,rhon)
3786  w(ixo^s,e_c_)=w(ixo^s,e_c_)*gamma_1
3787  call get_rhoc_tot(w,x,ixi^l,ixo^l,rhoc)
3788  do idir = 1, ndir
3789  w(ixo^s, mom_n(idir)) = w(ixo^s, mom_n(idir))/rhon(ixo^s)
3790  w(ixo^s, mom_c(idir)) = w(ixo^s, mom_c(idir))/rhoc(ixo^s)
3791  end do
3792  call small_values_error(w, x, ixi^l, ixo^l, flag, subname)
3793  end select
3794  end if
3795 
3796  end subroutine twofl_handle_small_ei_c
3797 
3798  !> handle small or negative internal energy
3799  subroutine twofl_handle_small_ei_n(w, x, ixI^L, ixO^L, ie, subname)
3801  use mod_small_values
3802  integer, intent(in) :: ixI^L,ixO^L, ie
3803  double precision, intent(inout) :: w(ixI^S,1:nw)
3804  double precision, intent(in) :: x(ixI^S,1:ndim)
3805  character(len=*), intent(in) :: subname
3806 
3807  integer :: idir
3808  logical :: flag(ixI^S,1:nw)
3809  double precision :: rhoc(ixI^S)
3810  double precision :: rhon(ixI^S)
3811 
3812  flag=.false.
3813  if(has_equi_pe_n0) then
3814  where(w(ixo^s,ie)+block%equi_vars(ixo^s,equi_pe_n0_,0)*inv_gamma_1<small_e)&
3815  flag(ixo^s,ie)=.true.
3816  else
3817  where(w(ixo^s,ie)<small_e) flag(ixo^s,ie)=.true.
3818  endif
3819  if(any(flag(ixo^s,ie))) then
3820  select case (small_values_method)
3821  case ("replace")
3822  if(has_equi_pe_n0) then
3823  where(flag(ixo^s,ie)) w(ixo^s,ie)=small_e - &
3824  block%equi_vars(ixo^s,equi_pe_n0_,0)*inv_gamma_1
3825  else
3826  where(flag(ixo^s,ie)) w(ixo^s,ie)=small_e
3827  endif
3828  case ("average")
3829  call small_values_average(ixi^l, ixo^l, w, x, flag, ie)
3830  case default
3831  ! small values error shows primitive variables
3832  w(ixo^s,e_n_)=w(ixo^s,e_n_)*gamma_1
3833  call get_rhon_tot(w,x,ixi^l,ixo^l,rhon)
3834  w(ixo^s,e_c_)=w(ixo^s,e_c_)*gamma_1
3835  call get_rhoc_tot(w,x,ixi^l,ixo^l,rhoc)
3836  do idir = 1, ndir
3837  w(ixo^s, mom_n(idir)) = w(ixo^s, mom_n(idir))/rhon(ixo^s)
3838  w(ixo^s, mom_c(idir)) = w(ixo^s, mom_c(idir))/rhoc(ixo^s)
3839  end do
3840  call small_values_error(w, x, ixi^l, ixo^l, flag, subname)
3841  end select
3842  end if
3843 
3844  end subroutine twofl_handle_small_ei_n
3845 
3846  !> Source terms after split off time-independent magnetic field
3847  subroutine add_source_b0split(qdt,ixI^L,ixO^L,wCT,w,x)
3849 
3850  integer, intent(in) :: ixI^L, ixO^L
3851  double precision, intent(in) :: qdt, wCT(ixI^S,1:nw), x(ixI^S,1:ndim)
3852  double precision, intent(inout) :: w(ixI^S,1:nw)
3853 
3854  double precision :: a(ixI^S,3), b(ixI^S,3), axb(ixI^S,3)
3855  integer :: idir
3856 
3857  a=0.d0
3858  b=0.d0
3859  ! for force-free field J0xB0 =0
3860  if(.not.b0field_forcefree) then
3861  ! store B0 magnetic field in b
3862  b(ixo^s,1:ndir)=block%B0(ixo^s,1:ndir,0)
3863 
3864  ! store J0 current in a
3865  do idir=7-2*ndir,3
3866  a(ixo^s,idir)=block%J0(ixo^s,idir)
3867  end do
3868  call cross_product(ixi^l,ixo^l,a,b,axb)
3869  axb(ixo^s,:)=axb(ixo^s,:)*qdt
3870  ! add J0xB0 source term in momentum equations
3871  w(ixo^s,mom_c(1:ndir))=w(ixo^s,mom_c(1:ndir))+axb(ixo^s,1:ndir)
3872  end if
3873 
3874  if(phys_total_energy) then
3875  a=0.d0
3876  ! for free-free field -(vxB0) dot J0 =0
3877  b(ixo^s,:)=wct(ixo^s,mag(:))
3878  ! store full magnetic field B0+B1 in b
3879  if(.not.b0field_forcefree) b(ixo^s,:)=b(ixo^s,:)+block%B0(ixo^s,:,0)
3880  ! store velocity in a
3881  do idir=1,ndir
3882  call twofl_get_v_c_idim(wct,x,ixi^l,ixo^l,idir,a(ixi^s,idir))
3883  end do
3884  call cross_product(ixi^l,ixo^l,a,b,axb)
3885  axb(ixo^s,:)=axb(ixo^s,:)*qdt
3886  ! add -(vxB) dot J0 source term in energy equation
3887  do idir=7-2*ndir,3
3888  w(ixo^s,e_c_)=w(ixo^s,e_c_)-axb(ixo^s,idir)*block%J0(ixo^s,idir)
3889  end do
3890  end if
3891 
3892  if (fix_small_values) call twofl_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_B0')
3893 
3894  end subroutine add_source_b0split
3895 
3896  !> Add resistive source to w within ixO Uses 3 point stencil (1 neighbour) in
3897  !> each direction, non-conservative. If the fourthorder precompiler flag is
3898  !> set, uses fourth order central difference for the laplacian. Then the
3899  !> stencil is 5 (2 neighbours).
3900  subroutine add_source_res1(qdt,ixI^L,ixO^L,wCT,w,x)
3902  use mod_usr_methods
3903  use mod_geometry
3904 
3905  integer, intent(in) :: ixI^L, ixO^L
3906  double precision, intent(in) :: qdt
3907  double precision, intent(in) :: wCT(ixI^S,1:nw), x(ixI^S,1:ndim)
3908  double precision, intent(inout) :: w(ixI^S,1:nw)
3909  integer :: ixA^L,idir,jdir,kdir,idirmin,idim,jxO^L,hxO^L,ix
3910  integer :: lxO^L, kxO^L
3911 
3912  double precision :: tmp(ixI^S),tmp2(ixI^S)
3913 
3914  ! For ndir=2 only 3rd component of J can exist, ndir=1 is impossible for MHD
3915  double precision :: current(ixI^S,7-2*ndir:3),eta(ixI^S)
3916  double precision :: gradeta(ixI^S,1:ndim), Bf(ixI^S,1:ndir)
3917 
3918  ! Calculating resistive sources involve one extra layer
3919  if (twofl_4th_order) then
3920  ixa^l=ixo^l^ladd2;
3921  else
3922  ixa^l=ixo^l^ladd1;
3923  end if
3924 
3925  if (iximin^d>ixamin^d.or.iximax^d<ixamax^d|.or.) &
3926  call mpistop("Error in add_source_res1: Non-conforming input limits")
3927 
3928  ! Calculate current density and idirmin
3929  call get_current(wct,ixi^l,ixo^l,idirmin,current)
3930 
3931  if (twofl_eta>zero)then
3932  eta(ixa^s)=twofl_eta
3933  gradeta(ixo^s,1:ndim)=zero
3934  else
3935  call usr_special_resistivity(wct,ixi^l,ixa^l,idirmin,x,current,eta)
3936  ! assumes that eta is not function of current?
3937  do idim=1,ndim
3938  call gradient(eta,ixi^l,ixo^l,idim,tmp)
3939  gradeta(ixo^s,idim)=tmp(ixo^s)
3940  end do
3941  end if
3942 
3943  if(b0field) then
3944  bf(ixi^s,1:ndir)=wct(ixi^s,mag(1:ndir))+block%B0(ixi^s,1:ndir,0)
3945  else
3946  bf(ixi^s,1:ndir)=wct(ixi^s,mag(1:ndir))
3947  end if
3948 
3949  do idir=1,ndir
3950  ! Put B_idir into tmp2 and eta*Laplace B_idir into tmp
3951  if (twofl_4th_order) then
3952  tmp(ixo^s)=zero
3953  tmp2(ixi^s)=bf(ixi^s,idir)
3954  do idim=1,ndim
3955  lxo^l=ixo^l+2*kr(idim,^d);
3956  jxo^l=ixo^l+kr(idim,^d);
3957  hxo^l=ixo^l-kr(idim,^d);
3958  kxo^l=ixo^l-2*kr(idim,^d);
3959  tmp(ixo^s)=tmp(ixo^s)+&
3960  (-tmp2(lxo^s)+16.0d0*tmp2(jxo^s)-30.0d0*tmp2(ixo^s)+16.0d0*tmp2(hxo^s)-tmp2(kxo^s)) &
3961  /(12.0d0 * dxlevel(idim)**2)
3962  end do
3963  else
3964  tmp(ixo^s)=zero
3965  tmp2(ixi^s)=bf(ixi^s,idir)
3966  do idim=1,ndim
3967  jxo^l=ixo^l+kr(idim,^d);
3968  hxo^l=ixo^l-kr(idim,^d);
3969  tmp(ixo^s)=tmp(ixo^s)+&
3970  (tmp2(jxo^s)-2.0d0*tmp2(ixo^s)+tmp2(hxo^s))/dxlevel(idim)**2
3971  end do
3972  end if
3973 
3974  ! Multiply by eta
3975  tmp(ixo^s)=tmp(ixo^s)*eta(ixo^s)
3976 
3977  ! Subtract grad(eta) x J = eps_ijk d_j eta J_k if eta is non-constant
3978  if (twofl_eta<zero)then
3979  do jdir=1,ndim; do kdir=idirmin,3
3980  if (lvc(idir,jdir,kdir)/=0)then
3981  if (lvc(idir,jdir,kdir)==1)then
3982  tmp(ixo^s)=tmp(ixo^s)-gradeta(ixo^s,jdir)*current(ixo^s,kdir)
3983  else
3984  tmp(ixo^s)=tmp(ixo^s)+gradeta(ixo^s,jdir)*current(ixo^s,kdir)
3985  end if
3986  end if
3987  end do; end do
3988  end if
3989 
3990  ! Add sources related to eta*laplB-grad(eta) x J to B and e
3991  w(ixo^s,mag(idir))=w(ixo^s,mag(idir))+qdt*tmp(ixo^s)
3992  if (phys_total_energy) then
3993  w(ixo^s,e_c_)=w(ixo^s,e_c_)+qdt*tmp(ixo^s)*bf(ixo^s,idir)
3994  end if
3995  end do ! idir
3996 
3997  if (phys_energy) then
3998  ! de/dt+=eta*J**2
3999  w(ixo^s,e_c_)=w(ixo^s,e_c_)+qdt*eta(ixo^s)*sum(current(ixo^s,:)**2,dim=ndim+1)
4000  end if
4001 
4002  if (fix_small_values) call twofl_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_res1')
4003 
4004  end subroutine add_source_res1
4005 
4006  !> Add resistive source to w within ixO
4007  !> Uses 5 point stencil (2 neighbours) in each direction, conservative
4008  subroutine add_source_res2(qdt,ixI^L,ixO^L,wCT,w,x)
4010  use mod_usr_methods
4011  use mod_geometry
4012 
4013  integer, intent(in) :: ixI^L, ixO^L
4014  double precision, intent(in) :: qdt
4015  double precision, intent(in) :: wCT(ixI^S,1:nw), x(ixI^S,1:ndim)
4016  double precision, intent(inout) :: w(ixI^S,1:nw)
4017 
4018  ! For ndir=2 only 3rd component of J can exist, ndir=1 is impossible for MHD
4019  double precision :: current(ixI^S,7-2*ndir:3),eta(ixI^S),curlj(ixI^S,1:3)
4020  double precision :: tmpvec(ixI^S,1:3),tmp(ixO^S)
4021  integer :: ixA^L,idir,idirmin,idirmin1
4022 
4023  ixa^l=ixo^l^ladd2;
4024 
4025  if (iximin^d>ixamin^d.or.iximax^d<ixamax^d|.or.) &
4026  call mpistop("Error in add_source_res2: Non-conforming input limits")
4027 
4028  ixa^l=ixo^l^ladd1;
4029  ! Calculate current density within ixL: J=curl B, thus J_i=eps_ijk*d_j B_k
4030  ! Determine exact value of idirmin while doing the loop.
4031  call get_current(wct,ixi^l,ixa^l,idirmin,current)
4032 
4033  if (twofl_eta>zero)then
4034  eta(ixa^s)=twofl_eta
4035  else
4036  call usr_special_resistivity(wct,ixi^l,ixa^l,idirmin,x,current,eta)
4037  end if
4038 
4039  ! dB/dt= -curl(J*eta), thus B_i=B_i-eps_ijk d_j Jeta_k
4040  tmpvec(ixa^s,1:ndir)=zero
4041  do idir=idirmin,3
4042  tmpvec(ixa^s,idir)=current(ixa^s,idir)*eta(ixa^s)
4043  end do
4044  curlj=0.d0
4045  call curlvector(tmpvec,ixi^l,ixo^l,curlj,idirmin1,1,3)
4046  if(stagger_grid.and.ndim==2.and.ndir==3) then
4047  ! if 2.5D
4048  w(ixo^s,mag(ndir)) = w(ixo^s,mag(ndir))-qdt*curlj(ixo^s,ndir)
4049  else
4050  w(ixo^s,mag(1:ndir)) = w(ixo^s,mag(1:ndir))-qdt*curlj(ixo^s,1:ndir)
4051  end if
4052 
4053  if(phys_energy) then
4054  if(phys_total_energy) then
4055  ! de/dt= +div(B x Jeta) = eta J^2 - B dot curl(eta J)
4056  ! de1/dt= eta J^2 - B1 dot curl(eta J)
4057  w(ixo^s,e_c_)=w(ixo^s,e_c_)+qdt*(eta(ixo^s)*sum(current(ixo^s,:)**2,dim=ndim+1)-&
4058  sum(wct(ixo^s,mag(1:ndir))*curlj(ixo^s,1:ndir),dim=ndim+1))
4059  else
4060  ! add eta*J**2 source term in the internal energy equation
4061  w(ixo^s,e_c_)=w(ixo^s,e_c_)+qdt*eta(ixo^s)*sum(current(ixo^s,:)**2,dim=ndim+1)
4062  end if
4063 
4064  end if
4065 
4066  if (fix_small_values) call twofl_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_res2')
4067  end subroutine add_source_res2
4068 
4069  !> Add Hyper-resistive source to w within ixO
4070  !> Uses 9 point stencil (4 neighbours) in each direction.
4071  subroutine add_source_hyperres(qdt,ixI^L,ixO^L,wCT,w,x)
4073  use mod_geometry
4074 
4075  integer, intent(in) :: ixI^L, ixO^L
4076  double precision, intent(in) :: qdt
4077  double precision, intent(in) :: wCT(ixI^S,1:nw), x(ixI^S,1:ndim)
4078  double precision, intent(inout) :: w(ixI^S,1:nw)
4079  !.. local ..
4080  double precision :: current(ixI^S,7-2*ndir:3)
4081  double precision :: tmpvec(ixI^S,1:3),tmpvec2(ixI^S,1:3),tmp(ixI^S),ehyper(ixI^S,1:3)
4082  integer :: ixA^L,idir,jdir,kdir,idirmin,idirmin1
4083 
4084  ixa^l=ixo^l^ladd3;
4085  if (iximin^d>ixamin^d.or.iximax^d<ixamax^d|.or.) &
4086  call mpistop("Error in add_source_hyperres: Non-conforming input limits")
4087 
4088  call get_current(wct,ixi^l,ixa^l,idirmin,current)
4089  tmpvec(ixa^s,1:ndir)=zero
4090  do jdir=idirmin,3
4091  tmpvec(ixa^s,jdir)=current(ixa^s,jdir)
4092  end do
4093 
4094  ixa^l=ixo^l^ladd2;
4095  call curlvector(tmpvec,ixi^l,ixa^l,tmpvec2,idirmin1,1,3)
4096 
4097  ixa^l=ixo^l^ladd1;
4098  tmpvec(ixa^s,1:ndir)=zero
4099  call curlvector(tmpvec2,ixi^l,ixa^l,tmpvec,idirmin1,1,3)
4100  ehyper(ixa^s,1:ndir) = - tmpvec(ixa^s,1:ndir)*twofl_eta_hyper
4101 
4102  ixa^l=ixo^l;
4103  tmpvec2(ixa^s,1:ndir)=zero
4104  call curlvector(ehyper,ixi^l,ixa^l,tmpvec2,idirmin1,1,3)
4105 
4106  do idir=1,ndir
4107  w(ixo^s,mag(idir)) = w(ixo^s,mag(idir))-tmpvec2(ixo^s,idir)*qdt
4108  end do
4109 
4110  if (phys_energy) then
4111  ! de/dt= +div(B x Ehyper)
4112  ixa^l=ixo^l^ladd1;
4113  tmpvec2(ixa^s,1:ndir)=zero
4114  do idir=1,ndir; do jdir=1,ndir; do kdir=idirmin,3
4115  tmpvec2(ixa^s,idir) = tmpvec(ixa^s,idir)&
4116  + lvc(idir,jdir,kdir)*wct(ixa^s,mag(jdir))*ehyper(ixa^s,kdir)
4117  end do; end do; end do
4118  tmp(ixo^s)=zero
4119  call divvector(tmpvec2,ixi^l,ixo^l,tmp)
4120  w(ixo^s,e_c_)=w(ixo^s,e_c_)+tmp(ixo^s)*qdt
4121  end if
4122 
4123  if (fix_small_values) call twofl_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_hyperres')
4124 
4125  end subroutine add_source_hyperres
4126 
4127  subroutine add_source_glm(qdt,ixI^L,ixO^L,wCT,w,x)
4128  ! Add divB related sources to w within ixO
4129  ! corresponding to Dedner JCP 2002, 175, 645 _equation 24_
4130  ! giving the EGLM-MHD scheme
4132  use mod_geometry
4133 
4134  integer, intent(in) :: ixI^L, ixO^L
4135  double precision, intent(in) :: qdt, wCT(ixI^S,1:nw), x(ixI^S,1:ndim)
4136  double precision, intent(inout) :: w(ixI^S,1:nw)
4137  double precision:: divb(ixI^S)
4138  integer :: idim,idir
4139  double precision :: gradPsi(ixI^S)
4140 
4141  ! We calculate now div B
4142  call get_divb(wct,ixi^l,ixo^l,divb, twofl_divb_4thorder)
4143 
4144  ! dPsi/dt = - Ch^2/Cp^2 Psi
4145  if (twofl_glm_alpha < zero) then
4146  w(ixo^s,psi_) = abs(twofl_glm_alpha)*wct(ixo^s,psi_)
4147  else
4148  ! implicit update of Psi variable
4149  ! equation (27) in Mignone 2010 J. Com. Phys. 229, 2117
4150  if(slab_uniform) then
4151  w(ixo^s,psi_) = dexp(-qdt*cmax_global*twofl_glm_alpha/minval(dxlevel(:)))*w(ixo^s,psi_)
4152  else
4153  w(ixo^s,psi_) = dexp(-qdt*cmax_global*twofl_glm_alpha/minval(block%ds(ixo^s,:),dim=ndim+1))*w(ixo^s,psi_)
4154  end if
4155  end if
4156 
4157  ! gradient of Psi
4158  do idim=1,ndim
4159  select case(typegrad)
4160  case("central")
4161  call gradient(wct(ixi^s,psi_),ixi^l,ixo^l,idim,gradpsi)
4162  case("limited")
4163  call gradients(wct(ixi^s,psi_),ixi^l,ixo^l,idim,gradpsi)
4164  end select
4165  if (phys_total_energy) then
4166  ! e = e -qdt (b . grad(Psi))
4167  w(ixo^s,e_c_) = w(ixo^s,e_c_)-qdt*wct(ixo^s,mag(idim))*gradpsi(ixo^s)
4168  end if
4169  end do
4170 
4171  ! m = m - qdt b div b
4172  do idir=1,ndir
4173  w(ixo^s,mom_c(idir))=w(ixo^s,mom_c(idir))-qdt*twofl_mag_i_all(w,ixi^l,ixo^l,idir)*divb(ixo^s)
4174  end do
4175 
4176  if (fix_small_values) call twofl_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_glm')
4177 
4178  end subroutine add_source_glm
4179 
4180  !> Add divB related sources to w within ixO corresponding to Powel
4181  subroutine add_source_powel(qdt,ixI^L,ixO^L,wCT,w,x)
4183 
4184  integer, intent(in) :: ixI^L, ixO^L
4185  double precision, intent(in) :: qdt, wCT(ixI^S,1:nw), x(ixI^S,1:ndim)
4186  double precision, intent(inout) :: w(ixI^S,1:nw)
4187  double precision :: divb(ixI^S),v(ixI^S,1:ndir)
4188  integer :: idir
4189 
4190  ! We calculate now div B
4191  call get_divb(wct,ixi^l,ixo^l,divb, twofl_divb_4thorder)
4192 
4193  ! calculate velocity
4194  call twofl_get_v_c(wct,x,ixi^l,ixo^l,v)
4195 
4196  if (phys_total_energy) then
4197  ! e = e - qdt (v . b) * div b
4198  w(ixo^s,e_c_)=w(ixo^s,e_c_)-&
4199  qdt*sum(v(ixo^s,:)*wct(ixo^s,mag(:)),dim=ndim+1)*divb(ixo^s)
4200  end if
4201 
4202  ! b = b - qdt v * div b
4203  do idir=1,ndir
4204  w(ixo^s,mag(idir))=w(ixo^s,mag(idir))-qdt*v(ixo^s,idir)*divb(ixo^s)
4205  end do
4206 
4207  ! m = m - qdt b div b
4208  do idir=1,ndir
4209  w(ixo^s,mom_c(idir))=w(ixo^s,mom_c(idir))-qdt*twofl_mag_i_all(w,ixi^l,ixo^l,idir)*divb(ixo^s)
4210  end do
4211 
4212  if (fix_small_values) call twofl_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_powel')
4213 
4214  end subroutine add_source_powel
4215 
4216  subroutine add_source_janhunen(qdt,ixI^L,ixO^L,wCT,w,x)
4217  ! Add divB related sources to w within ixO
4218  ! corresponding to Janhunen, just the term in the induction equation.
4220 
4221  integer, intent(in) :: ixI^L, ixO^L
4222  double precision, intent(in) :: qdt, wCT(ixI^S,1:nw), x(ixI^S,1:ndim)
4223  double precision, intent(inout) :: w(ixI^S,1:nw)
4224  double precision :: divb(ixI^S),vel(ixI^S)
4225  integer :: idir
4226 
4227  ! We calculate now div B
4228  call get_divb(wct,ixi^l,ixo^l,divb, twofl_divb_4thorder)
4229 
4230  ! b = b - qdt v * div b
4231  do idir=1,ndir
4232  call twofl_get_v_c_idim(wct,x,ixi^l,ixo^l,idir,vel)
4233  w(ixo^s,mag(idir))=w(ixo^s,mag(idir))-qdt*vel(ixo^s)*divb(ixo^s)
4234  end do
4235 
4236  if (fix_small_values) call twofl_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_janhunen')
4237 
4238  end subroutine add_source_janhunen
4239 
4240  subroutine add_source_linde(qdt,ixI^L,ixO^L,wCT,w,x)
4241  ! Add Linde's divB related sources to wnew within ixO
4243  use mod_geometry
4244 
4245  integer, intent(in) :: ixI^L, ixO^L
4246  double precision, intent(in) :: qdt, wCT(ixI^S,1:nw), x(ixI^S,1:ndim)
4247  double precision, intent(inout) :: w(ixI^S,1:nw)
4248  integer :: idim, idir, ixp^L, i^D, iside
4249  double precision :: divb(ixI^S),graddivb(ixI^S)
4250  logical, dimension(-1:1^D&) :: leveljump
4251 
4252  ! Calculate div B
4253  ixp^l=ixo^l^ladd1;
4254  call get_divb(wct,ixi^l,ixp^l,divb, twofl_divb_4thorder)
4255 
4256  ! for AMR stability, retreat one cell layer from the boarders of level jump
4257  {do i^db=-1,1\}
4258  if(i^d==0|.and.) cycle
4259  if(neighbor_type(i^d,block%igrid)==2 .or. neighbor_type(i^d,block%igrid)==4) then
4260  leveljump(i^d)=.true.
4261  else
4262  leveljump(i^d)=.false.
4263  end if
4264  {end do\}
4265 
4266  ixp^l=ixo^l;
4267  do idim=1,ndim
4268  select case(idim)
4269  {case(^d)
4270  do iside=1,2
4271  i^dd=kr(^dd,^d)*(2*iside-3);
4272  if (leveljump(i^dd)) then
4273  if (iside==1) then
4274  ixpmin^d=ixomin^d-i^d
4275  else
4276  ixpmax^d=ixomax^d-i^d
4277  end if
4278  end if
4279  end do
4280  \}
4281  end select
4282  end do
4283 
4284  ! Add Linde's diffusive terms
4285  do idim=1,ndim
4286  ! Calculate grad_idim(divb)
4287  select case(typegrad)
4288  case("central")
4289  call gradient(divb,ixi^l,ixp^l,idim,graddivb)
4290  case("limited")
4291  call gradients(divb,ixi^l,ixp^l,idim,graddivb)
4292  end select
4293 
4294  ! Multiply by Linde's eta*dt = divbdiff*(c_max*dx)*dt = divbdiff*dx**2
4295  if (slab_uniform) then
4296  graddivb(ixp^s)=graddivb(ixp^s)*divbdiff/(^d&1.0d0/dxlevel(^d)**2+)
4297  else
4298  graddivb(ixp^s)=graddivb(ixp^s)*divbdiff &
4299  /(^d&1.0d0/block%ds(ixp^s,^d)**2+)
4300  end if
4301 
4302  w(ixp^s,mag(idim))=w(ixp^s,mag(idim))+graddivb(ixp^s)
4303 
4304  if (typedivbdiff=='all' .and. phys_total_energy) then
4305  ! e += B_idim*eta*grad_idim(divb)
4306  w(ixp^s,e_c_)=w(ixp^s,e_c_)+wct(ixp^s,mag(idim))*graddivb(ixp^s)
4307  end if
4308  end do
4309 
4310  if (fix_small_values) call twofl_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_linde')
4311 
4312  end subroutine add_source_linde
4313 
4314 
4315  !> get dimensionless div B = |divB| * volume / area / |B|
4316  subroutine get_normalized_divb(w,ixI^L,ixO^L,divb)
4317 
4319 
4320  integer, intent(in) :: ixi^l, ixo^l
4321  double precision, intent(in) :: w(ixi^s,1:nw)
4322  double precision :: divb(ixi^s), dsurface(ixi^s)
4323 
4324  double precision :: invb(ixo^s)
4325  integer :: ixa^l,idims
4326 
4327  call get_divb(w,ixi^l,ixo^l,divb)
4328  invb(ixo^s)=sqrt(twofl_mag_en_all(w,ixi^l,ixo^l))
4329  where(invb(ixo^s)/=0.d0)
4330  invb(ixo^s)=1.d0/invb(ixo^s)
4331  end where
4332  if(slab_uniform) then
4333  divb(ixo^s)=0.5d0*abs(divb(ixo^s))*invb(ixo^s)/sum(1.d0/dxlevel(:))
4334  else
4335  ixamin^d=ixomin^d-1;
4336  ixamax^d=ixomax^d-1;
4337  dsurface(ixo^s)= sum(block%surfaceC(ixo^s,:),dim=ndim+1)
4338  do idims=1,ndim
4339  ixa^l=ixo^l-kr(idims,^d);
4340  dsurface(ixo^s)=dsurface(ixo^s)+block%surfaceC(ixa^s,idims)
4341  end do
4342  divb(ixo^s)=abs(divb(ixo^s))*invb(ixo^s)*&
4343  block%dvolume(ixo^s)/dsurface(ixo^s)
4344  end if
4345 
4346  end subroutine get_normalized_divb
4347 
4348  !> Calculate idirmin and the idirmin:3 components of the common current array
4349  !> make sure that dxlevel(^D) is set correctly.
4350  subroutine get_current(w,ixI^L,ixO^L,idirmin,current)
4352  use mod_geometry
4353 
4354  integer, intent(in) :: ixo^l, ixi^l
4355  double precision, intent(in) :: w(ixi^s,1:nw)
4356  integer, intent(out) :: idirmin
4357  integer :: idir, idirmin0
4358 
4359  ! For ndir=2 only 3rd component of J can exist, ndir=1 is impossible for MHD
4360  double precision :: current(ixi^s,7-2*ndir:3),bvec(ixi^s,1:ndir)
4361 
4362  idirmin0 = 7-2*ndir
4363 
4364  bvec(ixi^s,1:ndir)=w(ixi^s,mag(1:ndir))
4365 
4366  call curlvector(bvec,ixi^l,ixo^l,current,idirmin,idirmin0,ndir)
4367 
4368  if(b0field) current(ixo^s,idirmin0:3)=current(ixo^s,idirmin0:3)+&
4369  block%J0(ixo^s,idirmin0:3)
4370 
4371  end subroutine get_current
4372 
4373  ! copied from gravity
4374  !> w[iw]=w[iw]+qdt*S[wCT,qtC,x] where S is the source based on wCT within ixO
4375  subroutine gravity_add_source(qdt,ixI^L,ixO^L,wCT,w,x,&
4376  energy,qsourcesplit,active)
4378  use mod_usr_methods
4379 
4380  integer, intent(in) :: ixI^L, ixO^L
4381  double precision, intent(in) :: qdt, x(ixI^S,1:ndim)
4382  double precision, intent(in) :: wCT(ixI^S,1:nw)
4383  double precision, intent(inout) :: w(ixI^S,1:nw)
4384  logical, intent(in) :: energy,qsourcesplit
4385  logical, intent(inout) :: active
4386  double precision :: vel(ixI^S)
4387  integer :: idim
4388 
4389  double precision :: gravity_field(ixI^S,ndim)
4390 
4391  if(qsourcesplit .eqv. grav_split) then
4392  active = .true.
4393 
4394  if (.not. associated(usr_gravity)) then
4395  write(*,*) "mod_usr.t: please point usr_gravity to a subroutine"
4396  write(*,*) "like the phys_gravity in mod_usr_methods.t"
4397  call mpistop("gravity_add_source: usr_gravity not defined")
4398  else
4399  call usr_gravity(ixi^l,ixo^l,wct,x,gravity_field)
4400  end if
4401 
4402  do idim = 1, ndim
4403  w(ixo^s,mom_n(idim)) = w(ixo^s,mom_n(idim)) &
4404  + qdt * gravity_field(ixo^s,idim) * wct(ixo^s,rho_n_)
4405  w(ixo^s,mom_c(idim)) = w(ixo^s,mom_c(idim)) &
4406  + qdt * gravity_field(ixo^s,idim) * wct(ixo^s,rho_c_)
4407  if(energy) then
4408 #if !defined(E_RM_W0) || E_RM_W0 == 1
4409  call twofl_get_v_n_idim(wct,x,ixi^l,ixo^l,idim,vel)
4410  w(ixo^s,e_n_)=w(ixo^s,e_n_) &
4411  + qdt * gravity_field(ixo^s,idim) * vel(ixo^s) * wct(ixo^s,rho_n_)
4412  call twofl_get_v_c_idim(wct,x,ixi^l,ixo^l,idim,vel)
4413  w(ixo^s,e_c_)=w(ixo^s,e_c_) &
4414  + qdt * gravity_field(ixo^s,idim) * vel(ixo^s) * wct(ixo^s,rho_c_)
4415 #else
4416  w(ixo^s,e_n_)=w(ixo^s,e_n_) &
4417  + qdt * gravity_field(ixo^s,idim) * wct(ixo^s,mom_n(idim))
4418  w(ixo^s,e_c_)=w(ixo^s,e_c_) &
4419  + qdt * gravity_field(ixo^s,idim) * wct(ixo^s,mom_c(idim))
4420 #endif
4421 
4422 
4423  end if
4424  end do
4425  end if
4426 
4427  end subroutine gravity_add_source
4428 
4429  subroutine gravity_get_dt(w,ixI^L,ixO^L,dtnew,dx^D,x)
4431  use mod_usr_methods
4432 
4433  integer, intent(in) :: ixI^L, ixO^L
4434  double precision, intent(in) :: dx^D, x(ixI^S,1:ndim), w(ixI^S,1:nw)
4435  double precision, intent(inout) :: dtnew
4436 
4437  double precision :: dxinv(1:ndim), max_grav
4438  integer :: idim
4439 
4440  double precision :: gravity_field(ixI^S,ndim)
4441 
4442  ^d&dxinv(^d)=one/dx^d;
4443 
4444  if(.not. associated(usr_gravity)) then
4445  write(*,*) "mod_usr.t: please point usr_gravity to a subroutine"
4446  write(*,*) "like the phys_gravity in mod_usr_methods.t"
4447  call mpistop("gravity_get_dt: usr_gravity not defined")
4448  else
4449  call usr_gravity(ixi^l,ixo^l,w,x,gravity_field)
4450  end if
4451 
4452  do idim = 1, ndim
4453  max_grav = maxval(abs(gravity_field(ixo^s,idim)))
4454  max_grav = max(max_grav, epsilon(1.0d0))
4455  dtnew = min(dtnew, 1.0d0 / sqrt(max_grav * dxinv(idim)))
4456  end do
4457 
4458  end subroutine gravity_get_dt
4459 
4460  !> If resistivity is not zero, check diffusion time limit for dt
4461  subroutine twofl_get_dt(w,ixI^L,ixO^L,dtnew,dx^D,x)
4463  use mod_usr_methods
4465  !use mod_viscosity, only: viscosity_get_dt
4466  !use mod_gravity, only: gravity_get_dt
4467 
4468  integer, intent(in) :: ixI^L, ixO^L
4469  double precision, intent(inout) :: dtnew
4470  double precision, intent(in) :: dx^D
4471  double precision, intent(in) :: w(ixI^S,1:nw)
4472  double precision, intent(in) :: x(ixI^S,1:ndim)
4473 
4474  integer :: idirmin,idim
4475  double precision :: dxarr(ndim)
4476  double precision :: current(ixI^S,7-2*ndir:3),eta(ixI^S)
4477 
4478  dtnew = bigdouble
4479 
4480  ^d&dxarr(^d)=dx^d;
4481  if (twofl_eta>zero)then
4482  dtnew=dtdiffpar*minval(dxarr(1:ndim))**2/twofl_eta
4483  else if (twofl_eta<zero)then
4484  call get_current(w,ixi^l,ixo^l,idirmin,current)
4485  call usr_special_resistivity(w,ixi^l,ixo^l,idirmin,x,current,eta)
4486  dtnew=bigdouble
4487  do idim=1,ndim
4488  if(slab_uniform) then
4489  dtnew=min(dtnew,&
4490  dtdiffpar/(smalldouble+maxval(eta(ixo^s)/dxarr(idim)**2)))
4491  else
4492  dtnew=min(dtnew,&
4493  dtdiffpar/(smalldouble+maxval(eta(ixo^s)/block%ds(ixo^s,idim)**2)))
4494  end if
4495  end do
4496  end if
4497 
4498  if(twofl_eta_hyper>zero) then
4499  if(slab_uniform) then
4500  dtnew=min(dtdiffpar*minval(dxarr(1:ndim))**4/twofl_eta_hyper,dtnew)
4501  else
4502  dtnew=min(dtdiffpar*minval(block%ds(ixo^s,1:ndim))**4/twofl_eta_hyper,dtnew)
4503  end if
4504  end if
4505 
4506  ! the timestep related to coll terms: 1/(rho_n rho_c alpha)
4507  if(dtcollpar>0d0 .and. has_collisions()) then
4508  call coll_get_dt(w,x,ixi^l,ixo^l,dtnew)
4509  endif
4510 
4511  if(twofl_radiative_cooling_c) then
4512  call cooling_get_dt(w,ixi^l,ixo^l,dtnew,dx^d,x,rc_fl_c)
4513  end if
4514  if(twofl_radiative_cooling_n) then
4515  call cooling_get_dt(w,ixi^l,ixo^l,dtnew,dx^d,x,rc_fl_n)
4516  end if
4517 !
4518 ! if(twofl_viscosity) then
4519 ! call viscosity_get_dt(w,ixI^L,ixO^L,dtnew,dx^D,x)
4520 ! end if
4521 !
4522  if(twofl_gravity) then
4523  call gravity_get_dt(w,ixi^l,ixo^l,dtnew,dx^d,x)
4524  end if
4525  if(twofl_hyperdiffusivity) then
4526  call hyperdiffusivity_get_dt(w,ixi^l,ixo^l,dtnew,dx^d,x)
4527  end if
4528 
4529 
4530  end subroutine twofl_get_dt
4531 
4532  pure function has_collisions() result(res)
4533  logical :: res
4534  res = .not. twofl_alpha_coll_constant .or. twofl_alpha_coll >0d0
4535  end function has_collisions
4536 
4537  subroutine coll_get_dt(w,x,ixI^L,ixO^L,dtnew)
4539  integer, intent(in) :: ixi^l, ixo^l
4540  double precision, intent(in) :: w(ixi^s,1:nw)
4541  double precision, intent(in) :: x(ixi^s,1:ndim)
4542  double precision, intent(inout) :: dtnew
4543 
4544  double precision :: rhon(ixi^s), rhoc(ixi^s), alpha(ixi^s)
4545  double precision, allocatable :: gamma_rec(:^d&), gamma_ion(:^D&)
4546  double precision :: max_coll_rate
4547 
4548  call get_rhon_tot(w,x,ixi^l,ixo^l,rhon)
4549  call get_rhoc_tot(w,x,ixi^l,ixo^l,rhoc)
4550 
4551  call get_alpha_coll(ixi^l, ixo^l, w, x, alpha)
4552  max_coll_rate = maxval(alpha(ixo^s) * max(rhon(ixo^s), rhoc(ixo^s)))
4553 
4554  if(twofl_coll_inc_ionrec) then
4555  allocate(gamma_ion(ixi^s), gamma_rec(ixi^s))
4556  call get_gamma_ion_rec(ixi^l, ixo^l, w, x, gamma_rec, gamma_ion)
4557  max_coll_rate=max(max_coll_rate, maxval(gamma_ion(ixo^s)), maxval(gamma_rec(ixo^s)))
4558  deallocate(gamma_ion, gamma_rec)
4559  endif
4560  dtnew = min(dtcollpar/max_coll_rate, dtnew)
4561 
4562  end subroutine coll_get_dt
4563 
4564  ! Add geometrical source terms to w
4565  subroutine twofl_add_source_geom(qdt,dtfactor,ixI^L,ixO^L,wCT,wprim,w,x)
4567  use mod_geometry
4568 
4569  integer, intent(in) :: ixI^L, ixO^L
4570  double precision, intent(in) :: qdt, dtfactor,x(ixI^S,1:ndim)
4571  double precision, intent(inout) :: wCT(ixI^S,1:nw), wprim(ixI^S,1:nw), w(ixI^S,1:nw)
4572 
4573  integer :: iw,idir, h1x^L{^NOONED, h2x^L}
4574  double precision :: tmp(ixI^S),tmp1(ixI^S),tmp2(ixI^S),rho(ixI^S)
4575 
4576  integer :: mr_,mphi_ ! Polar var. names
4577  integer :: br_,bphi_
4578 
4579  ! charges
4580 
4581  mr_=mom_c(1); mphi_=mom_c(1)-1+phi_ ! Polar var. names
4582  br_=mag(1); bphi_=mag(1)-1+phi_
4583  call get_rhoc_tot(wct,x,ixi^l,ixo^l,rho)
4584 
4585  select case (coordinate)
4586  case (cylindrical)
4587  call twofl_get_p_c_total(wct,x,ixi^l,ixo^l,tmp)
4588 
4589  if(phi_>0) then
4590  w(ixo^s,mr_)=w(ixo^s,mr_)+qdt/x(ixo^s,1)*(tmp(ixo^s)-&
4591  wct(ixo^s,bphi_)**2+wct(ixo^s,mphi_)**2/rho(ixo^s))
4592  w(ixo^s,mphi_)=w(ixo^s,mphi_)+qdt/x(ixo^s,1)*(&
4593  -wct(ixo^s,mphi_)*wct(ixo^s,mr_)/rho(ixo^s) &
4594  +wct(ixo^s,bphi_)*wct(ixo^s,br_))
4595  if(.not.stagger_grid) then
4596  w(ixo^s,bphi_)=w(ixo^s,bphi_)+qdt/x(ixo^s,1)*&
4597  (wct(ixo^s,bphi_)*wct(ixo^s,mr_) &
4598  -wct(ixo^s,br_)*wct(ixo^s,mphi_)) &
4599  /rho(ixo^s)
4600  end if
4601  else
4602  w(ixo^s,mr_)=w(ixo^s,mr_)+qdt/x(ixo^s,1)*tmp(ixo^s)
4603  end if
4604  if(twofl_glm) w(ixo^s,br_)=w(ixo^s,br_)+qdt*wct(ixo^s,psi_)/x(ixo^s,1)
4605  case (spherical)
4606  h1x^l=ixo^l-kr(1,^d); {^nooned h2x^l=ixo^l-kr(2,^d);}
4607  call twofl_get_p_c_total(wct,x,ixi^l,ixo^l,tmp1)
4608  tmp(ixo^s)=tmp1(ixo^s)
4609  if(b0field) then
4610  tmp2(ixo^s)=sum(block%B0(ixo^s,:,0)*wct(ixo^s,mag(:)),dim=ndim+1)
4611  tmp(ixo^s)=tmp(ixo^s)+tmp2(ixo^s)
4612  end if
4613  ! m1
4614  tmp(ixo^s)=tmp(ixo^s)*x(ixo^s,1) &
4615  *(block%surfaceC(ixo^s,1)-block%surfaceC(h1x^s,1))/block%dvolume(ixo^s)
4616  if(ndir>1) then
4617  do idir=2,ndir
4618  tmp(ixo^s)=tmp(ixo^s)+wct(ixo^s,mom_c(idir))**2/rho(ixo^s)-wct(ixo^s,mag(idir))**2
4619  if(b0field) tmp(ixo^s)=tmp(ixo^s)-2.0d0*block%B0(ixo^s,idir,0)*wct(ixo^s,mag(idir))
4620  end do
4621  end if
4622  w(ixo^s,mom_c(1))=w(ixo^s,mom_c(1))+qdt*tmp(ixo^s)/x(ixo^s,1)
4623  ! b1
4624  if(twofl_glm) then
4625  w(ixo^s,mag(1))=w(ixo^s,mag(1))+qdt/x(ixo^s,1)*2.0d0*wct(ixo^s,psi_)
4626  end if
4627 
4628  {^nooned
4629  ! m2
4630  tmp(ixo^s)=tmp1(ixo^s)
4631  if(b0field) then
4632  tmp(ixo^s)=tmp(ixo^s)+tmp2(ixo^s)
4633  end if
4634  ! This will make hydrostatic p=const an exact solution
4635  w(ixo^s,mom_c(2))=w(ixo^s,mom_c(2))+qdt*tmp(ixo^s) &
4636  *(block%surfaceC(ixo^s,2)-block%surfaceC(h2x^s,2)) &
4637  /block%dvolume(ixo^s)
4638  tmp(ixo^s)=-(wct(ixo^s,mom_c(1))*wct(ixo^s,mom_c(2))/rho(ixo^s) &
4639  -wct(ixo^s,mag(1))*wct(ixo^s,mag(2)))
4640  if (b0field) then
4641  tmp(ixo^s)=tmp(ixo^s)+block%B0(ixo^s,1,0)*wct(ixo^s,mag(2)) &
4642  +wct(ixo^s,mag(1))*block%B0(ixo^s,2,0)
4643  end if
4644  if(ndir==3) then
4645  tmp(ixo^s)=tmp(ixo^s)+(wct(ixo^s,mom_c(3))**2/rho(ixo^s) &
4646  -wct(ixo^s,mag(3))**2)*dcos(x(ixo^s,2))/dsin(x(ixo^s,2))
4647  if (b0field) then
4648  tmp(ixo^s)=tmp(ixo^s)-2.0d0*block%B0(ixo^s,3,0)*wct(ixo^s,mag(3))&
4649  *dcos(x(ixo^s,2))/dsin(x(ixo^s,2))
4650  end if
4651  end if
4652  w(ixo^s,mom_c(2))=w(ixo^s,mom_c(2))+qdt*tmp(ixo^s)/x(ixo^s,1)
4653  ! b2
4654  if(.not.stagger_grid) then
4655  tmp(ixo^s)=(wct(ixo^s,mom_c(1))*wct(ixo^s,mag(2)) &
4656  -wct(ixo^s,mom_c(2))*wct(ixo^s,mag(1)))/rho(ixo^s)
4657  if(b0field) then
4658  tmp(ixo^s)=tmp(ixo^s)+(wct(ixo^s,mom_c(1))*block%B0(ixo^s,2,0) &
4659  -wct(ixo^s,mom_c(2))*block%B0(ixo^s,1,0))/rho(ixo^s)
4660  end if
4661  if(twofl_glm) then
4662  tmp(ixo^s)=tmp(ixo^s) &
4663  + dcos(x(ixo^s,2))/dsin(x(ixo^s,2))*wct(ixo^s,psi_)
4664  end if
4665  w(ixo^s,mag(2))=w(ixo^s,mag(2))+qdt*tmp(ixo^s)/x(ixo^s,1)
4666  end if
4667  }
4668 
4669  if(ndir==3) then
4670  ! m3
4671  tmp(ixo^s)=-(wct(ixo^s,mom_c(3))*wct(ixo^s,mom_c(1))/rho(ixo^s) &
4672  -wct(ixo^s,mag(3))*wct(ixo^s,mag(1))) {^nooned &
4673  -(wct(ixo^s,mom_c(2))*wct(ixo^s,mom_c(3))/rho(ixo^s) &
4674  -wct(ixo^s,mag(2))*wct(ixo^s,mag(3))) &
4675  *dcos(x(ixo^s,2))/dsin(x(ixo^s,2)) }
4676  if (b0field) then
4677  tmp(ixo^s)=tmp(ixo^s)+block%B0(ixo^s,1,0)*wct(ixo^s,mag(3)) &
4678  +wct(ixo^s,mag(1))*block%B0(ixo^s,3,0) {^nooned &
4679  +(block%B0(ixo^s,2,0)*wct(ixo^s,mag(3)) &
4680  +wct(ixo^s,mag(2))*block%B0(ixo^s,3,0)) &
4681  *dcos(x(ixo^s,2))/dsin(x(ixo^s,2)) }
4682  end if
4683  w(ixo^s,mom_c(3))=w(ixo^s,mom_c(3))+qdt*tmp(ixo^s)/x(ixo^s,1)
4684  ! b3
4685  if(.not.stagger_grid) then
4686  tmp(ixo^s)=(wct(ixo^s,mom_c(1))*wct(ixo^s,mag(3)) &
4687  -wct(ixo^s,mom_c(3))*wct(ixo^s,mag(1)))/rho(ixo^s) {^nooned &
4688  -(wct(ixo^s,mom_c(3))*wct(ixo^s,mag(2)) &
4689  -wct(ixo^s,mom_c(2))*wct(ixo^s,mag(3)))*dcos(x(ixo^s,2)) &
4690  /(rho(ixo^s)*dsin(x(ixo^s,2))) }
4691  if (b0field) then
4692  tmp(ixo^s)=tmp(ixo^s)+(wct(ixo^s,mom_c(1))*block%B0(ixo^s,3,0) &
4693  -wct(ixo^s,mom_c(3))*block%B0(ixo^s,1,0))/rho(ixo^s){^nooned &
4694  -(wct(ixo^s,mom_c(3))*block%B0(ixo^s,2,0) &
4695  -wct(ixo^s,mom_c(2))*block%B0(ixo^s,3,0))*dcos(x(ixo^s,2)) &
4696  /(rho(ixo^s)*dsin(x(ixo^s,2))) }
4697  end if
4698  w(ixo^s,mag(3))=w(ixo^s,mag(3))+qdt*tmp(ixo^s)/x(ixo^s,1)
4699  end if
4700  end if
4701  end select
4702 
4703  ! neutrals
4704  !TODO no dust: see and implement them from hd/mod_hd_phys !
4705  !uncomment cartesian expansion
4706  call get_rhon_tot(wct,x,ixi^l,ixo^l,rho)
4707  call twofl_get_pthermal_n(wct, x, ixi^l, ixo^l, tmp1)
4708 
4709  select case (coordinate)
4710 ! case(Cartesian_expansion)
4711 ! !the user provides the functions of exp_factor and del_exp_factor
4712 ! if(associated(usr_set_surface)) call usr_set_surface(ixI^L,x,block%dx,exp_factor,del_exp_factor,exp_factor_primitive)
4713 ! tmp(ixO^S) = tmp1(ixO^S)*del_exp_factor(ixO^S)/exp_factor(ixO^S)
4714 ! w(ixO^S,mom(1)) = w(ixO^S,mom(1)) + qdt*tmp(ixO^S)
4715 
4716  case (cylindrical)
4717  mr_ = mom_n(r_)
4718  if (phi_ > 0) then
4719  where (rho(ixo^s) > 0d0)
4720  tmp(ixo^s) = tmp1(ixo^s) + wct(ixo^s, mphi_)**2 / rho(ixo^s)
4721  w(ixo^s, mr_) = w(ixo^s, mr_) + qdt * tmp(ixo^s) / x(ixo^s, r_)
4722  end where
4723  ! s[mphi]=(-mphi*mr/rho)/radius
4724  where (rho(ixo^s) > 0d0)
4725  tmp(ixo^s) = -wct(ixo^s, mphi_) * wct(ixo^s, mr_) / rho(ixo^s)
4726  w(ixo^s, mphi_) = w(ixo^s, mphi_) + qdt * tmp(ixo^s) / x(ixo^s, r_)
4727  end where
4728  else
4729  ! s[mr]=2pthermal/radius
4730  w(ixo^s, mr_) = w(ixo^s, mr_) + qdt * tmp1(ixo^s) / x(ixo^s, r_)
4731  end if
4732  case (spherical)
4733  if(phi_>0) mphi_ = mom_n(phi_)
4734  h1x^l=ixo^l-kr(1,^d); {^nooned h2x^l=ixo^l-kr(2,^d);}
4735  ! s[mr]=((mtheta**2+mphi**2)/rho+2*p)/r
4736  tmp(ixo^s) = tmp1(ixo^s) * x(ixo^s, 1) &
4737  *(block%surfaceC(ixo^s, 1) - block%surfaceC(h1x^s, 1)) &
4738  /block%dvolume(ixo^s)
4739  if (ndir > 1) then
4740  do idir = 2, ndir
4741  tmp(ixo^s) = tmp(ixo^s) + wct(ixo^s, mom_n(idir))**2 / rho(ixo^s)
4742  end do
4743  end if
4744  w(ixo^s, mr_) = w(ixo^s, mr_) + qdt * tmp(ixo^s) / x(ixo^s, 1)
4745 
4746  {^nooned
4747  ! s[mtheta]=-(mr*mtheta/rho)/r+cot(theta)*(mphi**2/rho+p)/r
4748  tmp(ixo^s) = tmp1(ixo^s) * x(ixo^s, 1) &
4749  * (block%surfaceC(ixo^s, 2) - block%surfaceC(h2x^s, 2)) &
4750  / block%dvolume(ixo^s)
4751  if (ndir == 3) then
4752  tmp(ixo^s) = tmp(ixo^s) + (wct(ixo^s, mom_n(3))**2 / rho(ixo^s)) / tan(x(ixo^s, 2))
4753  end if
4754  tmp(ixo^s) = tmp(ixo^s) - (wct(ixo^s, mom_n(2)) * wct(ixo^s, mr_)) / rho(ixo^s)
4755  w(ixo^s, mom_n(2)) = w(ixo^s, mom_n(2)) + qdt * tmp(ixo^s) / x(ixo^s, 1)
4756 
4757  if (ndir == 3) then
4758  ! s[mphi]=-(mphi*mr/rho)/r-cot(theta)*(mtheta*mphi/rho)/r
4759  tmp(ixo^s) = -(wct(ixo^s, mom_n(3)) * wct(ixo^s, mr_)) / rho(ixo^s)&
4760  - (wct(ixo^s, mom_n(2)) * wct(ixo^s, mom_n(3))) / rho(ixo^s) / tan(x(ixo^s, 2))
4761  w(ixo^s, mom_n(3)) = w(ixo^s, mom_n(3)) + qdt * tmp(ixo^s) / x(ixo^s, 1)
4762  end if
4763  }
4764  end select
4765 
4766  contains
4767  subroutine twofl_get_p_c_total(w,x,ixI^L,ixO^L,p)
4769 
4770  integer, intent(in) :: ixI^L, ixO^L
4771  double precision, intent(in) :: w(ixI^S,nw)
4772  double precision, intent(in) :: x(ixI^S,1:ndim)
4773  double precision, intent(out) :: p(ixI^S)
4774 
4775  call twofl_get_pthermal_c(w,x,ixi^l,ixo^l,p)
4776 
4777  p(ixo^s) = p(ixo^s) + 0.5d0 * sum(w(ixo^s, mag(:))**2, dim=ndim+1)
4778 
4779  end subroutine twofl_get_p_c_total
4780 
4781  end subroutine twofl_add_source_geom
4782 
4783  subroutine twofl_get_temp_c_pert_from_etot(w, x, ixI^L, ixO^L, res)
4785  integer, intent(in) :: ixI^L, ixO^L
4786  double precision, intent(in) :: w(ixI^S, 1:nw)
4787  double precision, intent(in) :: x(ixI^S, 1:ndim)
4788  double precision, intent(out):: res(ixI^S)
4789 
4790  ! store pe1 in res
4791  res(ixo^s)=(gamma_1*(w(ixo^s,e_c_)&
4792  - twofl_kin_en_c(w,ixi^l,ixo^l)&
4793  - twofl_mag_en(w,ixi^l,ixo^l)))
4794  if(has_equi_pe_c0) then
4795  res(ixo^s) = res(ixo^s) + block%equi_vars(ixo^s,equi_pe_c0_,b0i)
4796  if(has_equi_rho_c0) then
4797  res(ixo^s) = res(ixo^s)/(rc * (w(ixo^s,rho_c_)+ block%equi_vars(ixo^s,equi_rho_c0_,b0i))) - &
4798  block%equi_vars(ixo^s,equi_pe_c0_,b0i)/(rc * block%equi_vars(ixo^s,equi_rho_c0_,b0i))
4799  else
4800  ! infinite equi temperature with p0 and 0 density
4801  res(ixo^s) = 0d0
4802  endif
4803  else
4804  res(ixo^s) = res(ixo^s)/(rc * w(ixo^s,rho_c_))
4805  endif
4806 
4807  end subroutine twofl_get_temp_c_pert_from_etot
4808 
4809  !> Compute 2 times total magnetic energy
4810  function twofl_mag_en_all(w, ixI^L, ixO^L) result(mge)
4812  integer, intent(in) :: ixi^l, ixo^l
4813  double precision, intent(in) :: w(ixi^s, nw)
4814  double precision :: mge(ixo^s)
4815 
4816  if (b0field) then
4817  mge(ixo^s) = sum((w(ixo^s, mag(:))+block%B0(ixo^s,:,b0i))**2, dim=ndim+1)
4818  else
4819  mge(ixo^s) = sum(w(ixo^s, mag(:))**2, dim=ndim+1)
4820  end if
4821  end function twofl_mag_en_all
4822 
4823  !> Compute full magnetic field by direction
4824  function twofl_mag_i_all(w, ixI^L, ixO^L,idir) result(mgf)
4826  integer, intent(in) :: ixi^l, ixo^l, idir
4827  double precision, intent(in) :: w(ixi^s, nw)
4828  double precision :: mgf(ixo^s)
4829 
4830  if (b0field) then
4831  mgf(ixo^s) = w(ixo^s, mag(idir))+block%B0(ixo^s,idir,b0i)
4832  else
4833  mgf(ixo^s) = w(ixo^s, mag(idir))
4834  end if
4835  end function twofl_mag_i_all
4836 
4837  !> Compute evolving magnetic energy
4838  function twofl_mag_en(w, ixI^L, ixO^L) result(mge)
4839  use mod_global_parameters, only: nw, ndim
4840  integer, intent(in) :: ixi^l, ixo^l
4841  double precision, intent(in) :: w(ixi^s, nw)
4842  double precision :: mge(ixo^s)
4843 
4844  mge(ixo^s) = 0.5d0 * sum(w(ixo^s, mag(:))**2, dim=ndim+1)
4845  end function twofl_mag_en
4846 
4847  !> compute kinetic energy of neutrals
4848  function twofl_kin_en_n(w, ixI^L, ixO^L) result(ke)
4849  use mod_global_parameters, only: nw, ndim,block
4850  integer, intent(in) :: ixi^l, ixo^l
4851  double precision, intent(in) :: w(ixi^s, nw)
4852  double precision :: ke(ixo^s)
4853 
4854  if(has_equi_rho_n0) then
4855  ke(ixo^s) = 0.5d0 * sum(w(ixo^s, mom_n(:))**2, dim=ndim+1) / (w(ixo^s, rho_n_) + block%equi_vars(ixo^s,equi_rho_n0_,0))
4856  else
4857  ke(ixo^s) = 0.5d0 * sum(w(ixo^s, mom_n(:))**2, dim=ndim+1) / w(ixo^s, rho_n_)
4858  endif
4859 
4860  end function twofl_kin_en_n
4861 
4862  subroutine twofl_get_temp_n_pert_from_etot(w, x, ixI^L, ixO^L, res)
4864  integer, intent(in) :: ixI^L, ixO^L
4865  double precision, intent(in) :: w(ixI^S, 1:nw)
4866  double precision, intent(in) :: x(ixI^S, 1:ndim)
4867  double precision, intent(out):: res(ixI^S)
4868 
4869  ! store pe1 in res
4870  res(ixo^s)=(gamma_1*(w(ixo^s,e_c_)- twofl_kin_en_c(w,ixi^l,ixo^l)))
4871  if(has_equi_pe_n0) then
4872  res(ixo^s) = res(ixo^s) + block%equi_vars(ixo^s,equi_pe_n0_,b0i)
4873  if(has_equi_rho_n0) then
4874  res(ixo^s) = res(ixo^s)/(rn * (w(ixo^s,rho_n_)+ block%equi_vars(ixo^s,equi_rho_n0_,b0i))) - &
4875  block%equi_vars(ixo^s,equi_pe_n0_,b0i)/(rn * block%equi_vars(ixo^s,equi_rho_n0_,b0i))
4876  else
4877  ! infinite equi temperature with p0 and 0 density
4878  res(ixo^s) = 0d0
4879  endif
4880  else
4881  res(ixo^s) = res(ixo^s)/(rn * w(ixo^s,rho_n_))
4882  endif
4883 
4884  end subroutine twofl_get_temp_n_pert_from_etot
4885 
4886  !> compute kinetic energy of charges
4887  !> w are conserved variables
4888  function twofl_kin_en_c(w, ixI^L, ixO^L) result(ke)
4889  use mod_global_parameters, only: nw, ndim,block
4890  integer, intent(in) :: ixi^l, ixo^l
4891  double precision, intent(in) :: w(ixi^s, nw)
4892  double precision :: ke(ixo^s)
4893 
4894  if(has_equi_rho_c0) then
4895  ke(ixo^s) = 0.5d0 * sum(w(ixo^s, mom_c(:))**2, dim=ndim+1) / (w(ixo^s, rho_c_) + block%equi_vars(ixo^s,equi_rho_c0_,0))
4896  else
4897  ke(ixo^s) = 0.5d0 * sum(w(ixo^s, mom_c(:))**2, dim=ndim+1) / w(ixo^s, rho_c_)
4898  endif
4899  end function twofl_kin_en_c
4900 
4901  subroutine twofl_getv_hall(w,x,ixI^L,ixO^L,vHall)
4903 
4904  integer, intent(in) :: ixI^L, ixO^L
4905  double precision, intent(in) :: w(ixI^S,nw)
4906  double precision, intent(in) :: x(ixI^S,1:ndim)
4907  double precision, intent(inout) :: vHall(ixI^S,1:3)
4908 
4909  integer :: idir, idirmin
4910  double precision :: current(ixI^S,7-2*ndir:3)
4911  double precision :: rho(ixI^S)
4912 
4913  call get_rhoc_tot(w,x,ixi^l,ixo^l,rho)
4914  ! Calculate current density and idirmin
4915  call get_current(w,ixi^l,ixo^l,idirmin,current)
4916  vhall(ixo^s,1:3) = zero
4917  vhall(ixo^s,idirmin:3) = - twofl_etah*current(ixo^s,idirmin:3)
4918  do idir = idirmin, 3
4919  vhall(ixo^s,idir) = vhall(ixo^s,idir)/rho(ixo^s)
4920  end do
4921 
4922  end subroutine twofl_getv_hall
4923 
4924 ! the following not used
4925 ! subroutine twofl_getdt_Hall(w,x,ixI^L,ixO^L,dx^D,dthall)
4926 ! use mod_global_parameters
4927 !
4928 ! integer, intent(in) :: ixI^L, ixO^L
4929 ! double precision, intent(in) :: dx^D
4930 ! double precision, intent(in) :: w(ixI^S,1:nw)
4931 ! double precision, intent(in) :: x(ixI^S,1:ndim)
4932 ! double precision, intent(out) :: dthall
4933 ! !.. local ..
4934 ! double precision :: dxarr(ndim)
4935 ! double precision :: bmag(ixI^S)
4936 !
4937 ! dthall=bigdouble
4938 !
4939 ! ! because we have that in cmax now:
4940 ! return
4941 !
4942 ! ^D&dxarr(^D)=dx^D;
4943 !
4944 ! if (.not. B0field) then
4945 ! bmag(ixO^S)=sqrt(sum(w(ixO^S,mag(:))**2, dim=ndim+1))
4946 ! bmag(ixO^S)=sqrt(sum((w(ixO^S,mag(:)) + block%B0(ixO^S,1:ndir,b0i))**2))
4947 ! end if
4948 !
4949 ! if(slab_uniform) then
4950 ! dthall=dtdiffpar*minval(dxarr(1:ndim))**2.0d0/(twofl_etah*maxval(bmag(ixO^S)/w(ixO^S,rho_c_)))
4951 ! else
4952 ! dthall=dtdiffpar*minval(block%ds(ixO^S,1:ndim))**2.0d0/(twofl_etah*maxval(bmag(ixO^S)/w(ixO^S,rho_c_)))
4953 ! end if
4954 !
4955 ! end subroutine twofl_getdt_Hall
4956 
4957  subroutine twofl_modify_wlr(ixI^L,ixO^L,qt,wLC,wRC,wLp,wRp,s,idir)
4959  use mod_usr_methods
4960  integer, intent(in) :: ixI^L, ixO^L, idir
4961  double precision, intent(in) :: qt
4962  double precision, intent(inout) :: wLC(ixI^S,1:nw), wRC(ixI^S,1:nw)
4963  double precision, intent(inout) :: wLp(ixI^S,1:nw), wRp(ixI^S,1:nw)
4964  type(state) :: s
4965  double precision :: dB(ixI^S), dPsi(ixI^S)
4966 
4967  if(stagger_grid) then
4968  wlc(ixo^s,mag(idir))=s%ws(ixo^s,idir)
4969  wrc(ixo^s,mag(idir))=s%ws(ixo^s,idir)
4970  wlp(ixo^s,mag(idir))=s%ws(ixo^s,idir)
4971  wrp(ixo^s,mag(idir))=s%ws(ixo^s,idir)
4972  else
4973  ! Solve the Riemann problem for the linear 2x2 system for normal
4974  ! B-field and GLM_Psi according to Dedner 2002:
4975  ! This implements eq. (42) in Dedner et al. 2002 JcP 175
4976  ! Gives the Riemann solution on the interface
4977  ! for the normal B component and Psi in the GLM-MHD system.
4978  ! 23/04/2013 Oliver Porth
4979  db(ixo^s) = wrp(ixo^s,mag(idir)) - wlp(ixo^s,mag(idir))
4980  dpsi(ixo^s) = wrp(ixo^s,psi_) - wlp(ixo^s,psi_)
4981 
4982  wlp(ixo^s,mag(idir)) = 0.5d0 * (wrp(ixo^s,mag(idir)) + wlp(ixo^s,mag(idir))) &
4983  - 0.5d0/cmax_global * dpsi(ixo^s)
4984  wlp(ixo^s,psi_) = 0.5d0 * (wrp(ixo^s,psi_) + wlp(ixo^s,psi_)) &
4985  - 0.5d0*cmax_global * db(ixo^s)
4986 
4987  wrp(ixo^s,mag(idir)) = wlp(ixo^s,mag(idir))
4988  wrp(ixo^s,psi_) = wlp(ixo^s,psi_)
4989 
4990  if(phys_total_energy) then
4991  wrc(ixo^s,e_c_)=wrc(ixo^s,e_c_)-half*wrc(ixo^s,mag(idir))**2
4992  wlc(ixo^s,e_c_)=wlc(ixo^s,e_c_)-half*wlc(ixo^s,mag(idir))**2
4993  end if
4994  wrc(ixo^s,mag(idir)) = wlp(ixo^s,mag(idir))
4995  wrc(ixo^s,psi_) = wlp(ixo^s,psi_)
4996  wlc(ixo^s,mag(idir)) = wlp(ixo^s,mag(idir))
4997  wlc(ixo^s,psi_) = wlp(ixo^s,psi_)
4998  ! modify total energy according to the change of magnetic field
4999  if(phys_total_energy) then
5000  wrc(ixo^s,e_c_)=wrc(ixo^s,e_c_)+half*wrc(ixo^s,mag(idir))**2
5001  wlc(ixo^s,e_c_)=wlc(ixo^s,e_c_)+half*wlc(ixo^s,mag(idir))**2
5002  end if
5003  end if
5004 
5005  if(associated(usr_set_wlr)) call usr_set_wlr(ixi^l,ixo^l,qt,wlc,wrc,wlp,wrp,s,idir)
5006 
5007  end subroutine twofl_modify_wlr
5008 
5009  subroutine twofl_boundary_adjust(igrid,psb)
5011  integer, intent(in) :: igrid
5012  type(state), target :: psb(max_blocks)
5013 
5014  integer :: iB, idims, iside, ixO^L, i^D
5015 
5016  block=>ps(igrid)
5017  ^d&dxlevel(^d)=rnode(rpdx^d_,igrid);
5018  do idims=1,ndim
5019  ! to avoid using as yet unknown corner info in more than 1D, we
5020  ! fill only interior mesh ranges of the ghost cell ranges at first,
5021  ! and progressively enlarge the ranges to include corners later
5022  do iside=1,2
5023  i^d=kr(^d,idims)*(2*iside-3);
5024  if (neighbor_type(i^d,igrid)/=1) cycle
5025  ib=(idims-1)*2+iside
5026  if(.not.boundary_divbfix(ib)) cycle
5027  if(any(typeboundary(:,ib)==bc_special)) then
5028  ! MF nonlinear force-free B field extrapolation and data driven
5029  ! require normal B of the first ghost cell layer to be untouched by
5030  ! fixdivB=0 process, set boundary_divbfix_skip(iB)=1 in par file
5031  select case (idims)
5032  {case (^d)
5033  if (iside==2) then
5034  ! maximal boundary
5035  ixomin^dd=ixghi^d+1-nghostcells+boundary_divbfix_skip(2*^d)^d%ixOmin^dd=ixglo^dd;
5036  ixomax^dd=ixghi^dd;
5037  else
5038  ! minimal boundary
5039  ixomin^dd=ixglo^dd;
5040  ixomax^dd=ixglo^d-1+nghostcells-boundary_divbfix_skip(2*^d-1)^d%ixOmax^dd=ixghi^dd;
5041  end if \}
5042  end select
5043  call fixdivb_boundary(ixg^ll,ixo^l,psb(igrid)%w,psb(igrid)%x,ib)
5044  end if
5045  end do
5046  end do
5047 
5048  end subroutine twofl_boundary_adjust
5049 
5050  subroutine fixdivb_boundary(ixG^L,ixO^L,w,x,iB)
5052 
5053  integer, intent(in) :: ixG^L,ixO^L,iB
5054  double precision, intent(inout) :: w(ixG^S,1:nw)
5055  double precision, intent(in) :: x(ixG^S,1:ndim)
5056 
5057  double precision :: dx1x2,dx1x3,dx2x1,dx2x3,dx3x1,dx3x2
5058  integer :: ix^D,ixF^L
5059 
5060  select case(ib)
5061  case(1)
5062  ! 2nd order CD for divB=0 to set normal B component better
5063  {^iftwod
5064  ixfmin1=ixomin1+1
5065  ixfmax1=ixomax1+1
5066  ixfmin2=ixomin2+1
5067  ixfmax2=ixomax2-1
5068  if(slab_uniform) then
5069  dx1x2=dxlevel(1)/dxlevel(2)
5070  do ix1=ixfmax1,ixfmin1,-1
5071  w(ix1-1,ixfmin2:ixfmax2,mag(1))=w(ix1+1,ixfmin2:ixfmax2,mag(1)) &
5072  +dx1x2*(w(ix1,ixfmin2+1:ixfmax2+1,mag(2))-&
5073  w(ix1,ixfmin2-1:ixfmax2-1,mag(2)))
5074  enddo
5075  else
5076  do ix1=ixfmax1,ixfmin1,-1
5077  w(ix1-1,ixfmin2:ixfmax2,mag(1))=( (w(ix1+1,ixfmin2:ixfmax2,mag(1))+&
5078  w(ix1,ixfmin2:ixfmax2,mag(1)))*block%surfaceC(ix1,ixfmin2:ixfmax2,1)&
5079  +(w(ix1,ixfmin2+1:ixfmax2+1,mag(2))+w(ix1,ixfmin2:ixfmax2,mag(2)))*&
5080  block%surfaceC(ix1,ixfmin2:ixfmax2,2)&
5081  -(w(ix1,ixfmin2:ixfmax2,mag(2))+w(ix1,ixfmin2-1:ixfmax2-1,mag(2)))*&
5082  block%surfaceC(ix1,ixfmin2-1:ixfmax2-1,2) )&
5083  /block%surfaceC(ix1-1,ixfmin2:ixfmax2,1)-w(ix1,ixfmin2:ixfmax2,mag(1))
5084  end do
5085  end if
5086  }
5087  {^ifthreed
5088  ixfmin1=ixomin1+1
5089  ixfmax1=ixomax1+1
5090  ixfmin2=ixomin2+1
5091  ixfmax2=ixomax2-1
5092  ixfmin3=ixomin3+1
5093  ixfmax3=ixomax3-1
5094  if(slab_uniform) then
5095  dx1x2=dxlevel(1)/dxlevel(2)
5096  dx1x3=dxlevel(1)/dxlevel(3)
5097  do ix1=ixfmax1,ixfmin1,-1
5098  w(ix1-1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))=&
5099  w(ix1+1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1)) &
5100  +dx1x2*(w(ix1,ixfmin2+1:ixfmax2+1,ixfmin3:ixfmax3,mag(2))-&
5101  w(ix1,ixfmin2-1:ixfmax2-1,ixfmin3:ixfmax3,mag(2))) &
5102  +dx1x3*(w(ix1,ixfmin2:ixfmax2,ixfmin3+1:ixfmax3+1,mag(3))-&
5103  w(ix1,ixfmin2:ixfmax2,ixfmin3-1:ixfmax3-1,mag(3)))
5104  end do
5105  else
5106  do ix1=ixfmax1,ixfmin1,-1
5107  w(ix1-1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))=&
5108  ( (w(ix1+1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))+&
5109  w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1)))*&
5110  block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,1)&
5111  +(w(ix1,ixfmin2+1:ixfmax2+1,ixfmin3:ixfmax3,mag(2))+&
5112  w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(2)))*&
5113  block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,2)&
5114  -(w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(2))+&
5115  w(ix1,ixfmin2-1:ixfmax2-1,ixfmin3:ixfmax3,mag(2)))*&
5116  block%surfaceC(ix1,ixfmin2-1:ixfmax2-1,ixfmin3:ixfmax3,2)&
5117  +(w(ix1,ixfmin2:ixfmax2,ixfmin3+1:ixfmax3+1,mag(3))+&
5118  w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(3)))*&
5119  block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,3)&
5120  -(w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(3))+&
5121  w(ix1,ixfmin2:ixfmax2,ixfmin3-1:ixfmax3-1,mag(3)))*&
5122  block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3-1:ixfmax3-1,3) )&
5123  /block%surfaceC(ix1-1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,1)-&
5124  w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))
5125  end do
5126  end if
5127  }
5128  case(2)
5129  {^iftwod
5130  ixfmin1=ixomin1-1
5131  ixfmax1=ixomax1-1
5132  ixfmin2=ixomin2+1
5133  ixfmax2=ixomax2-1
5134  if(slab_uniform) then
5135  dx1x2=dxlevel(1)/dxlevel(2)
5136  do ix1=ixfmin1,ixfmax1
5137  w(ix1+1,ixfmin2:ixfmax2,mag(1))=w(ix1-1,ixfmin2:ixfmax2,mag(1)) &
5138  -dx1x2*(w(ix1,ixfmin2+1:ixfmax2+1,mag(2))-&
5139  w(ix1,ixfmin2-1:ixfmax2-1,mag(2)))
5140  enddo
5141  else
5142  do ix1=ixfmin1,ixfmax1
5143  w(ix1+1,ixfmin2:ixfmax2,mag(1))=( (w(ix1-1,ixfmin2:ixfmax2,mag(1))+&
5144  w(ix1,ixfmin2:ixfmax2,mag(1)))*block%surfaceC(ix1-1,ixfmin2:ixfmax2,1)&
5145  -(w(ix1,ixfmin2+1:ixfmax2+1,mag(2))+w(ix1,ixfmin2:ixfmax2,mag(2)))*&
5146  block%surfaceC(ix1,ixfmin2:ixfmax2,2)&
5147  +(w(ix1,ixfmin2:ixfmax2,mag(2))+w(ix1,ixfmin2-1:ixfmax2-1,mag(2)))*&
5148  block%surfaceC(ix1,ixfmin2-1:ixfmax2-1,2) )&
5149  /block%surfaceC(ix1,ixfmin2:ixfmax2,1)-w(ix1,ixfmin2:ixfmax2,mag(1))
5150  end do
5151  end if
5152  }
5153  {^ifthreed
5154  ixfmin1=ixomin1-1
5155  ixfmax1=ixomax1-1
5156  ixfmin2=ixomin2+1
5157  ixfmax2=ixomax2-1
5158  ixfmin3=ixomin3+1
5159  ixfmax3=ixomax3-1
5160  if(slab_uniform) then
5161  dx1x2=dxlevel(1)/dxlevel(2)
5162  dx1x3=dxlevel(1)/dxlevel(3)
5163  do ix1=ixfmin1,ixfmax1
5164  w(ix1+1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))=&
5165  w(ix1-1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1)) &
5166  -dx1x2*(w(ix1,ixfmin2+1:ixfmax2+1,ixfmin3:ixfmax3,mag(2))-&
5167  w(ix1,ixfmin2-1:ixfmax2-1,ixfmin3:ixfmax3,mag(2))) &
5168  -dx1x3*(w(ix1,ixfmin2:ixfmax2,ixfmin3+1:ixfmax3+1,mag(3))-&
5169  w(ix1,ixfmin2:ixfmax2,ixfmin3-1:ixfmax3-1,mag(3)))
5170  end do
5171  else
5172  do ix1=ixfmin1,ixfmax1
5173  w(ix1+1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))=&
5174  ( (w(ix1-1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))+&
5175  w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1)))*&
5176  block%surfaceC(ix1-1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,1)&
5177  -(w(ix1,ixfmin2+1:ixfmax2+1,ixfmin3:ixfmax3,mag(2))+&
5178  w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(2)))*&
5179  block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,2)&
5180  +(w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(2))+&
5181  w(ix1,ixfmin2-1:ixfmax2-1,ixfmin3:ixfmax3,mag(2)))*&
5182  block%surfaceC(ix1,ixfmin2-1:ixfmax2-1,ixfmin3:ixfmax3,2)&
5183  -(w(ix1,ixfmin2:ixfmax2,ixfmin3+1:ixfmax3+1,mag(3))+&
5184  w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(3)))*&
5185  block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,3)&
5186  +(w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(3))+&
5187  w(ix1,ixfmin2:ixfmax2,ixfmin3-1:ixfmax3-1,mag(3)))*&
5188  block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3-1:ixfmax3-1,3) )&
5189  /block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,1)-&
5190  w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))
5191  end do
5192  end if
5193  }
5194  case(3)
5195  {^iftwod
5196  ixfmin1=ixomin1+1
5197  ixfmax1=ixomax1-1
5198  ixfmin2=ixomin2+1
5199  ixfmax2=ixomax2+1
5200  if(slab_uniform) then
5201  dx2x1=dxlevel(2)/dxlevel(1)
5202  do ix2=ixfmax2,ixfmin2,-1
5203  w(ixfmin1:ixfmax1,ix2-1,mag(2))=w(ixfmin1:ixfmax1,ix2+1,mag(2)) &
5204  +dx2x1*(w(ixfmin1+1:ixfmax1+1,ix2,mag(1))-&
5205  w(ixfmin1-1:ixfmax1-1,ix2,mag(1)))
5206  enddo
5207  else
5208  do ix2=ixfmax2,ixfmin2,-1
5209  w(ixfmin1:ixfmax1,ix2-1,mag(2))=( (w(ixfmin1:ixfmax1,ix2+1,mag(2))+&
5210  w(ixfmin1:ixfmax1,ix2,mag(2)))*block%surfaceC(ixfmin1:ixfmax1,ix2,2)&
5211  +(w(ixfmin1+1:ixfmax1+1,ix2,mag(1))+w(ixfmin1:ixfmax1,ix2,mag(1)))*&
5212  block%surfaceC(ixfmin1:ixfmax1,ix2,1)&
5213  -(w(ixfmin1:ixfmax1,ix2,mag(1))+w(ixfmin1-1:ixfmax1-1,ix2,mag(1)))*&
5214  block%surfaceC(ixfmin1-1:ixfmax1-1,ix2,1) )&
5215  /block%surfaceC(ixfmin1:ixfmax1,ix2-1,2)-w(ixfmin1:ixfmax1,ix2,mag(2))
5216  end do
5217  end if
5218  }
5219  {^ifthreed
5220  ixfmin1=ixomin1+1
5221  ixfmax1=ixomax1-1
5222  ixfmin3=ixomin3+1
5223  ixfmax3=ixomax3-1
5224  ixfmin2=ixomin2+1
5225  ixfmax2=ixomax2+1
5226  if(slab_uniform) then
5227  dx2x1=dxlevel(2)/dxlevel(1)
5228  dx2x3=dxlevel(2)/dxlevel(3)
5229  do ix2=ixfmax2,ixfmin2,-1
5230  w(ixfmin1:ixfmax1,ix2-1,ixfmin3:ixfmax3,mag(2))=w(ixfmin1:ixfmax1,&
5231  ix2+1,ixfmin3:ixfmax3,mag(2)) &
5232  +dx2x1*(w(ixfmin1+1:ixfmax1+1,ix2,ixfmin3:ixfmax3,mag(1))-&
5233  w(ixfmin1-1:ixfmax1-1,ix2,ixfmin3:ixfmax3,mag(1))) &
5234  +dx2x3*(w(ixfmin1:ixfmax1,ix2,ixfmin3+1:ixfmax3+1,mag(3))-&
5235  w(ixfmin1:ixfmax1,ix2,ixfmin3-1:ixfmax3-1,mag(3)))
5236  end do
5237  else
5238  do ix2=ixfmax2,ixfmin2,-1
5239  w(ixfmin1:ixfmax1,ix2-1,ixfmin3:ixfmax3,mag(2))=&
5240  ( (w(ixfmin1:ixfmax1,ix2+1,ixfmin3:ixfmax3,mag(2))+&
5241  w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(2)))*&
5242  block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,2)&
5243  +(w(ixfmin1+1:ixfmax1+1,ix2,ixfmin3:ixfmax3,mag(1))+&
5244  w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(1)))*&
5245  block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,1)&
5246  -(w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(1))+&
5247  w(ixfmin1-1:ixfmax1-1,ix2,ixfmin3:ixfmax3,mag(1)))*&
5248  block%surfaceC(ixfmin1-1:ixfmax1-1,ix2,ixfmin3:ixfmax3,1)&
5249  +(w(ixfmin1:ixfmax1,ix2,ixfmin3+1:ixfmax3+1,mag(3))+&
5250  w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(3)))*&
5251  block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,3)&
5252  -(w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(3))+&
5253  w(ixfmin1:ixfmax1,ix2,ixfmin3-1:ixfmax3-1,mag(3)))*&
5254  block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3-1:ixfmax3-1,3) )&
5255  /block%surfaceC(ixfmin1:ixfmax1,ix2-1,ixfmin3:ixfmax3,2)-&
5256  w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(2))
5257  end do
5258  end if
5259  }
5260  case(4)
5261  {^iftwod
5262  ixfmin1=ixomin1+1
5263  ixfmax1=ixomax1-1
5264  ixfmin2=ixomin2-1
5265  ixfmax2=ixomax2-1
5266  if(slab_uniform) then
5267  dx2x1=dxlevel(2)/dxlevel(1)
5268  do ix2=ixfmin2,ixfmax2
5269  w(ixfmin1:ixfmax1,ix2+1,mag(2))=w(ixfmin1:ixfmax1,ix2-1,mag(2)) &
5270  -dx2x1*(w(ixfmin1+1:ixfmax1+1,ix2,mag(1))-&
5271  w(ixfmin1-1:ixfmax1-1,ix2,mag(1)))
5272  end do
5273  else
5274  do ix2=ixfmin2,ixfmax2
5275  w(ixfmin1:ixfmax1,ix2+1,mag(2))=( (w(ixfmin1:ixfmax1,ix2-1,mag(2))+&
5276  w(ixfmin1:ixfmax1,ix2,mag(2)))*block%surfaceC(ixfmin1:ixfmax1,ix2-1,2)&
5277  -(w(ixfmin1+1:ixfmax1+1,ix2,mag(1))+w(ixfmin1:ixfmax1,ix2,mag(1)))*&
5278  block%surfaceC(ixfmin1:ixfmax1,ix2,1)&
5279  +(w(ixfmin1:ixfmax1,ix2,mag(1))+w(ixfmin1-1:ixfmax1-1,ix2,mag(1)))*&
5280  block%surfaceC(ixfmin1-1:ixfmax1-1,ix2,1) )&
5281  /block%surfaceC(ixfmin1:ixfmax1,ix2,2)-w(ixfmin1:ixfmax1,ix2,mag(2))
5282  end do
5283  end if
5284  }
5285  {^ifthreed
5286  ixfmin1=ixomin1+1
5287  ixfmax1=ixomax1-1
5288  ixfmin3=ixomin3+1
5289  ixfmax3=ixomax3-1
5290  ixfmin2=ixomin2-1
5291  ixfmax2=ixomax2-1
5292  if(slab_uniform) then
5293  dx2x1=dxlevel(2)/dxlevel(1)
5294  dx2x3=dxlevel(2)/dxlevel(3)
5295  do ix2=ixfmin2,ixfmax2
5296  w(ixfmin1:ixfmax1,ix2+1,ixfmin3:ixfmax3,mag(2))=w(ixfmin1:ixfmax1,&
5297  ix2-1,ixfmin3:ixfmax3,mag(2)) &
5298  -dx2x1*(w(ixfmin1+1:ixfmax1+1,ix2,ixfmin3:ixfmax3,mag(1))-&
5299  w(ixfmin1-1:ixfmax1-1,ix2,ixfmin3:ixfmax3,mag(1))) &
5300  -dx2x3*(w(ixfmin1:ixfmax1,ix2,ixfmin3+1:ixfmax3+1,mag(3))-&
5301  w(ixfmin1:ixfmax1,ix2,ixfmin3-1:ixfmax3-1,mag(3)))
5302  end do
5303  else
5304  do ix2=ixfmin2,ixfmax2
5305  w(ixfmin1:ixfmax1,ix2+1,ixfmin3:ixfmax3,mag(2))=&
5306  ( (w(ixfmin1:ixfmax1,ix2-1,ixfmin3:ixfmax3,mag(2))+&
5307  w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(2)))*&
5308  block%surfaceC(ixfmin1:ixfmax1,ix2-1,ixfmin3:ixfmax3,2)&
5309  -(w(ixfmin1+1:ixfmax1+1,ix2,ixfmin3:ixfmax3,mag(1))+&
5310  w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(1)))*&
5311  block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,1)&
5312  +(w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(1))+&
5313  w(ixfmin1-1:ixfmax1-1,ix2,ixfmin3:ixfmax3,mag(1)))*&
5314  block%surfaceC(ixfmin1-1:ixfmax1-1,ix2,ixfmin3:ixfmax3,1)&
5315  -(w(ixfmin1:ixfmax1,ix2,ixfmin3+1:ixfmax3+1,mag(3))+&
5316  w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(3)))*&
5317  block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,3)&
5318  +(w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(3))+&
5319  w(ixfmin1:ixfmax1,ix2,ixfmin3-1:ixfmax3-1,mag(3)))*&
5320  block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3-1:ixfmax3-1,3) )&
5321  /block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,2)-&
5322  w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(2))
5323  end do
5324  end if
5325  }
5326  {^ifthreed
5327  case(5)
5328  ixfmin1=ixomin1+1
5329  ixfmax1=ixomax1-1
5330  ixfmin2=ixomin2+1
5331  ixfmax2=ixomax2-1
5332  ixfmin3=ixomin3+1
5333  ixfmax3=ixomax3+1
5334  if(slab_uniform) then
5335  dx3x1=dxlevel(3)/dxlevel(1)
5336  dx3x2=dxlevel(3)/dxlevel(2)
5337  do ix3=ixfmax3,ixfmin3,-1
5338  w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3-1,mag(3))=w(ixfmin1:ixfmax1,&
5339  ixfmin2:ixfmax2,ix3+1,mag(3)) &
5340  +dx3x1*(w(ixfmin1+1:ixfmax1+1,ixfmin2:ixfmax2,ix3,mag(1))-&
5341  w(ixfmin1-1:ixfmax1-1,ixfmin2:ixfmax2,ix3,mag(1))) &
5342  +dx3x2*(w(ixfmin1:ixfmax1,ixfmin2+1:ixfmax2+1,ix3,mag(2))-&
5343  w(ixfmin1:ixfmax1,ixfmin2-1:ixfmax2-1,ix3,mag(2)))
5344  end do
5345  else
5346  do ix3=ixfmax3,ixfmin3,-1
5347  w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3-1,mag(3))=&
5348  ( (w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3+1,mag(3))+&
5349  w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(3)))*&
5350  block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,3)&
5351  +(w(ixfmin1+1:ixfmax1+1,ixfmin2:ixfmax2,ix3,mag(1))+&
5352  w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(1)))*&
5353  block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,1)&
5354  -(w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(1))+&
5355  w(ixfmin1-1:ixfmax1-1,ixfmin2:ixfmax2,ix3,mag(1)))*&
5356  block%surfaceC(ixfmin1-1:ixfmax1-1,ixfmin2:ixfmax2,ix3,1)&
5357  +(w(ixfmin1:ixfmax1,ixfmin2+1:ixfmax2+1,ix3,mag(2))+&
5358  w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(2)))*&
5359  block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,2)&
5360  -(w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(2))+&
5361  w(ixfmin1:ixfmax1,ixfmin2-1:ixfmax2-1,ix3,mag(2)))*&
5362  block%surfaceC(ixfmin1:ixfmax1,ixfmin2-1:ixfmax2-1,ix3,2) )&
5363  /block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3-1,3)-&
5364  w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(3))
5365  end do
5366  end if
5367  case(6)
5368  ixfmin1=ixomin1+1
5369  ixfmax1=ixomax1-1
5370  ixfmin2=ixomin2+1
5371  ixfmax2=ixomax2-1
5372  ixfmin3=ixomin3-1
5373  ixfmax3=ixomax3-1
5374  if(slab_uniform) then
5375  dx3x1=dxlevel(3)/dxlevel(1)
5376  dx3x2=dxlevel(3)/dxlevel(2)
5377  do ix3=ixfmin3,ixfmax3
5378  w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3+1,mag(3))=w(ixfmin1:ixfmax1,&
5379  ixfmin2:ixfmax2,ix3-1,mag(3)) &
5380  -dx3x1*(w(ixfmin1+1:ixfmax1+1,ixfmin2:ixfmax2,ix3,mag(1))-&
5381  w(ixfmin1-1:ixfmax1-1,ixfmin2:ixfmax2,ix3,mag(1))) &
5382  -dx3x2*(w(ixfmin1:ixfmax1,ixfmin2+1:ixfmax2+1,ix3,mag(2))-&
5383  w(ixfmin1:ixfmax1,ixfmin2-1:ixfmax2-1,ix3,mag(2)))
5384  end do
5385  else
5386  do ix3=ixfmin3,ixfmax3
5387  w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3+1,mag(3))=&
5388  ( (w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3-1,mag(3))+&
5389  w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(3)))*&
5390  block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3-1,3)&
5391  -(w(ixfmin1+1:ixfmax1+1,ixfmin2:ixfmax2,ix3,mag(1))+&
5392  w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(1)))*&
5393  block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,1)&
5394  +(w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(1))+&
5395  w(ixfmin1-1:ixfmax1-1,ixfmin2:ixfmax2,ix3,mag(1)))*&
5396  block%surfaceC(ixfmin1-1:ixfmax1-1,ixfmin2:ixfmax2,ix3,1)&
5397  -(w(ixfmin1:ixfmax1,ixfmin2+1:ixfmax2+1,ix3,mag(2))+&
5398  w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(2)))*&
5399  block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,2)&
5400  +(w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(2))+&
5401  w(ixfmin1:ixfmax1,ixfmin2-1:ixfmax2-1,ix3,mag(2)))*&
5402  block%surfaceC(ixfmin1:ixfmax1,ixfmin2-1:ixfmax2-1,ix3,2) )&
5403  /block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,3)-&
5404  w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(3))
5405  end do
5406  end if
5407  }
5408  case default
5409  call mpistop("Special boundary is not defined for this region")
5410  end select
5411 
5412  end subroutine fixdivb_boundary
5413 
5414  {^nooned
5415  subroutine twofl_clean_divb_multigrid(qdt, qt, active)
5416  use mod_forest
5419  use mod_geometry
5420 
5421  double precision, intent(in) :: qdt !< Current time step
5422  double precision, intent(in) :: qt !< Current time
5423  logical, intent(inout) :: active !< Output if the source is active
5424  integer :: iigrid, igrid, id
5425  integer :: n, nc, lvl, ix^l, ixc^l, idim
5426  type(tree_node), pointer :: pnode
5427  double precision :: tmp(ixg^t), grad(ixg^t, ndim)
5428  double precision :: res
5429  double precision, parameter :: max_residual = 1d-3
5430  double precision, parameter :: residual_reduction = 1d-10
5431  integer, parameter :: max_its = 50
5432  double precision :: residual_it(max_its), max_divb
5433 
5434  mg%operator_type = mg_laplacian
5435 
5436  ! Set boundary conditions
5437  do n = 1, 2*ndim
5438  idim = (n+1)/2
5439  select case (typeboundary(mag(idim), n))
5440  case (bc_symm)
5441  ! d/dx B = 0, take phi = 0
5442  mg%bc(n, mg_iphi)%bc_type = mg_bc_dirichlet
5443  mg%bc(n, mg_iphi)%bc_value = 0.0_dp
5444  case (bc_asymm)
5445  ! B = 0, so grad(phi) = 0
5446  mg%bc(n, mg_iphi)%bc_type = mg_bc_neumann
5447  mg%bc(n, mg_iphi)%bc_value = 0.0_dp
5448  case (bc_cont)
5449  mg%bc(n, mg_iphi)%bc_type = mg_bc_dirichlet
5450  mg%bc(n, mg_iphi)%bc_value = 0.0_dp
5451  case (bc_special)
5452  ! Assume Dirichlet boundary conditions, derivative zero
5453  mg%bc(n, mg_iphi)%bc_type = mg_bc_dirichlet
5454  mg%bc(n, mg_iphi)%bc_value = 0.0_dp
5455  case (bc_periodic)
5456  ! Nothing to do here
5457  case default
5458  print *, "divb_multigrid warning: unknown b.c.: ", &
5459  typeboundary(mag(idim), n)
5460  mg%bc(n, mg_iphi)%bc_type = mg_bc_dirichlet
5461  mg%bc(n, mg_iphi)%bc_value = 0.0_dp
5462  end select
5463  end do
5464 
5465  ix^l=ixm^ll^ladd1;
5466  max_divb = 0.0d0
5467 
5468  ! Store divergence of B as right-hand side
5469  do iigrid = 1, igridstail
5470  igrid = igrids(iigrid);
5471  pnode => igrid_to_node(igrid, mype)%node
5472  id = pnode%id
5473  lvl = mg%boxes(id)%lvl
5474  nc = mg%box_size_lvl(lvl)
5475 
5476  ! Geometry subroutines expect this to be set
5477  block => ps(igrid)
5478  ^d&dxlevel(^d)=rnode(rpdx^d_,igrid);
5479 
5480  call get_divb(ps(igrid)%w(ixg^t, 1:nw), ixg^ll, ixm^ll, tmp, &
5482  mg%boxes(id)%cc({1:nc}, mg_irhs) = tmp(ixm^t)
5483  max_divb = max(max_divb, maxval(abs(tmp(ixm^t))))
5484  end do
5485 
5486  ! Solve laplacian(phi) = divB
5487  if(stagger_grid) then
5488  call mpi_allreduce(mpi_in_place, max_divb, 1, mpi_double_precision, &
5489  mpi_max, icomm, ierrmpi)
5490 
5491  if (mype == 0) print *, "Performing multigrid divB cleaning"
5492  if (mype == 0) print *, "iteration vs residual"
5493  ! Solve laplacian(phi) = divB
5494  do n = 1, max_its
5495  call mg_fas_fmg(mg, n>1, max_res=residual_it(n))
5496  if (mype == 0) write(*, "(I4,E11.3)") n, residual_it(n)
5497  if (residual_it(n) < residual_reduction * max_divb) exit
5498  end do
5499  if (mype == 0 .and. n > max_its) then
5500  print *, "divb_multigrid warning: not fully converged"
5501  print *, "current amplitude of divb: ", residual_it(max_its)
5502  print *, "multigrid smallest grid: ", &
5503  mg%domain_size_lvl(:, mg%lowest_lvl)
5504  print *, "note: smallest grid ideally has <= 8 cells"
5505  print *, "multigrid dx/dy/dz ratio: ", mg%dr(:, 1)/mg%dr(1, 1)
5506  print *, "note: dx/dy/dz should be similar"
5507  end if
5508  else
5509  do n = 1, max_its
5510  call mg_fas_vcycle(mg, max_res=res)
5511  if (res < max_residual) exit
5512  end do
5513  if (res > max_residual) call mpistop("divb_multigrid: no convergence")
5514  end if
5515 
5516 
5517  ! Correct the magnetic field
5518  do iigrid = 1, igridstail
5519  igrid = igrids(iigrid);
5520  pnode => igrid_to_node(igrid, mype)%node
5521  id = pnode%id
5522 
5523  ! Geometry subroutines expect this to be set
5524  block => ps(igrid)
5525  ^d&dxlevel(^d)=rnode(rpdx^d_,igrid);
5526 
5527  ! Compute the gradient of phi
5528  tmp(ix^s) = mg%boxes(id)%cc({:,}, mg_iphi)
5529 
5530  if(stagger_grid) then
5531  do idim =1, ndim
5532  ixcmin^d=ixmlo^d-kr(idim,^d);
5533  ixcmax^d=ixmhi^d;
5534  call gradientx(tmp,ps(igrid)%x,ixg^ll,ixc^l,idim,grad(ixg^t,idim),.false.)
5535  ! Apply the correction B* = B - gradient(phi)
5536  ps(igrid)%ws(ixc^s,idim)=ps(igrid)%ws(ixc^s,idim)-grad(ixc^s,idim)
5537  end do
5538  ! store cell-center magnetic energy
5539  tmp(ixm^t) = sum(ps(igrid)%w(ixm^t, mag(1:ndim))**2, dim=ndim+1)
5540  ! change cell-center magnetic field
5541  call twofl_face_to_center(ixm^ll,ps(igrid))
5542  else
5543  do idim = 1, ndim
5544  call gradient(tmp,ixg^ll,ixm^ll,idim,grad(ixg^t, idim))
5545  end do
5546  ! store cell-center magnetic energy
5547  tmp(ixm^t) = sum(ps(igrid)%w(ixm^t, mag(1:ndim))**2, dim=ndim+1)
5548  ! Apply the correction B* = B - gradient(phi)
5549  ps(igrid)%w(ixm^t, mag(1:ndim)) = &
5550  ps(igrid)%w(ixm^t, mag(1:ndim)) - grad(ixm^t, :)
5551  end if
5552 
5553  if(phys_total_energy) then
5554  ! Determine magnetic energy difference
5555  tmp(ixm^t) = 0.5_dp * (sum(ps(igrid)%w(ixm^t, &
5556  mag(1:ndim))**2, dim=ndim+1) - tmp(ixm^t))
5557  ! Keep thermal pressure the same
5558  ps(igrid)%w(ixm^t, e_c_) = ps(igrid)%w(ixm^t, e_c_) + tmp(ixm^t)
5559  end if
5560  end do
5561 
5562  active = .true.
5563 
5564  end subroutine twofl_clean_divb_multigrid
5565  }
5566 
5567  subroutine twofl_update_faces(ixI^L,ixO^L,qt,qdt,wprim,fC,fE,sCT,s,vcts)
5569 
5570  integer, intent(in) :: ixI^L, ixO^L
5571  double precision, intent(in) :: qt,qdt
5572  ! cell-center primitive variables
5573  double precision, intent(in) :: wprim(ixI^S,1:nw)
5574  type(state) :: sCT, s
5575  type(ct_velocity) :: vcts
5576  double precision, intent(in) :: fC(ixI^S,1:nwflux,1:ndim)
5577  double precision, intent(inout) :: fE(ixI^S,sdim:3)
5578 
5579  select case(type_ct)
5580  case('average')
5581  call update_faces_average(ixi^l,ixo^l,qt,qdt,fc,fe,sct,s)
5582  case('uct_contact')
5583  call update_faces_contact(ixi^l,ixo^l,qt,qdt,wprim,fc,fe,sct,s,vcts)
5584  case('uct_hll')
5585  call update_faces_hll(ixi^l,ixo^l,qt,qdt,fe,sct,s,vcts)
5586  case default
5587  call mpistop('choose average, uct_contact,or uct_hll for type_ct!')
5588  end select
5589 
5590  end subroutine twofl_update_faces
5591 
5592  !> get electric field though averaging neighors to update faces in CT
5593  subroutine update_faces_average(ixI^L,ixO^L,qt,qdt,fC,fE,sCT,s)
5595  use mod_usr_methods
5596 
5597  integer, intent(in) :: ixI^L, ixO^L
5598  double precision, intent(in) :: qt, qdt
5599  type(state) :: sCT, s
5600  double precision, intent(in) :: fC(ixI^S,1:nwflux,1:ndim)
5601  double precision, intent(inout) :: fE(ixI^S,sdim:3)
5602 
5603  integer :: hxC^L,ixC^L,jxC^L,ixCm^L
5604  integer :: idim1,idim2,idir,iwdim1,iwdim2
5605  double precision :: circ(ixI^S,1:ndim)
5606  ! non-ideal electric field on cell edges
5607  double precision, dimension(ixI^S,sdim:3) :: E_resi
5608 
5609  associate(bfaces=>s%ws,x=>s%x)
5610 
5611  ! Calculate contribution to FEM of each edge,
5612  ! that is, estimate value of line integral of
5613  ! electric field in the positive idir direction.
5614  ixcmax^d=ixomax^d;
5615  ixcmin^d=ixomin^d-1;
5616 
5617  ! if there is resistivity, get eta J
5618  if(twofl_eta/=zero) call get_resistive_electric_field(ixi^l,ixo^l,sct,s,e_resi)
5619 
5620  fe=zero
5621 
5622  do idim1=1,ndim
5623  iwdim1 = mag(idim1)
5624  do idim2=1,ndim
5625  iwdim2 = mag(idim2)
5626  do idir=sdim,3! Direction of line integral
5627  ! Allow only even permutations
5628  if (lvc(idim1,idim2,idir)==1) then
5629  ! Assemble indices
5630  jxc^l=ixc^l+kr(idim1,^d);
5631  hxc^l=ixc^l+kr(idim2,^d);
5632  ! Interpolate to edges
5633  fe(ixc^s,idir)=quarter*(fc(ixc^s,iwdim1,idim2)+fc(jxc^s,iwdim1,idim2)&
5634  -fc(ixc^s,iwdim2,idim1)-fc(hxc^s,iwdim2,idim1))
5635 
5636  ! add resistive electric field at cell edges E=-vxB+eta J
5637  if(twofl_eta/=zero) fe(ixc^s,idir)=fe(ixc^s,idir)+e_resi(ixc^s,idir)
5638  fe(ixc^s,idir)=qdt*s%dsC(ixc^s,idir)*fe(ixc^s,idir)
5639 
5640  if (.not.slab) then
5641  where(abs(x(ixc^s,r_)+half*dxlevel(r_))<1.0d-9)
5642  fe(ixc^s,idir)=zero
5643  end where
5644  end if
5645  end if
5646  end do
5647  end do
5648  end do
5649 
5650  ! allow user to change inductive electric field, especially for boundary driven applications
5651  if(associated(usr_set_electric_field)) &
5652  call usr_set_electric_field(ixi^l,ixo^l,qt,qdt,fe,sct)
5653 
5654  circ(ixi^s,1:ndim)=zero
5655 
5656  ! Calculate circulation on each face
5657 
5658  do idim1=1,ndim ! Coordinate perpendicular to face
5659  do idim2=1,ndim
5660  do idir=sdim,3 ! Direction of line integral
5661  ! Assemble indices
5662  hxc^l=ixc^l-kr(idim2,^d);
5663  ! Add line integrals in direction idir
5664  circ(ixc^s,idim1)=circ(ixc^s,idim1)&
5665  +lvc(idim1,idim2,idir)&
5666  *(fe(ixc^s,idir)&
5667  -fe(hxc^s,idir))
5668  end do
5669  end do
5670  end do
5671 
5672  ! Divide by the area of the face to get dB/dt
5673  do idim1=1,ndim
5674  ixcmax^d=ixomax^d;
5675  ixcmin^d=ixomin^d-kr(idim1,^d);
5676  where(s%surfaceC(ixc^s,idim1) > 1.0d-9*s%dvolume(ixc^s))
5677  circ(ixc^s,idim1)=circ(ixc^s,idim1)/s%surfaceC(ixc^s,idim1)
5678  elsewhere
5679  circ(ixc^s,idim1)=zero
5680  end where
5681  ! Time update
5682  bfaces(ixc^s,idim1)=bfaces(ixc^s,idim1)-circ(ixc^s,idim1)
5683  end do
5684 
5685  end associate
5686 
5687  end subroutine update_faces_average
5688 
5689  !> update faces using UCT contact mode by Gardiner and Stone 2005 JCP 205, 509
5690  subroutine update_faces_contact(ixI^L,ixO^L,qt,qdt,wp,fC,fE,sCT,s,vcts)
5692  use mod_usr_methods
5693 
5694  integer, intent(in) :: ixI^L, ixO^L
5695  double precision, intent(in) :: qt, qdt
5696  ! cell-center primitive variables
5697  double precision, intent(in) :: wp(ixI^S,1:nw)
5698  type(state) :: sCT, s
5699  type(ct_velocity) :: vcts
5700  double precision, intent(in) :: fC(ixI^S,1:nwflux,1:ndim)
5701  double precision, intent(inout) :: fE(ixI^S,sdim:3)
5702 
5703  double precision :: circ(ixI^S,1:ndim)
5704  ! electric field at cell centers
5705  double precision :: ECC(ixI^S,sdim:3)
5706  ! gradient of E at left and right side of a cell face
5707  double precision :: EL(ixI^S),ER(ixI^S)
5708  ! gradient of E at left and right side of a cell corner
5709  double precision :: ELC(ixI^S),ERC(ixI^S)
5710  ! non-ideal electric field on cell edges
5711  double precision, dimension(ixI^S,sdim:3) :: E_resi, E_ambi
5712  ! total magnetic field at cell centers
5713  double precision :: Btot(ixI^S,1:ndim)
5714  integer :: hxC^L,ixC^L,jxC^L,ixA^L,ixB^L
5715  integer :: idim1,idim2,idir,iwdim1,iwdim2
5716 
5717  associate(bfaces=>s%ws,x=>s%x,w=>s%w,vnorm=>vcts%vnorm)
5718 
5719  if(b0field) then
5720  btot(ixi^s,1:ndim)=wp(ixi^s,mag(1:ndim))+block%B0(ixi^s,1:ndim,0)
5721  else
5722  btot(ixi^s,1:ndim)=wp(ixi^s,mag(1:ndim))
5723  end if
5724  ecc=0.d0
5725  ! Calculate electric field at cell centers
5726  do idim1=1,ndim; do idim2=1,ndim; do idir=sdim,3
5727  if(lvc(idim1,idim2,idir)==1)then
5728  ecc(ixi^s,idir)=ecc(ixi^s,idir)+btot(ixi^s,idim1)*wp(ixi^s,mom_c(idim2))
5729  else if(lvc(idim1,idim2,idir)==-1) then
5730  ecc(ixi^s,idir)=ecc(ixi^s,idir)-btot(ixi^s,idim1)*wp(ixi^s,mom_c(idim2))
5731  endif
5732  enddo; enddo; enddo
5733 
5734  ! if there is resistivity, get eta J
5735  if(twofl_eta/=zero) call get_resistive_electric_field(ixi^l,ixo^l,sct,s,e_resi)
5736  ! Calculate contribution to FEM of each edge,
5737  ! that is, estimate value of line integral of
5738  ! electric field in the positive idir direction.
5739  fe=zero
5740  ! evaluate electric field along cell edges according to equation (41)
5741  do idim1=1,ndim
5742  iwdim1 = mag(idim1)
5743  do idim2=1,ndim
5744  iwdim2 = mag(idim2)
5745  do idir=sdim,3 ! Direction of line integral
5746  ! Allow only even permutations
5747  if (lvc(idim1,idim2,idir)==1) then
5748  ixcmax^d=ixomax^d;
5749  ixcmin^d=ixomin^d+kr(idir,^d)-1;
5750  ! Assemble indices
5751  jxc^l=ixc^l+kr(idim1,^d);
5752  hxc^l=ixc^l+kr(idim2,^d);
5753  ! average cell-face electric field to cell edges
5754  fe(ixc^s,idir)=quarter*&
5755  (fc(ixc^s,iwdim1,idim2)+fc(jxc^s,iwdim1,idim2)&
5756  -fc(ixc^s,iwdim2,idim1)-fc(hxc^s,iwdim2,idim1))
5757 
5758  ! add slope in idim2 direction from equation (50)
5759  ixamin^d=ixcmin^d;
5760  ixamax^d=ixcmax^d+kr(idim1,^d);
5761  el(ixa^s)=fc(ixa^s,iwdim1,idim2)-ecc(ixa^s,idir)
5762  hxc^l=ixa^l+kr(idim2,^d);
5763  er(ixa^s)=fc(ixa^s,iwdim1,idim2)-ecc(hxc^s,idir)
5764  where(vnorm(ixc^s,idim1)>0.d0)
5765  elc(ixc^s)=el(ixc^s)
5766  else where(vnorm(ixc^s,idim1)<0.d0)
5767  elc(ixc^s)=el(jxc^s)
5768  else where
5769  elc(ixc^s)=0.5d0*(el(ixc^s)+el(jxc^s))
5770  end where
5771  hxc^l=ixc^l+kr(idim2,^d);
5772  where(vnorm(hxc^s,idim1)>0.d0)
5773  erc(ixc^s)=er(ixc^s)
5774  else where(vnorm(hxc^s,idim1)<0.d0)
5775  erc(ixc^s)=er(jxc^s)
5776  else where
5777  erc(ixc^s)=0.5d0*(er(ixc^s)+er(jxc^s))
5778  end where
5779  fe(ixc^s,idir)=fe(ixc^s,idir)+0.25d0*(elc(ixc^s)+erc(ixc^s))
5780 
5781  ! add slope in idim1 direction from equation (50)
5782  jxc^l=ixc^l+kr(idim2,^d);
5783  ixamin^d=ixcmin^d;
5784  ixamax^d=ixcmax^d+kr(idim2,^d);
5785  el(ixa^s)=-fc(ixa^s,iwdim2,idim1)-ecc(ixa^s,idir)
5786  hxc^l=ixa^l+kr(idim1,^d);
5787  er(ixa^s)=-fc(ixa^s,iwdim2,idim1)-ecc(hxc^s,idir)
5788  where(vnorm(ixc^s,idim2)>0.d0)
5789  elc(ixc^s)=el(ixc^s)
5790  else where(vnorm(ixc^s,idim2)<0.d0)
5791  elc(ixc^s)=el(jxc^s)
5792  else where
5793  elc(ixc^s)=0.5d0*(el(ixc^s)+el(jxc^s))
5794  end where
5795  hxc^l=ixc^l+kr(idim1,^d);
5796  where(vnorm(hxc^s,idim2)>0.d0)
5797  erc(ixc^s)=er(ixc^s)
5798  else where(vnorm(hxc^s,idim2)<0.d0)
5799  erc(ixc^s)=er(jxc^s)
5800  else where
5801  erc(ixc^s)=0.5d0*(er(ixc^s)+er(jxc^s))
5802  end where
5803  fe(ixc^s,idir)=fe(ixc^s,idir)+0.25d0*(elc(ixc^s)+erc(ixc^s))
5804 
5805  ! add current component of electric field at cell edges E=-vxB+eta J
5806  if(twofl_eta/=zero) fe(ixc^s,idir)=fe(ixc^s,idir)+e_resi(ixc^s,idir)
5807  ! times time step and edge length
5808  fe(ixc^s,idir)=fe(ixc^s,idir)*qdt*s%dsC(ixc^s,idir)
5809  if (.not.slab) then
5810  where(abs(x(ixc^s,r_)+half*dxlevel(r_))<1.0d-9)
5811  fe(ixc^s,idir)=zero
5812  end where
5813  end if
5814  end if
5815  end do
5816  end do
5817  end do
5818 
5819  ! allow user to change inductive electric field, especially for boundary driven applications
5820  if(associated(usr_set_electric_field)) &
5821  call usr_set_electric_field(ixi^l,ixo^l,qt,qdt,fe,sct)
5822 
5823  circ(ixi^s,1:ndim)=zero
5824 
5825  ! Calculate circulation on each face
5826  do idim1=1,ndim ! Coordinate perpendicular to face
5827  ixcmax^d=ixomax^d;
5828  ixcmin^d=ixomin^d-kr(idim1,^d);
5829  do idim2=1,ndim
5830  do idir=sdim,3 ! Direction of line integral
5831  ! Assemble indices
5832  hxc^l=ixc^l-kr(idim2,^d);
5833  ! Add line integrals in direction idir
5834  circ(ixc^s,idim1)=circ(ixc^s,idim1)&
5835  +lvc(idim1,idim2,idir)&
5836  *(fe(ixc^s,idir)&
5837  -fe(hxc^s,idir))
5838  end do
5839  end do
5840  ! Divide by the area of the face to get dB/dt
5841  ixcmax^d=ixomax^d;
5842  ixcmin^d=ixomin^d-kr(idim1,^d);
5843  where(s%surfaceC(ixc^s,idim1) > 1.0d-9*s%dvolume(ixc^s))
5844  circ(ixc^s,idim1)=circ(ixc^s,idim1)/s%surfaceC(ixc^s,idim1)
5845  elsewhere
5846  circ(ixc^s,idim1)=zero
5847  end where
5848  ! Time update cell-face magnetic field component
5849  bfaces(ixc^s,idim1)=bfaces(ixc^s,idim1)-circ(ixc^s,idim1)
5850  end do
5851 
5852  end associate
5853 
5854  end subroutine update_faces_contact
5855 
5856  !> update faces
5857  subroutine update_faces_hll(ixI^L,ixO^L,qt,qdt,fE,sCT,s,vcts)
5860  use mod_usr_methods
5861 
5862  integer, intent(in) :: ixI^L, ixO^L
5863  double precision, intent(in) :: qt, qdt
5864  double precision, intent(inout) :: fE(ixI^S,sdim:3)
5865  type(state) :: sCT, s
5866  type(ct_velocity) :: vcts
5867 
5868  double precision :: vtilL(ixI^S,2)
5869  double precision :: vtilR(ixI^S,2)
5870  double precision :: bfacetot(ixI^S,ndim)
5871  double precision :: btilL(s%ixGs^S,ndim)
5872  double precision :: btilR(s%ixGs^S,ndim)
5873  double precision :: cp(ixI^S,2)
5874  double precision :: cm(ixI^S,2)
5875  double precision :: circ(ixI^S,1:ndim)
5876  ! non-ideal electric field on cell edges
5877  double precision, dimension(ixI^S,sdim:3) :: E_resi, E_ambi
5878  integer :: hxC^L,ixC^L,ixCp^L,jxC^L,ixCm^L
5879  integer :: idim1,idim2,idir
5880 
5881  associate(bfaces=>s%ws,bfacesct=>sct%ws,x=>s%x,vbarc=>vcts%vbarC,cbarmin=>vcts%cbarmin,&
5882  cbarmax=>vcts%cbarmax)
5883 
5884  ! Calculate contribution to FEM of each edge,
5885  ! that is, estimate value of line integral of
5886  ! electric field in the positive idir direction.
5887 
5888  ! Loop over components of electric field
5889 
5890  ! idir: electric field component we need to calculate
5891  ! idim1: directions in which we already performed the reconstruction
5892  ! idim2: directions in which we perform the reconstruction
5893 
5894  ! if there is resistivity, get eta J
5895  if(twofl_eta/=zero) call get_resistive_electric_field(ixi^l,ixo^l,sct,s,e_resi)
5896  fe=zero
5897 
5898  do idir=sdim,3
5899  ! Indices
5900  ! idir: electric field component
5901  ! idim1: one surface
5902  ! idim2: the other surface
5903  ! cyclic permutation: idim1,idim2,idir=1,2,3
5904  ! Velocity components on the surface
5905  ! follow cyclic premutations:
5906  ! Sx(1),Sx(2)=y,z ; Sy(1),Sy(2)=z,x ; Sz(1),Sz(2)=x,y
5907 
5908  ixcmax^d=ixomax^d;
5909  ixcmin^d=ixomin^d-1+kr(idir,^d);
5910 
5911  ! Set indices and directions
5912  idim1=mod(idir,3)+1
5913  idim2=mod(idir+1,3)+1
5914 
5915  jxc^l=ixc^l+kr(idim1,^d);
5916  ixcp^l=ixc^l+kr(idim2,^d);
5917 
5918  ! Reconstruct transverse transport velocities
5919  call reconstruct(ixi^l,ixc^l,idim2,vbarc(ixi^s,idim1,1),&
5920  vtill(ixi^s,2),vtilr(ixi^s,2))
5921 
5922  call reconstruct(ixi^l,ixc^l,idim1,vbarc(ixi^s,idim2,2),&
5923  vtill(ixi^s,1),vtilr(ixi^s,1))
5924 
5925  ! Reconstruct magnetic fields
5926  ! Eventhough the arrays are larger, reconstruct works with
5927  ! the limits ixG.
5928  if(b0field) then
5929  bfacetot(ixi^s,idim1)=bfacesct(ixi^s,idim1)+block%B0(ixi^s,idim1,idim1)
5930  bfacetot(ixi^s,idim2)=bfacesct(ixi^s,idim2)+block%B0(ixi^s,idim2,idim2)
5931  else
5932  bfacetot(ixi^s,idim1)=bfacesct(ixi^s,idim1)
5933  bfacetot(ixi^s,idim2)=bfacesct(ixi^s,idim2)
5934  end if
5935  call reconstruct(ixi^l,ixc^l,idim2,bfacetot(ixi^s,idim1),&
5936  btill(ixi^s,idim1),btilr(ixi^s,idim1))
5937 
5938  call reconstruct(ixi^l,ixc^l,idim1,bfacetot(ixi^s,idim2),&
5939  btill(ixi^s,idim2),btilr(ixi^s,idim2))
5940 
5941  ! Take the maximum characteristic
5942 
5943  cm(ixc^s,1)=max(cbarmin(ixcp^s,idim1),cbarmin(ixc^s,idim1))
5944  cp(ixc^s,1)=max(cbarmax(ixcp^s,idim1),cbarmax(ixc^s,idim1))
5945 
5946  cm(ixc^s,2)=max(cbarmin(jxc^s,idim2),cbarmin(ixc^s,idim2))
5947  cp(ixc^s,2)=max(cbarmax(jxc^s,idim2),cbarmax(ixc^s,idim2))
5948 
5949 
5950  ! Calculate eletric field
5951  fe(ixc^s,idir)=-(cp(ixc^s,1)*vtill(ixc^s,1)*btill(ixc^s,idim2) &
5952  + cm(ixc^s,1)*vtilr(ixc^s,1)*btilr(ixc^s,idim2) &
5953  - cp(ixc^s,1)*cm(ixc^s,1)*(btilr(ixc^s,idim2)-btill(ixc^s,idim2)))&
5954  /(cp(ixc^s,1)+cm(ixc^s,1)) &
5955  +(cp(ixc^s,2)*vtill(ixc^s,2)*btill(ixc^s,idim1) &
5956  + cm(ixc^s,2)*vtilr(ixc^s,2)*btilr(ixc^s,idim1) &
5957  - cp(ixc^s,2)*cm(ixc^s,2)*(btilr(ixc^s,idim1)-btill(ixc^s,idim1)))&
5958  /(cp(ixc^s,2)+cm(ixc^s,2))
5959 
5960  ! add current component of electric field at cell edges E=-vxB+eta J
5961  if(twofl_eta/=zero) fe(ixc^s,idir)=fe(ixc^s,idir)+e_resi(ixc^s,idir)
5962  fe(ixc^s,idir)=qdt*s%dsC(ixc^s,idir)*fe(ixc^s,idir)
5963 
5964  if (.not.slab) then
5965  where(abs(x(ixc^s,r_)+half*dxlevel(r_)).lt.1.0d-9)
5966  fe(ixc^s,idir)=zero
5967  end where
5968  end if
5969 
5970  end do
5971 
5972  ! allow user to change inductive electric field, especially for boundary driven applications
5973  if(associated(usr_set_electric_field)) &
5974  call usr_set_electric_field(ixi^l,ixo^l,qt,qdt,fe,sct)
5975 
5976  circ(ixi^s,1:ndim)=zero
5977 
5978  ! Calculate circulation on each face: interal(fE dot dl)
5979 
5980  do idim1=1,ndim ! Coordinate perpendicular to face
5981  ixcmax^d=ixomax^d;
5982  ixcmin^d=ixomin^d-kr(idim1,^d);
5983  do idim2=1,ndim
5984  do idir=sdim,3 ! Direction of line integral
5985  ! Assemble indices
5986  hxc^l=ixc^l-kr(idim2,^d);
5987  ! Add line integrals in direction idir
5988  circ(ixc^s,idim1)=circ(ixc^s,idim1)&
5989  +lvc(idim1,idim2,idir)&
5990  *(fe(ixc^s,idir)&
5991  -fe(hxc^s,idir))
5992  end do
5993  end do
5994  end do
5995 
5996  ! Divide by the area of the face to get dB/dt
5997  do idim1=1,ndim
5998  ixcmax^d=ixomax^d;
5999  ixcmin^d=ixomin^d-kr(idim1,^d);
6000  where(s%surfaceC(ixc^s,idim1) > 1.0d-9*s%dvolume(ixc^s))
6001  circ(ixc^s,idim1)=circ(ixc^s,idim1)/s%surfaceC(ixc^s,idim1)
6002  elsewhere
6003  circ(ixc^s,idim1)=zero
6004  end where
6005  ! Time update
6006  bfaces(ixc^s,idim1)=bfaces(ixc^s,idim1)-circ(ixc^s,idim1)
6007  end do
6008 
6009  end associate
6010  end subroutine update_faces_hll
6011 
6012  !> calculate eta J at cell edges
6013  subroutine get_resistive_electric_field(ixI^L,ixO^L,sCT,s,jce)
6015  use mod_usr_methods
6016  use mod_geometry
6017 
6018  integer, intent(in) :: ixI^L, ixO^L
6019  type(state), intent(in) :: sCT, s
6020  ! current on cell edges
6021  double precision :: jce(ixI^S,sdim:3)
6022 
6023  ! current on cell centers
6024  double precision :: jcc(ixI^S,7-2*ndir:3)
6025  ! location at cell faces
6026  double precision :: xs(ixGs^T,1:ndim)
6027  ! resistivity
6028  double precision :: eta(ixI^S)
6029  double precision :: gradi(ixGs^T)
6030  integer :: ix^D,ixC^L,ixA^L,ixB^L,idir,idirmin,idim1,idim2
6031 
6032  associate(x=>s%x,dx=>s%dx,w=>s%w,wct=>sct%w,wcts=>sct%ws)
6033  ! calculate current density at cell edges
6034  jce=0.d0
6035  do idim1=1,ndim
6036  do idim2=1,ndim
6037  do idir=sdim,3
6038  if (lvc(idim1,idim2,idir)==0) cycle
6039  ixcmax^d=ixomax^d;
6040  ixcmin^d=ixomin^d+kr(idir,^d)-1;
6041  ixbmax^d=ixcmax^d-kr(idir,^d)+1;
6042  ixbmin^d=ixcmin^d;
6043  ! current at transverse faces
6044  xs(ixb^s,:)=x(ixb^s,:)
6045  xs(ixb^s,idim2)=x(ixb^s,idim2)+half*dx(ixb^s,idim2)
6046  call gradientx(wcts(ixgs^t,idim2),xs,ixgs^ll,ixc^l,idim1,gradi,.true.)
6047  if (lvc(idim1,idim2,idir)==1) then
6048  jce(ixc^s,idir)=jce(ixc^s,idir)+gradi(ixc^s)
6049  else
6050  jce(ixc^s,idir)=jce(ixc^s,idir)-gradi(ixc^s)
6051  end if
6052  end do
6053  end do
6054  end do
6055  ! get resistivity
6056  if(twofl_eta>zero)then
6057  jce(ixi^s,:)=jce(ixi^s,:)*twofl_eta
6058  else
6059  ixa^l=ixo^l^ladd1;
6060  call get_current(wct,ixi^l,ixa^l,idirmin,jcc)
6061  call usr_special_resistivity(wct,ixi^l,ixa^l,idirmin,x,jcc,eta)
6062  ! calcuate eta on cell edges
6063  do idir=sdim,3
6064  ixcmax^d=ixomax^d;
6065  ixcmin^d=ixomin^d+kr(idir,^d)-1;
6066  jcc(ixc^s,idir)=0.d0
6067  {do ix^db=0,1\}
6068  if({ ix^d==1 .and. ^d==idir | .or.}) cycle
6069  ixamin^d=ixcmin^d+ix^d;
6070  ixamax^d=ixcmax^d+ix^d;
6071  jcc(ixc^s,idir)=jcc(ixc^s,idir)+eta(ixa^s)
6072  {end do\}
6073  jcc(ixc^s,idir)=jcc(ixc^s,idir)*0.25d0
6074  jce(ixc^s,idir)=jce(ixc^s,idir)*jcc(ixc^s,idir)
6075  enddo
6076  end if
6077 
6078  end associate
6079  end subroutine get_resistive_electric_field
6080 
6081  !> calculate cell-center values from face-center values
6082  subroutine twofl_face_to_center(ixO^L,s)
6084  ! Non-staggered interpolation range
6085  integer, intent(in) :: ixo^l
6086  type(state) :: s
6087 
6088  integer :: fxo^l, gxo^l, hxo^l, jxo^l, kxo^l, idim
6089 
6090  associate(w=>s%w, ws=>s%ws)
6091 
6092  ! calculate cell-center values from face-center values in 2nd order
6093  do idim=1,ndim
6094  ! Displace index to the left
6095  ! Even if ixI^L is the full size of the w arrays, this is ok
6096  ! because the staggered arrays have an additional place to the left.
6097  hxo^l=ixo^l-kr(idim,^d);
6098  ! Interpolate to cell barycentre using arithmetic average
6099  ! This might be done better later, to make the method less diffusive.
6100  w(ixo^s,mag(idim))=half/s%surface(ixo^s,idim)*&
6101  (ws(ixo^s,idim)*s%surfaceC(ixo^s,idim)&
6102  +ws(hxo^s,idim)*s%surfaceC(hxo^s,idim))
6103  end do
6104 
6105  ! calculate cell-center values from face-center values in 4th order
6106  !do idim=1,ndim
6107  ! gxO^L=ixO^L-2*kr(idim,^D);
6108  ! hxO^L=ixO^L-kr(idim,^D);
6109  ! jxO^L=ixO^L+kr(idim,^D);
6110 
6111  ! ! Interpolate to cell barycentre using fourth order central formula
6112  ! w(ixO^S,mag(idim))=(0.0625d0/s%surface(ixO^S,idim))*&
6113  ! ( -ws(gxO^S,idim)*s%surfaceC(gxO^S,idim) &
6114  ! +9.0d0*ws(hxO^S,idim)*s%surfaceC(hxO^S,idim) &
6115  ! +9.0d0*ws(ixO^S,idim)*s%surfaceC(ixO^S,idim) &
6116  ! -ws(jxO^S,idim)*s%surfaceC(jxO^S,idim) )
6117  !end do
6118 
6119  ! calculate cell-center values from face-center values in 6th order
6120  !do idim=1,ndim
6121  ! fxO^L=ixO^L-3*kr(idim,^D);
6122  ! gxO^L=ixO^L-2*kr(idim,^D);
6123  ! hxO^L=ixO^L-kr(idim,^D);
6124  ! jxO^L=ixO^L+kr(idim,^D);
6125  ! kxO^L=ixO^L+2*kr(idim,^D);
6126 
6127  ! ! Interpolate to cell barycentre using sixth order central formula
6128  ! w(ixO^S,mag(idim))=(0.00390625d0/s%surface(ixO^S,idim))* &
6129  ! ( +3.0d0*ws(fxO^S,idim)*s%surfaceC(fxO^S,idim) &
6130  ! -25.0d0*ws(gxO^S,idim)*s%surfaceC(gxO^S,idim) &
6131  ! +150.0d0*ws(hxO^S,idim)*s%surfaceC(hxO^S,idim) &
6132  ! +150.0d0*ws(ixO^S,idim)*s%surfaceC(ixO^S,idim) &
6133  ! -25.0d0*ws(jxO^S,idim)*s%surfaceC(jxO^S,idim) &
6134  ! +3.0d0*ws(kxO^S,idim)*s%surfaceC(kxO^S,idim) )
6135  !end do
6136 
6137  end associate
6138 
6139  end subroutine twofl_face_to_center
6140 
6141  !> calculate magnetic field from vector potential
6142  subroutine b_from_vector_potential(ixIs^L, ixI^L, ixO^L, ws, x)
6145 
6146  integer, intent(in) :: ixis^l, ixi^l, ixo^l
6147  double precision, intent(inout) :: ws(ixis^s,1:nws)
6148  double precision, intent(in) :: x(ixi^s,1:ndim)
6149 
6150  double precision :: adummy(ixis^s,1:3)
6151 
6152  call b_from_vector_potentiala(ixis^l, ixi^l, ixo^l, ws, x, adummy)
6153 
6154  end subroutine b_from_vector_potential
6155 
6156  subroutine hyperdiffusivity_get_dt(w,ixI^L,ixO^L,dtnew,dx^D,x)
6159  integer, intent(in) :: ixI^L, ixO^L
6160  double precision, intent(in) :: w(ixI^S,1:nw)
6161  double precision, intent(in) :: x(ixI^S,1:ndim)
6162  double precision, intent(in) :: dx^D
6163  double precision, intent(inout) :: dtnew
6164 
6165  double precision :: nu(ixI^S),tmp(ixI^S),rho(ixI^S),temp(ixI^S)
6166  double precision :: divv(ixI^S,1:ndim)
6167  double precision :: vel(ixI^S,1:ndir)
6168  double precision :: csound(ixI^S),csound_dim(ixI^S,1:ndim)
6169  double precision :: dxarr(ndim)
6170  double precision :: maxCoef
6171  integer :: ixOO^L, hxb^L, hx^L, ii, jj
6172 
6173 
6174  ^d&dxarr(^d)=dx^d;
6175  maxcoef = smalldouble
6176 
6177  ! charges
6178  call twofl_get_v_c(w,x,ixi^l,ixi^l,vel)
6179  call get_rhoc_tot(w,x,ixi^l,ixi^l,rho)
6180  call twofl_get_csound2_c_from_conserved(w,x,ixi^l,ixi^l,csound)
6181  csound(ixi^s) = sqrt(csound(ixi^s)) + sqrt(twofl_mag_en_all(w,ixi^l,ixi^l) /rho(ixi^s))
6182  csound(ixi^s) = csound(ixi^s) + sqrt(sum(vel(ixi^s,1:ndir)**2 ,dim=ndim+1))
6183  do ii=1,ndim
6184  call div_vel_coeff(ixi^l, ixoo^l, vel, ii, divv(ixi^s,ii))
6185  hxmin^d=iximin^d+1;
6186  hxmax^d=iximax^d-1;
6187  hxb^l=hx^l-kr(ii,^d);
6188  csound_dim(hx^s,ii) = (csound(hxb^s)+csound(hx^s))/2d0
6189  enddo
6190  call twofl_get_temp_c_pert_from_etot(w, x, ixi^l, ixi^l, temp)
6191  do ii=1,ndim
6192  !TODO the following is copied
6193  !rho_c
6194  call hyp_coeff(ixi^l, ixoo^l, w(ixi^s,rho_c_), ii, tmp(ixi^s))
6195  nu(ixo^s) = c_hyp(rho_c_) * csound_dim(ixo^s,ii) * dxlevel(ii) * tmp(ixo^s) + &
6196  c_shk(rho_c_) * (dxlevel(ii)**2) *divv(ixo^s,ii)
6197  maxcoef = max(maxcoef,maxval(nu(ixo^s)))
6198 
6199  !TH c
6200  call hyp_coeff(ixi^l, ixoo^l, temp(ixi^s), ii, tmp(ixi^s))
6201  nu(ixo^s) = c_hyp(e_c_) * csound_dim(ixo^s,ii) * dxlevel(ii) * tmp(ixo^s) + &
6202  c_shk(e_c_) * (dxlevel(ii)**2) *divv(ixo^s,ii)
6203  nu(ixo^s) = nu(ixo^s) * rho(ixo^s) * rc/(twofl_gamma-1d0)
6204  maxcoef = max(maxcoef,maxval(nu(ixo^s)))
6205 
6206  !visc c
6207  do jj=1,ndir
6208  call hyp_coeff(ixi^l, ixoo^l, vel(ixi^s,jj), ii, tmp(ixi^s))
6209  nu(ixo^s) = c_hyp(mom_c(jj)) * csound_dim(ixo^s,ii) * dxlevel(ii) * tmp(ixo^s) + &
6210  c_shk(mom_c(jj)) * (dxlevel(ii)**2) *divv(ixo^s,ii)
6211  nu(ixo^s) = nu(ixo^s) * rho(ixo^s)
6212  maxcoef = max(maxcoef,maxval(nu(ixo^s)))
6213  enddo
6214 
6215  ! Ohmic
6216  do jj=1,ndir
6217  if(ii .ne. jj) then
6218  call hyp_coeff(ixi^l, ixoo^l, w(ixi^s,mag(jj)), ii, tmp(ixi^s))
6219  nu(ixo^s) = c_hyp(mag(jj)) * csound_dim(ixo^s,ii) * dxlevel(ii) * tmp(ixo^s) + &
6220  c_shk(mag(jj)) * (dxlevel(ii)**2) *divv(ixo^s,ii)
6221  maxcoef = max(maxcoef,maxval(nu(ixo^s)))
6222  endif
6223  enddo
6224 
6225  enddo
6226 
6227  !TODO the following is copied, as charges, and as in add_source!
6228  ! neutrals
6229  call twofl_get_v_n(w,x,ixi^l,ixi^l,vel)
6230  call twofl_get_csound_n(w,x,ixi^l,ixi^l,csound)
6231  csound(ixi^s) = csound(ixi^s) + sqrt(sum(vel(ixi^s,1:ndir)**2 ,dim=ndim+1))
6232  do ii=1,ndim
6233  call div_vel_coeff(ixi^l, ixoo^l, vel, ii, divv(ixi^s,ii))
6234  hxmin^d=iximin^d+1;
6235  hxmax^d=iximax^d-1;
6236  hxb^l=hx^l-kr(ii,^d);
6237  csound_dim(hx^s,ii) = (csound(hxb^s)+csound(hx^s))/2d0
6238  enddo
6239  call get_rhon_tot(w,x,ixi^l,ixo^l,rho)
6240  call twofl_get_temp_n_pert_from_etot(w, x, ixi^l, ixi^l, temp)
6241  do ii=1,ndim
6242  !rho_n
6243  call hyp_coeff(ixi^l, ixoo^l, w(ixi^s,rho_n_), ii, tmp(ixi^s))
6244  nu(ixo^s) = c_hyp(rho_n_) * csound_dim(ixo^s,ii) * dxlevel(ii) * tmp(ixo^s) + &
6245  c_shk(rho_n_) * (dxlevel(ii)**2) *divv(ixoo^s,ii)
6246  maxcoef = max(maxcoef,maxval(nu(ixo^s)))
6247 
6248  !TH n
6249  call hyp_coeff(ixi^l, ixoo^l, temp(ixi^s), ii, tmp(ixi^s))
6250  nu(ixo^s) = c_hyp(e_n_) * csound_dim(ixo^s,ii) * dxlevel(ii) * tmp(ixo^s) + &
6251  c_shk(e_n_) * (dxlevel(ii)**2) *divv(ixo^s,ii)
6252  nu(ixo^s) = nu(ixo^s) * rho(ixo^s) * rn/(twofl_gamma-1d0)
6253  maxcoef = max(maxcoef,maxval(nu(ixo^s)))
6254 
6255  !visc n
6256  do jj=1,ndir
6257  call hyp_coeff(ixi^l, ixoo^l, vel(ixi^s,jj), ii, tmp(ixi^s))
6258  nu(ixo^s) = c_hyp(mom_n(jj)) * csound_dim(ixo^s,ii) * dxlevel(ii) * tmp(ixo^s) + &
6259  c_shk(mom_n(jj)) * (dxlevel(ii)**2) *divv(ixo^s,ii)
6260  nu(ixo^s) = nu(ixo^s) * rho(ixo^s)
6261  maxcoef = max(maxcoef,maxval(nu(ixo^s)))
6262  enddo
6263  enddo
6264 
6265  dtnew=min(dtdiffpar*minval(dxarr(1:ndim))**2/maxcoef,dtnew)
6266  end subroutine hyperdiffusivity_get_dt
6267 
6268  subroutine add_source_hyperdiffusive(qdt,ixI^L,ixO^L,w,wCT,x)
6271 
6272  integer, intent(in) :: ixI^L, ixO^L
6273  double precision, intent(in) :: qdt, x(ixI^S,1:ndim)
6274  double precision, intent(inout) :: w(ixI^S,1:nw)
6275  double precision, intent(in) :: wCT(ixI^S,1:nw)
6276 
6277  double precision :: divv(ixI^S,1:ndim)
6278  double precision :: vel(ixI^S,1:ndir)
6279  double precision :: csound(ixI^S),csound_dim(ixI^S,1:ndim)
6280  integer :: ii,ixOO^L,hxb^L,hx^L
6281  double precision :: rho(ixI^S)
6282 
6283  call twofl_get_v_c(wct,x,ixi^l,ixi^l,vel)
6284  call get_rhoc_tot(wct,x,ixi^l,ixi^l,rho)
6285  call twofl_get_csound2_c_from_conserved(wct,x,ixi^l,ixi^l,csound)
6286  csound(ixi^s) = sqrt(csound(ixi^s)) + sqrt(twofl_mag_en_all(wct,ixi^l,ixi^l) /rho(ixi^s))
6287  csound(ixi^s) = csound(ixi^s) + sqrt(sum(vel(ixi^s,1:ndir)**2 ,dim=ndim+1))
6288  do ii=1,ndim
6289  call div_vel_coeff(ixi^l, ixoo^l, vel, ii, divv(ixi^s,ii))
6290  hxmin^d=iximin^d+1;
6291  hxmax^d=iximax^d-1;
6292  hxb^l=hx^l-kr(ii,^d);
6293  csound_dim(hx^s,ii) = (csound(hxb^s)+csound(hx^s))/2d0
6294  enddo
6296  call add_viscosity_hyper_source(rho,mom_c(1), e_c_)
6297  call add_th_cond_c_hyper_source(rho)
6298  call add_ohmic_hyper_source()
6299 
6300  call twofl_get_v_n(wct,x,ixi^l,ixi^l,vel)
6301  call twofl_get_csound_n(wct,x,ixi^l,ixi^l,csound)
6302  csound(ixi^s) = csound(ixi^s) + sqrt(sum(vel(ixi^s,1:ndir)**2 ,dim=ndim+1))
6303  do ii=1,ndim
6304  call div_vel_coeff(ixi^l, ixoo^l, vel, ii, divv(ixi^s,ii))
6305  hxmin^d=iximin^d+1;
6306  hxmax^d=iximax^d-1;
6307  hxb^l=hx^l-kr(ii,^d);
6308  csound_dim(hx^s,ii) = (csound(hxb^s)+csound(hx^s))/2d0
6309  enddo
6311  call get_rhon_tot(wct,x,ixi^l,ixi^l,rho)
6312  call add_viscosity_hyper_source(rho,mom_n(1), e_n_)
6313  call add_th_cond_n_hyper_source(rho)
6314 
6315  contains
6316 
6317  subroutine add_density_hyper_source(index_rho)
6318  integer, intent(in) :: index_rho
6319 
6320  double precision :: nu(ixI^S), tmp(ixI^S)
6321 
6322  do ii=1,ndim
6323  call hyp_coeff(ixi^l, ixoo^l, wct(ixi^s,index_rho), ii, tmp(ixi^s))
6324  nu(ixoo^s) = c_hyp(index_rho) * csound_dim(ixoo^s,ii) * dxlevel(ii) * tmp(ixoo^s) + &
6325  c_shk(index_rho) * (dxlevel(ii)**2) *divv(ixoo^s,ii)
6326  !print*, "IXOO HYP ", ixOO^L, " IDIMM ", ii
6327  call second_same_deriv(ixi^l, ixoo^l, nu(ixi^s), wct(ixi^s,index_rho), ii, tmp)
6328 
6329  w(ixo^s,index_rho) = w(ixo^s,index_rho) + qdt * tmp(ixo^s)
6330  !print*, "RHO ", index_rho, maxval(abs(tmp(ixO^S)))
6331  enddo
6332  end subroutine add_density_hyper_source
6333 
6334  subroutine add_th_cond_c_hyper_source(var2)
6335  double precision, intent(in) :: var2(ixI^S)
6336  double precision :: nu(ixI^S), tmp(ixI^S), var(ixI^S)
6337  call twofl_get_temp_c_pert_from_etot(wct, x, ixi^l, ixi^l, var)
6338  do ii=1,ndim
6339  call hyp_coeff(ixi^l, ixoo^l, var(ixi^s), ii, tmp(ixi^s))
6340  nu(ixoo^s) = c_hyp(e_c_) * csound_dim(ixoo^s,ii) * dxlevel(ii) * tmp(ixoo^s) + &
6341  c_shk(e_c_) * (dxlevel(ii)**2) *divv(ixoo^s,ii)
6342  call second_same_deriv2(ixi^l, ixoo^l, nu(ixi^s), var2(ixi^s) ,var(ixi^s), ii, tmp)
6343  w(ixo^s,e_c_) = w(ixo^s,e_c_) + qdt * tmp(ixo^s) * rc/(twofl_gamma-1d0)
6344  !print*, "TH C ", maxval(abs(tmp(ixO^S)))
6345  enddo
6346  end subroutine add_th_cond_c_hyper_source
6347 
6348  subroutine add_th_cond_n_hyper_source(var2)
6349  double precision, intent(in) :: var2(ixI^S)
6350  double precision :: nu(ixI^S), tmp(ixI^S), var(ixI^S)
6351  call twofl_get_temp_n_pert_from_etot(wct, x, ixi^l, ixi^l, var)
6352  do ii=1,ndim
6353  call hyp_coeff(ixi^l, ixoo^l, var(ixi^s), ii, tmp(ixi^s))
6354  nu(ixoo^s) = c_hyp(e_n_) * csound_dim(ixoo^s,ii) * dxlevel(ii) * tmp(ixoo^s) + &
6355  c_shk(e_n_) * (dxlevel(ii)**2) *divv(ixoo^s,ii)
6356  call second_same_deriv2(ixi^l, ixoo^l, nu(ixi^s), var2(ixi^s) ,var(ixi^s), ii, tmp)
6357  w(ixo^s,e_n_) = w(ixo^s,e_n_) + qdt * tmp(ixo^s) * rn/(twofl_gamma-1d0)
6358  !print*, "TH N ", maxval(abs(tmp(ixO^S)))
6359  enddo
6360  end subroutine add_th_cond_n_hyper_source
6361 
6362  subroutine add_viscosity_hyper_source(rho,index_mom1, index_e)
6363  double precision, intent(in) :: rho(ixI^S)
6364  integer, intent(in) :: index_mom1, index_e
6365 
6366  double precision :: nu(ixI^S,1:ndir,1:ndim), tmp(ixI^S),tmp2(ixI^S)
6367  integer :: jj
6368 
6369  do jj=1,ndir
6370  do ii=1,ndim
6371  call hyp_coeff(ixi^l, ixoo^l, vel(ixi^s,jj), ii, tmp(ixi^s))
6372  nu(ixoo^s,jj,ii) = c_hyp(index_mom1-1+jj) * csound_dim(ixoo^s,ii) * dxlevel(ii) * tmp(ixoo^s) + &
6373  c_shk(index_mom1-1+jj) * (dxlevel(ii)**2) *divv(ixoo^s,ii)
6374  enddo
6375  enddo
6376 
6377  do jj=1,ndir
6378  do ii=1,ndim
6379  call second_same_deriv2(ixi^l, ixoo^l, nu(ixi^s,jj,ii), rho(ixi^s), vel(ixi^s,jj), ii, tmp)
6380  call second_same_deriv2(ixi^l, ixoo^l, nu(ixi^s,jj,ii), wct(ixi^s,index_mom1-1+jj), vel(ixi^s,jj), ii, tmp2)
6381  if(ii .eq. jj) then
6382  w(ixo^s,index_mom1-1+jj) = w(ixo^s,index_mom1-1+jj) + qdt * tmp(ixo^s)
6383  w(ixo^s,index_e) = w(ixo^s,index_e) + qdt * tmp2(ixo^s)
6384 
6385  else
6386  w(ixo^s,index_mom1-1+jj) = w(ixo^s,index_mom1-1+jj) + 0.5*qdt * tmp(ixo^s)
6387  w(ixo^s,index_e) = w(ixo^s,index_e) + 0.5*qdt * tmp2(ixo^s)
6388  call second_cross_deriv2(ixi^l, ixoo^l, nu(ixi^s,ii,jj), rho(ixi^s), vel(ixi^s,ii), jj, ii, tmp)
6389  w(ixo^s,index_mom1-1+jj) = w(ixo^s,index_mom1-1+jj) + 0.5*qdt * tmp(ixo^s)
6390  call second_cross_deriv2(ixi^l, ixoo^l, nu(ixi^s,jj,ii), wct(ixi^s,index_mom1-1+jj), vel(ixi^s,jj), ii, jj, tmp2)
6391  w(ixo^s,index_e) = w(ixo^s,index_e) + 0.5*qdt * tmp2(ixo^s)
6392  endif
6393 
6394  enddo
6395  enddo
6396 
6397  end subroutine add_viscosity_hyper_source
6398 
6399  subroutine add_ohmic_hyper_source()
6400  double precision :: nu(ixI^S,1:ndir,1:ndim), tmp(ixI^S)
6401  integer :: jj
6402 
6403  do jj=1,ndir
6404  do ii=1,ndim
6405  if(ii .ne. jj) then
6406  call hyp_coeff(ixi^l, ixoo^l, wct(ixi^s,mag(jj)), ii, tmp(ixi^s))
6407  nu(ixoo^s,jj,ii) = c_hyp(mag(jj)) * csound_dim(ixoo^s,ii) * dxlevel(ii) * tmp(ixoo^s) + &
6408  c_shk(mag(jj)) * (dxlevel(ii)**2) *divv(ixoo^s,ii)
6409  endif
6410  enddo
6411  enddo
6412 
6413  do jj=1,ndir
6414  do ii=1,ndim
6415  if(ii .ne. jj) then
6416  !mag field
6417  call second_same_deriv(ixi^l, ixoo^l, nu(ixi^s,jj,ii), wct(ixi^s,mag(jj)), ii, tmp)
6418  w(ixo^s,mag(jj)) = w(ixo^s,mag(jj)) + qdt * tmp(ixo^s)
6419  call second_cross_deriv(ixi^l, ixoo^l, nu(ixi^s,ii,jj), wct(ixi^s,mag(ii)), jj, ii, tmp)
6420  w(ixo^s,mag(jj)) = w(ixo^s,mag(jj)) + qdt * tmp(ixo^s)
6421  !in the total energy
6422  call second_same_deriv(ixi^l, ixoo^l, nu(ixi^s,jj,ii), wct(ixi^s,mag(jj)), ii, tmp)
6423  w(ixo^s,e_c_) = w(ixo^s,e_c_) + qdt * tmp(ixo^s)
6424  call second_cross_deriv2(ixi^l, ixoo^l, nu(ixi^s,ii,jj), wct(ixi^s,mag(jj)), wct(ixi^s,mag(ii)), jj, ii, tmp)
6425  w(ixo^s,e_c_) = w(ixo^s,e_c_) + qdt * tmp(ixo^s)
6426  endif
6427 
6428  enddo
6429  enddo
6430 
6431  end subroutine add_ohmic_hyper_source
6432 
6433  end subroutine add_source_hyperdiffusive
6434 
6435  function dump_hyperdiffusivity_coef_x(ixI^L,ixO^L, w, x, nwc) result(wnew)
6438  integer, intent(in) :: ixI^L, ixO^L, nwc
6439  double precision, intent(in) :: w(ixI^S, 1:nw)
6440  double precision, intent(in) :: x(ixI^S,1:ndim)
6441  double precision :: wnew(ixO^S, 1:nwc)
6442 
6443  if(nw .ne. nwc) call mpistop("nw != nwc")
6444  wnew(ixo^s,1:nw) = dump_hyperdiffusivity_coef_dim(ixi^l,ixo^l, w, x, 1)
6445 
6446  end function dump_hyperdiffusivity_coef_x
6447 
6448  function dump_hyperdiffusivity_coef_y(ixI^L,ixO^L, w, x, nwc) result(wnew)
6451  integer, intent(in) :: ixi^l, ixo^l, nwc
6452  double precision, intent(in) :: w(ixi^s, 1:nw)
6453  double precision, intent(in) :: x(ixi^s,1:ndim)
6454  double precision :: wnew(ixo^s, 1:nwc)
6455 
6456  if(nw .ne. nwc) call mpistop("nw != nwc")
6457  wnew(ixo^s,1:nw) = dump_hyperdiffusivity_coef_dim(ixi^l,ixo^l, w, x, 2)
6458 
6459  end function dump_hyperdiffusivity_coef_y
6460 
6461  function dump_hyperdiffusivity_coef_z(ixI^L,ixO^L, w, x, nwc) result(wnew)
6464  integer, intent(in) :: ixi^l, ixo^l, nwc
6465  double precision, intent(in) :: w(ixi^s, 1:nw)
6466  double precision, intent(in) :: x(ixi^s,1:ndim)
6467  double precision :: wnew(ixo^s, 1:nwc)
6468 
6469  if(nw .ne. nwc) call mpistop("nw != nwc")
6470  wnew(ixo^s,1:nw) = dump_hyperdiffusivity_coef_dim(ixi^l,ixo^l, w, x, 3)
6471 
6472  end function dump_hyperdiffusivity_coef_z
6473 
6474  function dump_hyperdiffusivity_coef_dim(ixI^L,ixOP^L, w, x, ii) result(wnew)
6477  integer, intent(in) :: ixi^l, ixop^l, ii
6478  double precision, intent(in) :: w(ixi^s, 1:nw)
6479  double precision, intent(in) :: x(ixi^s,1:ndim)
6480  double precision :: wnew(ixop^s, 1:nw)
6481 
6482  double precision :: nu(ixi^s),tmp(ixi^s),rho(ixi^s),temp(ixi^s)
6483  double precision :: divv(ixi^s)
6484  double precision :: vel(ixi^s,1:ndir)
6485  double precision :: csound(ixi^s),csound_dim(ixi^s)
6486  double precision :: dxarr(ndim)
6487  integer :: ixoo^l, hxb^l, hx^l, jj, ixo^l
6488 
6489  ! this is done because of save_physical_boundary = true
6490  ixomin^d=max(ixopmin^d,iximin^d+3);
6491  ixomax^d=min(ixopmax^d,iximax^d-3);
6492 
6493  wnew(ixop^s,1:nw) = 0d0
6494 
6495  ! charges
6496  call twofl_get_temp_c_pert_from_etot(w, x, ixi^l, ixi^l, temp)
6497  call twofl_get_v_c(w,x,ixi^l,ixi^l,vel)
6498  call get_rhoc_tot(w,x,ixi^l,ixi^l,rho)
6499  call twofl_get_csound2_c_from_conserved(w,x,ixi^l,ixi^l,csound)
6500  csound(ixi^s) = sqrt(csound(ixi^s)) + sqrt(twofl_mag_en_all(w,ixi^l,ixi^l) /rho(ixi^s))
6501  csound(ixi^s) = csound(ixi^s) + sqrt(sum(vel(ixi^s,1:ndir)**2 ,dim=ndim+1))
6502  !for dim
6503  call div_vel_coeff(ixi^l, ixoo^l, vel, ii, divv(ixi^s))
6504  hxmin^d=iximin^d+1;
6505  hxmax^d=iximax^d-1;
6506  hxb^l=hx^l-kr(ii,^d);
6507  csound_dim(hx^s) = (csound(hxb^s)+csound(hx^s))/2d0
6508 
6509  !TODO the following is copied
6510  !rho_c
6511  call hyp_coeff(ixi^l, ixoo^l, w(ixi^s,rho_c_), ii, tmp(ixi^s))
6512  nu(ixo^s) = c_hyp(rho_c_) * csound_dim(ixo^s) * dxlevel(ii) * tmp(ixo^s) + &
6513  c_shk(rho_c_) * (dxlevel(ii)**2) *divv(ixo^s)
6514 
6515  wnew(ixo^s,rho_c_) = nu(ixo^s)
6516 
6517  !TH c
6518  call hyp_coeff(ixi^l, ixoo^l, temp(ixi^s), ii, tmp(ixi^s))
6519  nu(ixo^s) = c_hyp(e_c_) * csound_dim(ixo^s) * dxlevel(ii) * tmp(ixo^s) + &
6520  c_shk(e_c_) * (dxlevel(ii)**2) *divv(ixo^s)
6521  nu(ixo^s) = nu(ixo^s) * rho(ixo^s) * rc/(twofl_gamma-1d0)
6522  wnew(ixo^s,e_c_) = nu(ixo^s)
6523 
6524  !visc c
6525  do jj=1,ndir
6526  call hyp_coeff(ixi^l, ixoo^l, vel(ixi^s,jj), ii, tmp(ixi^s))
6527  nu(ixo^s) = c_hyp(mom_c(jj)) * csound_dim(ixo^s) * dxlevel(ii) * tmp(ixo^s) + &
6528  c_shk(mom_c(jj)) * (dxlevel(ii)**2) *divv(ixo^s)
6529  nu(ixo^s) = nu(ixo^s) * rho(ixo^s)
6530  wnew(ixo^s,mom_c(jj)) = nu(ixo^s)
6531  enddo
6532 
6533  ! Ohmic
6534  do jj=1,ndir
6535  if(ii .ne. jj) then
6536  call hyp_coeff(ixi^l, ixoo^l, w(ixi^s,mag(jj)), ii, tmp(ixi^s))
6537  nu(ixo^s) = c_hyp(mag(jj)) * csound_dim(ixo^s) * dxlevel(ii) * tmp(ixo^s) + &
6538  c_shk(mag(jj)) * (dxlevel(ii)**2) *divv(ixo^s)
6539  wnew(ixo^s,mag(jj)) = nu(ixo^s)
6540  endif
6541  enddo
6542 
6543  !end for dim
6544 
6545  ! neutrals
6546  call get_rhon_tot(w,x,ixi^l,ixo^l,rho)
6547  call twofl_get_temp_n_pert_from_etot(w, x, ixi^l, ixi^l, temp)
6548  call twofl_get_v_n(w,x,ixi^l,ixi^l,vel)
6549  call twofl_get_csound_n(w,x,ixi^l,ixi^l,csound)
6550  csound(ixi^s) = csound(ixi^s) + sqrt(sum(vel(ixi^s,1:ndir)**2 ,dim=ndim+1))
6551  !for dim
6552  call div_vel_coeff(ixi^l, ixoo^l, vel, ii, divv(ixi^s))
6553  hxb^l=ixoo^l-kr(ii,^d);
6554  csound_dim(ixoo^s) = (csound(hxb^s)+csound(ixoo^s))/2d0
6555  !rho_n
6556  call hyp_coeff(ixi^l, ixoo^l, w(ixi^s,rho_n_), ii, tmp(ixi^s))
6557  nu(ixo^s) = c_hyp(rho_n_) * csound_dim(ixo^s) * dxlevel(ii) * tmp(ixo^s) + &
6558  c_shk(rho_n_) * (dxlevel(ii)**2) *divv(ixoo^s)
6559  wnew(ixo^s,rho_n_) = nu(ixo^s)
6560 
6561  !TH n
6562  call hyp_coeff(ixi^l, ixoo^l, temp(ixi^s), ii, tmp(ixi^s))
6563  nu(ixo^s) = c_hyp(e_n_) * csound_dim(ixo^s) * dxlevel(ii) * tmp(ixo^s) + &
6564  c_shk(e_n_) * (dxlevel(ii)**2) *divv(ixo^s)
6565  nu(ixo^s) = nu(ixo^s) * rho(ixo^s) * rn/(twofl_gamma-1d0)
6566  wnew(ixo^s,e_n_) = nu(ixo^s)
6567 
6568  !visc n
6569  do jj=1,ndir
6570  call hyp_coeff(ixi^l, ixoo^l, vel(ixi^s,jj), ii, tmp(ixi^s))
6571  nu(ixo^s) = c_hyp(mom_n(jj)) * csound_dim(ixo^s) * dxlevel(ii) * tmp(ixo^s) + &
6572  c_shk(mom_n(jj)) * (dxlevel(ii)**2) *divv(ixo^s)
6573  nu(ixo^s) = nu(ixo^s) * rho(ixo^s)
6574  wnew(ixo^s,mom_n(jj)) = nu(ixo^s)
6575  enddo
6576  !end for dim
6577 
6578  end function dump_hyperdiffusivity_coef_dim
6579 
6580  function dump_coll_terms(ixI^L,ixO^L, w, x, nwc) result(wnew)
6582  integer, intent(in) :: ixi^l,ixo^l, nwc
6583  double precision, intent(in) :: w(ixi^s, 1:nw)
6584  double precision, intent(in) :: x(ixi^s,1:ndim)
6585  double precision :: wnew(ixo^s, 1:nwc)
6586  double precision :: tmp(ixi^s),tmp2(ixi^s)
6587 
6588  call get_alpha_coll(ixi^l, ixo^l, w, x, tmp(ixi^s))
6589  wnew(ixo^s,1)= tmp(ixo^s)
6590  call get_gamma_ion_rec(ixi^l, ixo^l, w, x, tmp(ixi^s), tmp2(ixi^s))
6591  wnew(ixo^s,2)= tmp(ixo^s)
6592  wnew(ixo^s,3)= tmp2(ixo^s)
6593 
6594  end function dump_coll_terms
6595 
6596  subroutine get_gamma_ion_rec(ixI^L, ixO^L, w, x, gamma_rec, gamma_ion)
6598 
6599  integer, intent(in) :: ixi^l, ixo^l
6600  double precision, intent(in) :: w(ixi^s,1:nw)
6601  double precision, intent(in) :: x(ixi^s,1:ndim)
6602  double precision, intent(out) :: gamma_rec(ixi^s),gamma_ion(ixi^s)
6603  ! calculations are done in S.I. units
6604  double precision, parameter :: a = 2.91e-14, & !m3/s
6605  k = 0.39, &
6606  xx = 0.232, &
6607  eion = 13.6 ! eV
6608  double precision, parameter :: echarge=1.6022d-19 !C
6609  double precision :: rho(ixi^s), tmp(ixi^s)
6610 
6611  call twofl_get_pthermal_c(w,x,ixi^l,ixo^l,tmp)
6612  call get_rhoc_tot(w,x,ixi^l,ixo^l,rho)
6613  tmp(ixo^s) = tmp(ixo^s)/(rc * rho(ixo^s))
6614 
6615  !transform to SI units
6616  tmp(ixo^s) = tmp(ixo^s) * unit_temperature * kb_si/echarge !* BK/ECHARGE means K to eV
6617  !number electrons rho_c = n_e * MH, in normalized units MH=1 and n = rho
6618  rho(ixo^s) = rho(ixo^s) * unit_numberdensity
6619  if(.not. si_unit) then
6620  !1/cm^3 = 1e6/m^3
6621  rho(ixo^s) = rho(ixo^s) * 1d6
6622  endif
6623  gamma_rec(ixo^s) = rho(ixo^s) /sqrt(tmp(ixo^s)) * 2.6e-19
6624  gamma_ion(ixo^s) = ((rho(ixo^s) * a) /(xx + eion/tmp(ixo^s))) * ((eion/tmp(ixo^s))**k) * exp(-eion/tmp(ixo^s))
6625  ! see Voronov table: valid for temp min = 1eV(approx 11605 K), Temp max = 20KeV
6626  !to normalized
6627  gamma_rec(ixo^s) = gamma_rec(ixo^s) * unit_time
6628  gamma_ion(ixo^s) = gamma_ion(ixo^s) * unit_time
6629 
6630  if (associated(usr_mask_gamma_ion_rec)) then
6631  call usr_mask_gamma_ion_rec(ixi^l,ixo^l,w,x,gamma_ion, gamma_rec)
6632  end if
6633  end subroutine get_gamma_ion_rec
6634 
6635  subroutine get_alpha_coll(ixI^L, ixO^L, w, x, alpha)
6637  integer, intent(in) :: ixi^l, ixo^l
6638  double precision, intent(in) :: w(ixi^s,1:nw)
6639  double precision, intent(in) :: x(ixi^s,1:ndim)
6640  double precision, intent(out) :: alpha(ixi^s)
6641  if(twofl_alpha_coll_constant) then
6642  alpha(ixo^s) = twofl_alpha_coll
6643  else
6644  call get_alpha_coll_plasma(ixi^l, ixo^l, w, x, alpha)
6645  endif
6646  if (associated(usr_mask_alpha)) then
6647  call usr_mask_alpha(ixi^l,ixo^l,w,x,alpha)
6648  end if
6649  end subroutine get_alpha_coll
6650 
6651  subroutine get_alpha_coll_plasma(ixI^L, ixO^L, w, x, alpha)
6653  integer, intent(in) :: ixI^L, ixO^L
6654  double precision, intent(in) :: w(ixI^S,1:nw)
6655  double precision, intent(in) :: x(ixI^S,1:ndim)
6656  double precision, intent(out) :: alpha(ixI^S)
6657  double precision :: pe(ixI^S),rho(ixI^S), tmp(ixI^S), tmp2(ixI^S)
6658 
6659  double precision :: sigma_in = 1e-19 ! m^2
6660  ! make calculation in SI physical units
6661 
6662  call twofl_get_pthermal_c(w,x,ixi^l,ixo^l,pe)
6663  call get_rhoc_tot(w,x,ixi^l,ixo^l,rho)
6664  tmp(ixo^s) = pe(ixo^s)/(rc * rho(ixo^s))
6665  call twofl_get_pthermal_n(w,x,ixi^l,ixo^l,pe)
6666  call get_rhon_tot(w,x,ixi^l,ixo^l,rho)
6667  tmp2(ixo^s) = pe(ixo^s)/(rn * rho(ixo^s))
6668  alpha(ixo^s) = (2d0/(mp_si**(3d0/2) * sqrt(dpi))*sqrt(0.5*(tmp(ixo^s)+tmp2(ixo^s))*unit_temperature*kb_si) * sigma_in)*unit_time * unit_density
6669  if(.not. si_unit) then
6670  alpha(ixo^s) = alpha(ixo^s) * 1d3 ! this comes from unit_density: g/cm^3 = 1e-3 kg/m^3
6671  endif
6672 
6673  end subroutine get_alpha_coll_plasma
6674 
6675  subroutine calc_mult_factor1(ixI^L, ixO^L, step_dt, JJ, res)
6676  integer, intent(in) :: ixI^L, ixO^L
6677  double precision, intent(in) :: step_dt
6678  double precision, intent(in) :: JJ(ixI^S)
6679  double precision, intent(out) :: res(ixI^S)
6680 
6681  res(ixo^s) = step_dt/(1d0 + step_dt * jj(ixo^s))
6682 
6683  end subroutine calc_mult_factor1
6684 
6685  subroutine calc_mult_factor2(ixI^L, ixO^L, step_dt, JJ, res)
6686  integer, intent(in) :: ixI^L, ixO^L
6687  double precision, intent(in) :: step_dt
6688  double precision, intent(in) :: JJ(ixI^S)
6689  double precision, intent(out) :: res(ixI^S)
6690 
6691  res(ixo^s) = (1d0 - exp(-step_dt * jj(ixo^s)))/jj(ixo^s)
6692 
6693  end subroutine calc_mult_factor2
6694 
6695  subroutine advance_implicit_grid(ixI^L, ixO^L, w, wout, x, dtfactor,qdt)
6697  integer, intent(in) :: ixI^L, ixO^L
6698  double precision, intent(in) :: qdt
6699  double precision, intent(in) :: dtfactor
6700  double precision, intent(in) :: w(ixI^S,1:nw)
6701  double precision, intent(in) :: x(ixI^S,1:ndim)
6702  double precision, intent(out) :: wout(ixI^S,1:nw)
6703 
6704  integer :: idir
6705  double precision :: tmp(ixI^S),tmp1(ixI^S),tmp2(ixI^S),tmp3(ixI^S),tmp4(ixI^S),tmp5(ixI^S)
6706  double precision :: v_c(ixI^S,ndir), v_n(ixI^S,ndir)
6707  double precision :: rhon(ixI^S), rhoc(ixI^S), alpha(ixI^S)
6708  double precision, allocatable :: gamma_rec(:^D&), gamma_ion(:^D&)
6709 
6710  !TODO latest changes sets already wout to w in implicit update (see where psb=psa)
6711  ! commment out setting mag and density when they are not modified here
6712 
6713  ! copy vars at the indices which are not updated here: mag. field
6714  wout(ixo^s,mag(:)) = w(ixo^s,mag(:))
6715 
6716  call get_rhon_tot(w,x,ixi^l,ixo^l,rhon)
6717  call get_rhoc_tot(w,x,ixi^l,ixo^l,rhoc)
6718  !update density
6719  if(twofl_coll_inc_ionrec) then
6720  allocate(gamma_ion(ixi^s), gamma_rec(ixi^s))
6721  call get_gamma_ion_rec(ixi^l, ixo^l, w, x, gamma_rec, gamma_ion)
6722  tmp2(ixo^s) = gamma_rec(ixo^s) + gamma_ion(ixo^s)
6723  call calc_mult_factor(ixi^l, ixo^l, dtfactor * qdt, tmp2, tmp3)
6724  tmp(ixo^s) = (-gamma_ion(ixo^s) * rhon(ixo^s) + &
6725  gamma_rec(ixo^s) * rhoc(ixo^s))
6726  wout(ixo^s,rho_n_) = w(ixo^s,rho_n_) + tmp(ixo^s) * tmp3(ixo^s)
6727  wout(ixo^s,rho_c_) = w(ixo^s,rho_c_) - tmp(ixo^s) * tmp3(ixo^s)
6728  else
6729  wout(ixo^s,rho_n_) = w(ixo^s,rho_n_)
6730  wout(ixo^s,rho_c_) = w(ixo^s,rho_c_)
6731  endif
6732 
6733  call get_alpha_coll(ixi^l, ixo^l, w, x, alpha)
6734 
6735  !-J11 + J12 for momentum and kinetic energy
6736  tmp2(ixo^s) = alpha(ixo^s) * (rhon(ixo^s) + rhoc(ixo^s))
6737  if(twofl_coll_inc_ionrec) then
6738  tmp2(ixo^s) = tmp2(ixo^s) + gamma_ion(ixo^s) + gamma_rec(ixo^s)
6739  endif
6740  call calc_mult_factor(ixi^l, ixo^l, dtfactor * qdt, tmp2, tmp3)
6741 
6742  ! momentum update
6743  do idir=1,ndir
6744 
6745  tmp(ixo^s) = alpha(ixo^s)* (-rhoc(ixo^s) * w(ixo^s,mom_n(idir)) + rhon(ixo^s) * w(ixo^s,mom_c(idir)))
6746  if(twofl_coll_inc_ionrec) then
6747  tmp(ixo^s) = tmp(ixo^s) - gamma_ion(ixo^s) * w(ixo^s,mom_n(idir)) + gamma_rec(ixo^s) * w(ixo^s,mom_c(idir))
6748  endif
6749 
6750  wout(ixo^s,mom_n(idir)) = w(ixo^s,mom_n(idir)) + tmp(ixo^s) * tmp3(ixo^s)
6751  wout(ixo^s,mom_c(idir)) = w(ixo^s,mom_c(idir)) - tmp(ixo^s) * tmp3(ixo^s)
6752  enddo
6753 
6754  ! energy update
6755 
6756  ! kinetic energy update
6757  if(.not. phys_internal_e) then
6758  ! E_tot includes kinetic energy
6759  tmp1(ixo^s) = twofl_kin_en_n(w,ixi^l,ixo^l)
6760  tmp2(ixo^s) = twofl_kin_en_c(w,ixi^l,ixo^l)
6761  tmp4(ixo^s) = w(ixo^s,e_n_) - tmp1(ixo^s) !E_tot - E_kin
6762  tmp5(ixo^s) = w(ixo^s,e_c_) - tmp2(ixo^s)
6763  if(phys_total_energy) then
6764  tmp5(ixo^s) = tmp5(ixo^s) - twofl_mag_en(w,ixi^l,ixo^l)
6765  endif
6766 
6767  !!implicit update
6768  tmp(ixo^s) = alpha(ixo^s)*(-rhoc(ixo^s) * tmp1(ixo^s) + rhon(ixo^s) * tmp2(ixo^s))
6769  if(twofl_coll_inc_ionrec) then
6770  tmp(ixo^s) = tmp(ixo^s) - gamma_ion(ixo^s) * tmp1(ixo^s) + gamma_rec(ixo^s) * tmp2(ixo^s)
6771  endif
6772 
6773  wout(ixo^s,e_n_) = w(ixo^s,e_n_) + tmp(ixo^s) * tmp3(ixo^s)
6774  wout(ixo^s,e_c_) = w(ixo^s,e_c_) - tmp(ixo^s) * tmp3(ixo^s)
6775 
6776  else
6777  tmp4(ixo^s) = w(ixo^s,e_n_)
6778  tmp5(ixo^s) = w(ixo^s,e_c_)
6779  ! calculate velocities, using the already updated variables
6780  call twofl_get_v_n(wout,x,ixi^l,ixo^l,v_n)
6781  call twofl_get_v_c(wout,x,ixi^l,ixo^l,v_c)
6782  tmp1(ixo^s) = alpha(ixo^s) * rhoc(ixo^s) * rhon(ixo^s)
6783  tmp2(ixo^s) = tmp1(ixo^s)
6784  if(twofl_coll_inc_ionrec) then
6785  tmp1(ixo^s) = tmp1(ixo^s) + rhoc(ixo^s) * gamma_rec(ixo^s)
6786  tmp2(ixo^s) = tmp2(ixo^s) + rhon(ixo^s) * gamma_ion(ixo^s)
6787  endif
6788 
6789  tmp(ixo^s) = 0.5d0 * sum((v_c(ixo^s,1:ndir) - v_n(ixo^s,1:ndir))**2, dim=ndim+1) &
6790  * dtfactor * qdt
6791  wout(ixo^s,e_n_) = w(ixo^s,e_n_) + tmp(ixo^s)*tmp1(ixo^s)
6792  wout(ixo^s,e_c_) = w(ixo^s,e_c_) + tmp(ixo^s)*tmp2(ixo^s)
6793  endif
6794 
6795  !update internal energy
6796  if(twofl_coll_inc_te) then
6797  if(has_equi_pe_n0) then
6798  tmp2(ixo^s)= block%equi_vars(ixo^s,equi_pe_n0_,0)*inv_gamma_1
6799  endif
6800  if(has_equi_pe_c0) then
6801  tmp3(ixo^s)=block%equi_vars(ixo^s,equi_pe_c0_,0)*inv_gamma_1
6802  endif
6803  if (twofl_equi_thermal) then
6804  tmp(ixo^s) = alpha(ixo^s) *(-1d0/rn*(rhoc(ixo^s) * tmp4(ixo^s) + &
6805  tmp2(ixo^s)*w(ixo^s,rho_c_)) + 1d0/rc*(rhon(ixo^s) * tmp5(ixo^s) +&
6806  tmp3(ixo^s)*w(ixo^s,rho_n_)))
6807  endif
6808  if(has_equi_pe_n0) then
6809  tmp4(ixo^s) = tmp2(ixo^s) + tmp4(ixo^s)
6810  endif
6811  if(has_equi_pe_c0) then
6812  tmp5(ixo^s) = tmp3(ixo^s) + tmp5(ixo^s)
6813  endif
6814  if (.not. twofl_equi_thermal) then
6815  tmp(ixo^s) = alpha(ixo^s) *(-rhoc(ixo^s)/rn * tmp4(ixo^s) + rhon(ixo^s)/rc * tmp5(ixo^s))
6816  endif
6817  tmp2(ixo^s) = alpha(ixo^s) * (rhon(ixo^s)/rc + rhoc(ixo^s)/rn)
6818  if(twofl_coll_inc_ionrec) then
6819  tmp2(ixo^s) = tmp2(ixo^s) + gamma_rec(ixo^s)/rc + gamma_ion(ixo^s)/rn
6820  tmp(ixo^s) = tmp(ixo^s) - gamma_ion(ixo^s)/rn * tmp4(ixo^s) + gamma_rec(ixo^s)/rc * tmp5(ixo^s)
6821  endif
6822  call calc_mult_factor(ixi^l, ixo^l, dtfactor * qdt, tmp2, tmp3)
6823  wout(ixo^s,e_n_) = wout(ixo^s,e_n_)+tmp(ixo^s)*tmp3(ixo^s)
6824  wout(ixo^s,e_c_) = wout(ixo^s,e_c_)-tmp(ixo^s)*tmp3(ixo^s)
6825  endif
6826  if(twofl_coll_inc_ionrec) then
6827  deallocate(gamma_ion, gamma_rec)
6828  endif
6829  end subroutine advance_implicit_grid
6830 
6831  !> Implicit solve of psb=psa+dtfactor*dt*F_im(psb)
6832  subroutine twofl_implicit_coll_terms_update(dtfactor,qdt,qtC,psb,psa)
6835 
6836  type(state), target :: psa(max_blocks)
6837  type(state), target :: psb(max_blocks)
6838  double precision, intent(in) :: qdt
6839  double precision, intent(in) :: qtC
6840  double precision, intent(in) :: dtfactor
6841 
6842  integer :: iigrid, igrid
6843  !print*, "IMPL call ", it
6844 
6845  call getbc(global_time,0.d0,psa,1,nw)
6846  !$OMP PARALLEL DO PRIVATE(igrid)
6847  do iigrid=1,igridstail; igrid=igrids(iigrid);
6848  ^d&dxlevel(^d)=rnode(rpdx^d_,igrid);
6849  block=>psa(igrid)
6850  call advance_implicit_grid(ixg^ll, ixg^ll, psa(igrid)%w, psb(igrid)%w, psa(igrid)%x, dtfactor,qdt)
6851  end do
6852  !$OMP END PARALLEL DO
6853 
6854  end subroutine twofl_implicit_coll_terms_update
6855 
6856  !> inplace update of psa==>F_im(psa)
6857  subroutine twofl_evaluate_implicit(qtC,psa)
6859  type(state), target :: psa(max_blocks)
6860  double precision, intent(in) :: qtC
6861 
6862  integer :: iigrid, igrid, level
6863 
6864  !$OMP PARALLEL DO PRIVATE(igrid)
6865  do iigrid=1,igridstail; igrid=igrids(iigrid);
6866  ^d&dxlevel(^d)=rnode(rpdx^d_,igrid);
6867  block=>psa(igrid)
6868  call coll_terms(ixg^ll,ixm^ll,psa(igrid)%w,psa(igrid)%x)
6869  end do
6870  !$OMP END PARALLEL DO
6871 
6872  end subroutine twofl_evaluate_implicit
6873 
6874  subroutine coll_terms(ixI^L,ixO^L,w,x)
6876  integer, intent(in) :: ixI^L, ixO^L
6877  double precision, intent(inout) :: w(ixI^S, 1:nw)
6878  double precision, intent(in) :: x(ixI^S,1:ndim)
6879 
6880  integer :: idir
6881  double precision :: tmp(ixI^S),tmp1(ixI^S),tmp2(ixI^S),tmp3(ixI^S),tmp4(ixI^S),tmp5(ixI^S)
6882  !double precision :: v_c(ixI^S,ndir), v_n(ixI^S,ndir)
6883  double precision, allocatable :: v_c(:^D&,:), v_n(:^D&,:)
6884  double precision, allocatable :: rho_c1(:^D&), rho_n1(:^D&)
6885  double precision :: rhon(ixI^S), rhoc(ixI^S), alpha(ixI^S)
6886  double precision, allocatable :: gamma_rec(:^D&), gamma_ion(:^D&)
6887 
6888  ! copy density before overwrite
6889  if(twofl_equi_thermal) then
6890  allocate(rho_n1(ixi^s), rho_c1(ixi^s))
6891  rho_n1(ixo^s) = w(ixo^s,rho_n_)
6892  rho_c1(ixo^s) = w(ixo^s,rho_c_)
6893  endif
6894 
6895  ! get total density before overwrite density
6896  call get_rhon_tot(w,x,ixi^l,ixo^l,rhon)
6897  call get_rhoc_tot(w,x,ixi^l,ixo^l,rhoc)
6898  if(phys_internal_e) then
6899  ! get velocity before overwrite momentum
6900  allocate(v_n(ixi^s,ndir), v_c(ixi^s,ndir))
6901  call twofl_get_v_n(w,x,ixi^l,ixo^l,v_n)
6902  call twofl_get_v_c(w,x,ixi^l,ixo^l,v_c)
6903  else
6904  ! get ke before overwrite density and momentum
6905  tmp1(ixo^s) = twofl_kin_en_n(w,ixi^l,ixo^l)
6906  tmp2(ixo^s) = twofl_kin_en_c(w,ixi^l,ixo^l)
6907  endif
6908 
6909  !update density
6910  if(twofl_coll_inc_ionrec) then
6911  allocate(gamma_ion(ixi^s), gamma_rec(ixi^s))
6912  call get_gamma_ion_rec(ixi^l, ixo^l, w, x, gamma_rec, gamma_ion)
6913  tmp(ixo^s) = -gamma_ion(ixo^s) * rhon(ixo^s) + &
6914  gamma_rec(ixo^s) * rhoc(ixo^s)
6915  w(ixo^s,rho_n_) = tmp(ixo^s)
6916  w(ixo^s,rho_c_) = -tmp(ixo^s)
6917  else
6918  w(ixo^s,rho_n_) = 0d0
6919  w(ixo^s,rho_c_) = 0d0
6920 
6921  endif
6922 
6923  call get_alpha_coll(ixi^l, ixo^l, w, x, alpha)
6924 
6925  ! momentum update
6926  do idir=1,ndir
6927 
6928  tmp(ixo^s) = alpha(ixo^s)* (-rhoc(ixo^s) * w(ixo^s,mom_n(idir)) + rhon(ixo^s) * w(ixo^s,mom_c(idir)))
6929  if(twofl_coll_inc_ionrec) then
6930  tmp(ixo^s) = tmp(ixo^s) - gamma_ion(ixo^s) * w(ixo^s,mom_n(idir)) + gamma_rec(ixo^s) * w(ixo^s,mom_c(idir))
6931  endif
6932 
6933  w(ixo^s,mom_n(idir)) = tmp(ixo^s)
6934  w(ixo^s,mom_c(idir)) = -tmp(ixo^s)
6935  enddo
6936 
6937  ! energy update
6938 
6939  ! kinetic energy update
6940  if(.not. phys_internal_e) then
6941  ! E_tot includes kinetic energy
6942  tmp4(ixo^s) = w(ixo^s,e_n_) - tmp1(ixo^s) !E_tot - E_kin
6943  tmp5(ixo^s) = w(ixo^s,e_c_) - tmp2(ixo^s)
6944  if(phys_total_energy) then
6945  tmp5(ixo^s) = tmp5(ixo^s) - twofl_mag_en(w,ixi^l,ixo^l)
6946  endif
6947  ! tmp4 = eint_n, tmp5 = eint_c
6948  ! tmp1 = ke_n, tmp2 = ke_c
6949  tmp(ixo^s) = alpha(ixo^s)*(-rhoc(ixo^s) * tmp1(ixo^s) + rhon(ixo^s) * tmp2(ixo^s))
6950  if(twofl_coll_inc_ionrec) then
6951  tmp(ixo^s) = tmp(ixo^s) - gamma_ion(ixo^s) * tmp1(ixo^s) + gamma_rec(ixo^s) * tmp2(ixo^s)
6952  endif
6953 
6954  w(ixo^s,e_n_) = tmp(ixo^s)
6955  w(ixo^s,e_c_) = -tmp(ixo^s)
6956 
6957  else
6958  tmp4(ixo^s) = w(ixo^s,e_n_)
6959  tmp5(ixo^s) = w(ixo^s,e_c_)
6960  tmp1(ixo^s) = alpha(ixo^s) * rhoc(ixo^s) * rhon(ixo^s)
6961  tmp2(ixo^s) = tmp1(ixo^s)
6962  if(twofl_coll_inc_ionrec) then
6963  tmp1(ixo^s) = tmp1(ixo^s) + rhoc(ixo^s) * gamma_rec(ixo^s)
6964  tmp2(ixo^s) = tmp2(ixo^s) + rhon(ixo^s) * gamma_ion(ixo^s)
6965  endif
6966 
6967  tmp(ixo^s) = 0.5d0 * sum((v_c(ixo^s,1:ndir) - v_n(ixo^s,1:ndir))**2, dim=ndim+1)
6968  w(ixo^s,e_n_) = tmp(ixo^s)*tmp1(ixo^s)
6969  w(ixo^s,e_c_) = tmp(ixo^s)*tmp2(ixo^s)
6970  endif
6971 
6972  !update internal energy
6973  if(twofl_coll_inc_te) then
6974 
6975  if(has_equi_pe_n0) then
6976  tmp2(ixo^s)= block%equi_vars(ixo^s,equi_pe_n0_,0)*inv_gamma_1
6977  endif
6978  if(has_equi_pe_c0) then
6979  tmp3(ixo^s)=block%equi_vars(ixo^s,equi_pe_c0_,0)*inv_gamma_1
6980  endif
6981  if (twofl_equi_thermal) then
6982  tmp(ixo^s) = alpha(ixo^s) *(-1d0/rn*(rhoc(ixo^s) * tmp4(ixo^s) + &
6983  tmp2(ixo^s)*rho_c1(ixo^s)) + 1d0/rc*(rhon(ixo^s) * tmp5(ixo^s) +&
6984  tmp3(ixo^s)*rho_n1(ixo^s)))
6985  endif
6986  if(has_equi_pe_n0) then
6987  tmp4(ixo^s) = tmp2(ixo^s) + tmp4(ixo^s)
6988  endif
6989  if(has_equi_pe_c0) then
6990  tmp5(ixo^s) = tmp3(ixo^s) + tmp5(ixo^s)
6991  endif
6992  if (.not. twofl_equi_thermal) then
6993  tmp(ixo^s) = alpha(ixo^s) *(-rhoc(ixo^s)/rn * tmp4(ixo^s) + rhon(ixo^s)/rc * tmp5(ixo^s))
6994  endif
6995 
6996  if(twofl_coll_inc_ionrec) then
6997  tmp(ixo^s) = tmp(ixo^s) - gamma_ion(ixo^s)/rn * tmp4(ixo^s) + gamma_rec(ixo^s)/rc * tmp5(ixo^s)
6998  endif
6999 
7000  w(ixo^s,e_n_) = w(ixo^s,e_n_)+tmp(ixo^s)
7001  w(ixo^s,e_c_) = w(ixo^s,e_c_)-tmp(ixo^s)
7002  endif
7003  if(twofl_coll_inc_ionrec) then
7004  deallocate(gamma_ion, gamma_rec)
7005  endif
7006  if(phys_internal_e) then
7007  deallocate(v_n, v_c)
7008  endif
7009  if(twofl_equi_thermal) then
7010  deallocate(rho_n1, rho_c1)
7011  endif
7012  !set contribution to mag field
7013  w(ixo^s,mag(1:ndir)) = 0d0
7014 
7015  end subroutine coll_terms
7016 
7017  subroutine twofl_explicit_coll_terms_update(qdt,ixI^L,ixO^L,w,wCT,x)
7019 
7020  integer, intent(in) :: ixI^L, ixO^L
7021  double precision, intent(in) :: qdt, x(ixI^S,1:ndim)
7022  double precision, intent(inout) :: w(ixI^S,1:nw)
7023  double precision, intent(in) :: wCT(ixI^S,1:nw)
7024 
7025  integer :: idir
7026  double precision :: tmp(ixI^S),tmp1(ixI^S),tmp2(ixI^S),tmp3(ixI^S),tmp4(ixI^S),tmp5(ixI^S)
7027  double precision :: v_c(ixI^S,ndir), v_n(ixI^S,ndir)
7028  double precision :: rhon(ixI^S), rhoc(ixI^S), alpha(ixI^S)
7029  double precision, allocatable :: gamma_rec(:^D&), gamma_ion(:^D&)
7030 
7031  call get_rhon_tot(wct,x,ixi^l,ixo^l,rhon)
7032  call get_rhoc_tot(wct,x,ixi^l,ixo^l,rhoc)
7033  !update density
7034  if(twofl_coll_inc_ionrec) then
7035  allocate(gamma_ion(ixi^s), gamma_rec(ixi^s))
7036  call get_gamma_ion_rec(ixi^l, ixo^l, wct, x, gamma_rec, gamma_ion)
7037  tmp(ixo^s) = qdt *(-gamma_ion(ixo^s) * rhon(ixo^s) + &
7038  gamma_rec(ixo^s) * rhoc(ixo^s))
7039  w(ixo^s,rho_n_) = w(ixo^s,rho_n_) + tmp(ixo^s)
7040  w(ixo^s,rho_c_) = w(ixo^s,rho_c_) - tmp(ixo^s)
7041  endif
7042 
7043  call get_alpha_coll(ixi^l, ixo^l, wct, x, alpha)
7044 
7045  ! momentum update
7046  do idir=1,ndir
7047 
7048  tmp(ixo^s) = alpha(ixo^s)* (-rhoc(ixo^s) * wct(ixo^s,mom_n(idir)) + rhon(ixo^s) * wct(ixo^s,mom_c(idir)))
7049  if(twofl_coll_inc_ionrec) then
7050  tmp(ixo^s) = tmp(ixo^s) - gamma_ion(ixo^s) * wct(ixo^s,mom_n(idir)) + gamma_rec(ixo^s) * wct(ixo^s,mom_c(idir))
7051  endif
7052  tmp(ixo^s) =tmp(ixo^s) * qdt
7053 
7054  w(ixo^s,mom_n(idir)) = w(ixo^s,mom_n(idir)) + tmp(ixo^s)
7055  w(ixo^s,mom_c(idir)) = w(ixo^s,mom_c(idir)) - tmp(ixo^s)
7056  enddo
7057 
7058  ! energy update
7059 
7060  ! kinetic energy update
7061  if(.not. phys_internal_e) then
7062  ! E_tot includes kinetic energy
7063  tmp1(ixo^s) = twofl_kin_en_n(wct,ixi^l,ixo^l)
7064  tmp2(ixo^s) = twofl_kin_en_c(wct,ixi^l,ixo^l)
7065  tmp4(ixo^s) = wct(ixo^s,e_n_) - tmp1(ixo^s) !E_tot - E_kin
7066  tmp5(ixo^s) = wct(ixo^s,e_c_) - tmp2(ixo^s)
7067  if(phys_total_energy) then
7068  tmp5(ixo^s) = tmp5(ixo^s) - twofl_mag_en(wct,ixi^l,ixo^l)
7069  endif
7070 
7071  tmp(ixo^s) = alpha(ixo^s)*(-rhoc(ixo^s) * tmp1(ixo^s) + rhon(ixo^s) * tmp2(ixo^s))
7072  if(twofl_coll_inc_ionrec) then
7073  tmp(ixo^s) = tmp(ixo^s) - gamma_ion(ixo^s) * tmp1(ixo^s) + gamma_rec(ixo^s) * tmp2(ixo^s)
7074  endif
7075  tmp(ixo^s) =tmp(ixo^s) * qdt
7076 
7077  w(ixo^s,e_n_) = w(ixo^s,e_n_) + tmp(ixo^s)
7078  w(ixo^s,e_c_) = w(ixo^s,e_c_) - tmp(ixo^s)
7079 
7080  else
7081  tmp4(ixo^s) = w(ixo^s,e_n_)
7082  tmp5(ixo^s) = w(ixo^s,e_c_)
7083  call twofl_get_v_n(wct,x,ixi^l,ixo^l,v_n)
7084  call twofl_get_v_c(wct,x,ixi^l,ixo^l,v_c)
7085  tmp1(ixo^s) = alpha(ixo^s) * rhoc(ixo^s) * rhon(ixo^s)
7086  tmp2(ixo^s) = tmp1(ixo^s)
7087  if(twofl_coll_inc_ionrec) then
7088  tmp1(ixo^s) = tmp1(ixo^s) + rhoc(ixo^s) * gamma_rec(ixo^s)
7089  tmp2(ixo^s) = tmp2(ixo^s) + rhon(ixo^s) * gamma_ion(ixo^s)
7090  endif
7091 
7092  tmp(ixo^s) = 0.5d0 * sum((v_c(ixo^s,1:ndir) - v_n(ixo^s,1:ndir))**2, dim=ndim+1) * qdt
7093  w(ixo^s,e_n_) = w(ixo^s,e_n_) + tmp(ixo^s)*tmp1(ixo^s)
7094  w(ixo^s,e_c_) = w(ixo^s,e_c_) + tmp(ixo^s)*tmp2(ixo^s)
7095  endif
7096 
7097  !update internal energy
7098  if(twofl_coll_inc_te) then
7099  if(has_equi_pe_n0) then
7100  tmp2(ixo^s)= block%equi_vars(ixo^s,equi_pe_n0_,0)*inv_gamma_1
7101  endif
7102  if(has_equi_pe_c0) then
7103  tmp3(ixo^s)=block%equi_vars(ixo^s,equi_pe_c0_,0)*inv_gamma_1
7104  endif
7105  if (twofl_equi_thermal) then
7106  tmp(ixo^s) = alpha(ixo^s) *(-1d0/rn*(rhoc(ixo^s) * tmp4(ixo^s) + &
7107  tmp2(ixo^s)*wct(ixo^s,rho_c_)) + 1d0/rc*(rhon(ixo^s) * tmp5(ixo^s) +&
7108  tmp3(ixo^s)*wct(ixo^s,rho_n_)))
7109  endif
7110  if(has_equi_pe_n0) then
7111  tmp4(ixo^s) = tmp2(ixo^s) + tmp4(ixo^s)
7112  endif
7113  if(has_equi_pe_c0) then
7114  tmp5(ixo^s) = tmp3(ixo^s) + tmp5(ixo^s)
7115  endif
7116  if (.not. twofl_equi_thermal) then
7117  tmp(ixo^s) = alpha(ixo^s) *(-rhoc(ixo^s)/rn * tmp4(ixo^s) + rhon(ixo^s)/rc * tmp5(ixo^s))
7118  endif
7119 
7120  if(twofl_coll_inc_ionrec) then
7121  tmp(ixo^s) = tmp(ixo^s) - gamma_ion(ixo^s)/rn * tmp4(ixo^s) + gamma_rec(ixo^s)/rc * tmp5(ixo^s)
7122  endif
7123 
7124  tmp(ixo^s) =tmp(ixo^s) * qdt
7125 
7126  w(ixo^s,e_n_) = w(ixo^s,e_n_)+tmp(ixo^s)
7127  w(ixo^s,e_c_) = w(ixo^s,e_c_)-tmp(ixo^s)
7128  endif
7129  if(twofl_coll_inc_ionrec) then
7130  deallocate(gamma_ion, gamma_rec)
7131  endif
7132  end subroutine twofl_explicit_coll_terms_update
7133 
7134  subroutine rfactor_c(w,x,ixI^L,ixO^L,Rfactor)
7136  integer, intent(in) :: ixI^L, ixO^L
7137  double precision, intent(in) :: w(ixI^S,1:nw)
7138  double precision, intent(in) :: x(ixI^S,1:ndim)
7139  double precision, intent(out):: Rfactor(ixI^S)
7140 
7141  rfactor(ixo^s)=rc
7142 
7143  end subroutine rfactor_c
7144 
7145 end module mod_twofl_phys
subroutine twofl_get_csound2_primitive(w, x, ixIL, ixOL, csound2)
subroutine twofl_get_p_c_total(w, x, ixIL, ixOL, p)
subroutine add_density_hyper_source(index_rho)
subroutine, public mpistop(message)
Exit MPI-AMRVAC with an error message.
Definition: mod_comm_lib.t:208
Module for physical and numeric constants.
Definition: mod_constants.t:2
double precision, parameter bigdouble
A very large real number.
Definition: mod_constants.t:11
subroutine b_from_vector_potentiala(ixIsL, ixIL, ixOL, ws, x, A)
calculate magnetic field from vector potential A at cell edges
subroutine reconstruct(ixIL, ixCL, idir, q, qL, qR)
Reconstruct scalar q within ixO^L to 1/2 dx in direction idir Return both left and right reconstructe...
subroutine add_convert_method(phys_convert_vars, nwc, dataset_names, file_suffix)
Definition: mod_convert.t:59
Module for flux conservation near refinement boundaries.
Module with basic grid data structures.
Definition: mod_forest.t:2
type(tree_node_ptr), dimension(:,:), allocatable, save igrid_to_node
Array to go from an [igrid, ipe] index to a node pointer.
Definition: mod_forest.t:32
integer, dimension(:), allocatable, public mag
Indices of the magnetic field.
subroutine, public get_divb(w, ixIL, ixOL, divb, fourthorder)
Calculate div B within ixO.
Module with geometry-related routines (e.g., divergence, curl)
Definition: mod_geometry.t:2
integer coordinate
Definition: mod_geometry.t:7
integer, parameter spherical
Definition: mod_geometry.t:11
integer, parameter cylindrical
Definition: mod_geometry.t:10
subroutine gradient(q, ixIL, ixOL, idir, gradq)
Calculate gradient of a scalar q within ixL in direction idir.
Definition: mod_geometry.t:321
subroutine curlvector(qvec, ixIL, ixOL, curlvec, idirmin, idirmin0, ndir0, fourthorder)
Calculate curl of a vector qvec within ixL Options to employ standard second order CD evaluations use...
Definition: mod_geometry.t:664
subroutine gradients(q, ixIL, ixOL, idir, gradq)
Calculate gradient of a scalar q within ixL in direction idir first use limiter to go from cell cente...
Definition: mod_geometry.t:458
subroutine divvector(qvec, ixIL, ixOL, divq, fourthorder, sixthorder)
Calculate divergence of a vector qvec within ixL.
Definition: mod_geometry.t:516
subroutine gradientx(q, x, ixIL, ixOL, idir, gradq, fourth_order)
Calculate gradient of a scalar q in direction idir at cell interfaces.
Definition: mod_geometry.t:363
update ghost cells of all blocks including physical boundaries
subroutine getbc(time, qdt, psb, nwstart, nwbc, req_diag)
do update ghost cells of all blocks including physical boundaries
This module contains definitions of global parameters and variables and some generic functions/subrou...
type(state), pointer block
Block pointer for using one block and its previous state.
logical h_correction
If true, do H-correction to fix the carbuncle problem at grid-aligned shocks.
double precision dtdiffpar
For resistive MHD, the time step is also limited by the diffusion time: .
character(len=std_len) typegrad
double precision unit_charge
Physical scaling factor for charge.
double precision small_pressure
integer ixghi
Upper index of grid block arrays.
integer, dimension(3, 3, 3) lvc
Levi-Civita tensor.
double precision unit_time
Physical scaling factor for time.
double precision unit_density
Physical scaling factor for density.
integer, parameter unitpar
file handle for IO
integer, parameter bc_asymm
double precision global_time
The global simulation time.
double precision unit_mass
Physical scaling factor for mass.
logical use_imex_scheme
whether IMEX in use or not
integer, dimension(3, 3) kr
Kronecker delta tensor.
double precision phys_trac_mask
integer it
Number of time steps taken.
integer, dimension(:, :), allocatable typeboundary
Array indicating the type of boundary condition per variable and per physical boundary.
double precision unit_numberdensity
Physical scaling factor for number density.
character(len=std_len) convert_type
Which format to use when converting.
double precision unit_pressure
Physical scaling factor for pressure.
integer, parameter ndim
Number of spatial dimensions for grid variables.
double precision unit_length
Physical scaling factor for length.
logical stagger_grid
True for using stagger grid.
double precision cmax_global
global fastest wave speed needed in fd scheme and glm method
character(len=std_len), dimension(:), allocatable par_files
Which par files are used as input.
integer icomm
The MPI communicator.
double precision bdip
amplitude of background dipolar, quadrupolar, octupolar, user's field
integer b0i
background magnetic field location indicator
integer mype
The rank of the current MPI task.
double precision, dimension(:), allocatable, parameter d
integer ndir
Number of spatial dimensions (components) for vector variables.
integer ixm
the mesh range of a physical block without ghost cells
integer ierrmpi
A global MPI error return code.
logical autoconvert
If true, already convert to output format during the run.
logical slab
Cartesian geometry or not.
integer, parameter bc_periodic
integer, parameter bc_special
boundary condition types
double precision unit_magneticfield
Physical scaling factor for magnetic field.
double precision unit_velocity
Physical scaling factor for velocity.
double precision c_norm
Normalised speed of light.
logical b0field
split magnetic field as background B0 field
double precision, dimension(:,:), allocatable rnode
Corner coordinates.
double precision unit_temperature
Physical scaling factor for temperature.
integer, parameter bc_cont
logical si_unit
Use SI units (.true.) or use cgs units (.false.)
double precision, dimension(:,:), allocatable dx
pure subroutine cross_product(ixIL, ixOL, a, b, axb)
Cross product of two vectors.
integer nghostcells
Number of ghost cells surrounding a grid.
integer, parameter bc_symm
logical phys_trac
Use TRAC for MHD or 1D HD.
logical need_global_cmax
need global maximal wave speed
logical convert
If true and restart_from_file is given, convert snapshots to other file formats.
logical fix_small_values
fix small values with average or replace methods
logical crash
Save a snapshot before crash a run met unphysical values.
double precision, dimension(^nd) dxlevel
store unstretched cell size of current level
logical use_multigrid
Use multigrid (only available in 2D and 3D)
logical slab_uniform
uniform Cartesian geometry or not (stretched Cartesian)
double precision small_density
integer r_
Indices for cylindrical coordinates FOR TESTS, negative value when not used:
integer boundspeed
bound (left/min and right.max) speed of Riemann fan
integer, parameter unitconvert
integer number_equi_vars
number of equilibrium set variables, besides the mag field
logical check_small_values
check and optionally fix unphysical small values (density, gas pressure)
integer, parameter ixglo
Lower index of grid block arrays (always 1)
Subroutines for Roe-type Riemann solver for HD.
subroutine second_same_deriv2(ixIL, ixOL, nu_hyper, var2, var, idimm, res)
subroutine second_cross_deriv(ixIL, ixOL, nu_hyper, var, idimm, idimm2, res)
subroutine div_vel_coeff(ixIL, ixOL, vel, idimm, nu_vel)
subroutine hyp_coeff(ixIL, ixOL, var, idimm, nu_hyp)
subroutine second_cross_deriv2(ixIL, ixOL, nu_hyper, var2, var, idimm, idimm2, res)
subroutine second_same_deriv(ixIL, ixOL, nu_hyper, var, idimm, res)
subroutine hyperdiffusivity_init()
Module to couple the octree-mg library to AMRVAC. This file uses the VACPP preprocessor,...
type(mg_t) mg
Data structure containing the multigrid tree.
This module defines the procedures of a physics module. It contains function pointers for the various...
Definition: mod_physics.t:4
module radiative cooling – add optically thin radiative cooling for HD and MHD
subroutine radiative_cooling_init(fl, read_params)
subroutine cooling_get_dt(w, ixIL, ixOL, dtnew, dxD, x, fl)
subroutine radiative_cooling_init_params(phys_gamma, He_abund)
Radiative cooling initialization.
subroutine radiative_cooling_add_source(qdt, ixIL, ixOL, wCT, wCTprim, w, x, qsourcesplit, active, fl)
Module for handling problematic values in simulations, such as negative pressures.
logical, public trace_small_values
trace small values in the source file using traceback flag of compiler
subroutine, public small_values_average(ixIL, ixOL, w, x, w_flag, windex)
logical, dimension(:), allocatable, public small_values_fix_iw
Whether to apply small value fixes to certain variables.
subroutine, public small_values_error(wprim, x, ixIL, ixOL, w_flag, subname)
character(len=20), public small_values_method
How to handle small values.
Generic supertimestepping method 1) in amrvac.par in sts_list set the following parameters which have...
subroutine, public add_sts_method(sts_getdt, sts_set_sources, startVar, nflux, startwbc, nwbc, evolve_B)
subroutine which added programatically a term to be calculated using STS Params: sts_getdt function c...
subroutine, public set_conversion_methods_to_head(sts_before_first_cycle, sts_after_last_cycle)
Set the hooks called before the first cycle and after the last cycle in the STS update This method sh...
subroutine, public set_error_handling_to_head(sts_error_handling)
Set the hook of error handling in the STS update. This method is called before updating the BC....
subroutine, public sts_init()
Initialize sts module.
Thermal conduction for HD and MHD or RHD and RMHD or twofl (plasma-neutral) module Adaptation of mod_...
subroutine, public sts_set_source_tc_hd(ixIL, ixOL, w, x, wres, fix_conserve_at_step, my_dt, igrid, nflux, fl)
subroutine, public tc_get_hd_params(fl, read_hd_params)
Init TC coefficients: HD case.
subroutine tc_init_params(phys_gamma)
subroutine, public sts_set_source_tc_mhd(ixIL, ixOL, w, x, wres, fix_conserve_at_step, my_dt, igrid, nflux, fl)
anisotropic thermal conduction with slope limited symmetric scheme Sharma 2007 Journal of Computation...
double precision function, public get_tc_dt_hd(w, ixIL, ixOL, dxD, x, fl)
Get the explicit timestep for the TC (hd implementation)
subroutine, public tc_get_mhd_params(fl, read_mhd_params)
Init TC coefficients: MHD case.
double precision function, public get_tc_dt_mhd(w, ixIL, ixOL, dxD, x, fl)
Get the explicut timestep for the TC (mhd implementation)
subroutine get_euv_image(qunit, fl)
subroutine get_sxr_image(qunit, fl)
subroutine get_euv_spectrum(qunit, fl)
subroutine get_whitelight_image(qunit, fl)
Magneto-hydrodynamics module.
Definition: mod_twofl_phys.t:2
double precision function twofl_get_tc_dt_mhd_c(w, ixIL, ixOL, dxD, x)
subroutine twofl_get_temperature_from_etot_c(w, x, ixIL, ixOL, res)
Calculate temperature=p/rho when in e_ the total energy is stored this does not check the values of t...
subroutine add_source_linde(qdt, ixIL, ixOL, wCT, w, x)
logical, public twofl_coll_inc_ionrec
whether include ionization/recombination inelastic collisional terms
subroutine twofl_getv_hall(w, x, ixIL, ixOL, vHall)
subroutine twofl_get_csound2_adiab_c(w, x, ixIL, ixOL, csound2)
subroutine add_source_b0split(qdt, ixIL, ixOL, wCT, w, x)
Source terms after split off time-independent magnetic field.
subroutine twofl_check_w(primitive, ixIL, ixOL, w, flag)
logical, public, protected twofl_dump_full_vars
whether dump full variables (when splitting is used) in a separate dat file
double precision, public, protected rn
logical, public clean_initial_divb
clean initial divB
double precision, public twofl_eta_hyper
The MHD hyper-resistivity.
pure logical function has_collisions()
subroutine hyperdiffusivity_get_dt(w, ixIL, ixOL, dtnew, dxD, x)
subroutine internal_energy_add_source_n(qdt, ixIL, ixOL, wCT, w, x)
double precision, public twofl_eta
The MHD resistivity.
integer, public, protected twofl_trac_type
Which TRAC method is used
subroutine twofl_get_pthermal_c_primitive(w, x, ixIL, ixOL, pth)
logical, public has_equi_pe_c0
double precision function, dimension(ixop^s, 1:nw) dump_hyperdiffusivity_coef_dim(ixIL, ixOPL, w, x, ii)
type(tc_fluid), allocatable, public tc_fl_c
double precision function, dimension(ixo^s, 1:nwc) dump_coll_terms(ixIL, ixOL, w, x, nwc)
logical, public twofl_alpha_coll_constant
double precision, dimension(:), allocatable, public, protected c_shk
subroutine twofl_get_h_speed_one(wprim, x, ixIL, ixOL, idim, Hspeed)
get H speed for H-correction to fix the carbuncle problem at grid-aligned shock front
subroutine twofl_get_csound2_from_pthermal(w, x, ixIL, ixOL, pth_c, pth_n, csound2)
subroutine twofl_get_csound2_n_from_primitive(w, x, ixIL, ixOL, csound2)
logical, public, protected twofl_dump_hyperdiffusivity_coef
subroutine twofl_get_v_c(w, x, ixIL, ixOL, v)
Calculate v_c vector.
subroutine twofl_get_csound_c_idim(w, x, ixIL, ixOL, idim, csound)
subroutine set_equi_vars_grid(igrid)
sets the equilibrium variables
double precision, public twofl_glm_alpha
GLM-MHD parameter: ratio of the diffusive and advective time scales for div b taking values within [0...
subroutine update_faces_contact(ixIL, ixOL, qt, qdt, wp, fC, fE, sCT, s, vcts)
update faces using UCT contact mode by Gardiner and Stone 2005 JCP 205, 509
integer, parameter, public eq_energy_ki
subroutine twofl_get_temperature_from_eint_n_with_equi(w, x, ixIL, ixOL, res)
subroutine twofl_boundary_adjust(igrid, psb)
subroutine twofl_tc_handle_small_e_c(w, x, ixIL, ixOL, step)
subroutine twofl_get_temperature_from_eint_c(w, x, ixIL, ixOL, res)
separate routines so that it is faster Calculate temperature=p/rho when in e_ the internal energy is ...
subroutine, public get_current(w, ixIL, ixOL, idirmin, current)
Calculate idirmin and the idirmin:3 components of the common current array make sure that dxlevel(^D)...
subroutine internal_energy_add_source_c(qdt, ixIL, ixOL, wCT, w, x, ie)
subroutine add_pe_n0_divv(qdt, ixIL, ixOL, wCT, w, x)
logical, public, protected twofl_thermal_conduction_n
subroutine, public twofl_phys_init()
subroutine twofl_modify_wlr(ixIL, ixOL, qt, wLC, wRC, wLp, wRp, s, idir)
subroutine add_source_hyperres(qdt, ixIL, ixOL, wCT, w, x)
Add Hyper-resistive source to w within ixO Uses 9 point stencil (4 neighbours) in each direction.
subroutine gravity_add_source(qdt, ixIL, ixOL, wCT, w, x, energy, qsourcesplit, active)
w[iw]=w[iw]+qdt*S[wCT,qtC,x] where S is the source based on wCT within ixO
subroutine rc_params_read_c(fl)
subroutine rfactor_c(w, x, ixIL, ixOL, Rfactor)
logical, public, protected twofl_thermal_conduction_c
Whether thermal conduction is used.
double precision, public twofl_adiab
The adiabatic constant.
logical, public twofl_equi_thermal_c
subroutine, public twofl_get_csound2_c_from_conserved(w, x, ixIL, ixOL, csound2)
double precision function, dimension(ixo^s, 1:nwc) dump_hyperdiffusivity_coef_z(ixIL, ixOL, w, x, nwc)
subroutine add_source_powel(qdt, ixIL, ixOL, wCT, w, x)
Add divB related sources to w within ixO corresponding to Powel.
procedure(implicit_mult_factor_subroutine), pointer calc_mult_factor
subroutine twofl_get_tcutoff_n(ixIL, ixOL, w, x, tco_local, Tmax_local)
get adaptive cutoff temperature for TRAC (Johnston 2019 ApJL, 873, L22)
character(len=std_len), public, protected type_ct
Method type of constrained transport.
subroutine, public get_rhoc_tot(w, x, ixIL, ixOL, rhoc)
subroutine twofl_get_csound_n(w, x, ixIL, ixOL, csound)
integer, public tweight_c_
subroutine twofl_get_temperature_from_eki_c_with_equi(w, x, ixIL, ixOL, res)
subroutine, public twofl_get_pthermal_c(w, x, ixIL, ixOL, pth)
subroutine get_lorentz(ixIL, ixOL, w, JxB)
Compute the Lorentz force (JxB)
logical, public, protected twofl_radiative_cooling_n
subroutine twofl_get_csound2_adiab_n(w, x, ixIL, ixOL, csound2)
subroutine twofl_get_tcutoff_c(ixIL, ixOL, w, x, Tco_local, Tmax_local)
get adaptive cutoff temperature for TRAC (Johnston 2019 ApJL, 873, L22)
integer, parameter, public eq_energy_none
subroutine twofl_get_csound_prim_c(w, x, ixIL, ixOL, idim, csound)
Calculate fast magnetosonic wave speed.
subroutine, public twofl_get_v_n_idim(w, x, ixIL, ixOL, idim, v)
Calculate v component.
subroutine twofl_ei_to_e_c(ixIL, ixOL, w, x)
Transform internal energy to total energy.
subroutine twofl_get_rho_n_equi(w, x, ixIL, ixOL, res)
integer, public e_n_
type(te_fluid), allocatable, public te_fl_c
procedure(mask_subroutine2), pointer, public usr_mask_gamma_ion_rec
double precision, public, protected rc
subroutine twofl_get_temperature_from_etot_n(w, x, ixIL, ixOL, res)
Calculate temperature=p/rho when in e_ the total energy is stored this does not check the values of t...
logical, public, protected twofl_dump_coll_terms
whether dump collisional terms in a separte dat file
logical, public twofl_equi_thermal_n
subroutine twofl_get_dt(w, ixIL, ixOL, dtnew, dxD, x)
If resistivity is not zero, check diffusion time limit for dt.
subroutine grav_params_read(files)
copied from mod_gravity
subroutine twofl_get_csound2_adiab(w, x, ixIL, ixOL, csound2)
subroutine twofl_update_faces(ixIL, ixOL, qt, qdt, wprim, fC, fE, sCT, s, vcts)
subroutine twofl_get_pthermal_n_primitive(w, x, ixIL, ixOL, pth)
logical, public, protected twofl_radiative_cooling_c
Whether radiative cooling is added.
logical, public, protected b0field_forcefree
B0 field is force-free.
subroutine twofl_sts_set_source_tc_n_hd(ixIL, ixOL, w, x, wres, fix_conserve_at_step, my_dt, igrid, nflux)
subroutine update_faces_hll(ixIL, ixOL, qt, qdt, fE, sCT, s, vcts)
update faces
integer, public e_c_
Index of the energy density (-1 if not present)
subroutine get_resistive_electric_field(ixIL, ixOL, sCT, s, jce)
calculate eta J at cell edges
integer, public equi_rho_n0_
subroutine set_equi_vars_grid_faces(igrid, x, ixIL, ixOL)
sets the equilibrium variables
subroutine twofl_implicit_coll_terms_update(dtfactor, qdt, qtC, psb, psa)
Implicit solve of psb=psa+dtfactor*dt*F_im(psb)
subroutine, public twofl_face_to_center(ixOL, s)
calculate cell-center values from face-center values
integer, parameter, public eq_energy_int
subroutine, public get_normalized_divb(w, ixIL, ixOL, divb)
get dimensionless div B = |divB| * volume / area / |B|
subroutine twofl_evaluate_implicit(qtC, psa)
inplace update of psa==>F_im(psa)
subroutine add_source_res2(qdt, ixIL, ixOL, wCT, w, x)
Add resistive source to w within ixO Uses 5 point stencil (2 neighbours) in each direction,...
double precision function, dimension(ixo^s, 1:nwc) dump_hyperdiffusivity_coef_y(ixIL, ixOL, w, x, nwc)
integer, dimension(:), allocatable, public mom_c
Indices of the momentum density.
subroutine, public get_rhon_tot(w, x, ixIL, ixOL, rhon)
logical, public twofl_coll_inc_te
whether include thermal exchange collisional terms
double precision function twofl_get_tc_dt_hd_n(w, ixIL, ixOL, dxD, x)
logical, public has_equi_rho_c0
equi vars flags
logical, public, protected twofl_viscosity
Whether viscosity is added.
subroutine calc_mult_factor1(ixIL, ixOL, step_dt, JJ, res)
double precision, public dtcollpar
subroutine twofl_explicit_coll_terms_update(qdt, ixIL, ixOL, w, wCT, x)
logical, public divbwave
Add divB wave in Roe solver.
subroutine add_source_hyperdiffusive(qdt, ixIL, ixOL, w, wCT, x)
subroutine, public twofl_to_conserved(ixIL, ixOL, w, x)
Transform primitive variables into conservative ones.
subroutine gravity_get_dt(w, ixIL, ixOL, dtnew, dxD, x)
subroutine twofl_get_csound2(w, x, ixIL, ixOL, csound2)
subroutine twofl_get_temperature_from_etot_c_with_equi(w, x, ixIL, ixOL, res)
subroutine twofl_e_to_ei_c(ixIL, ixOL, w, x)
Transform total energy to internal energy.
subroutine twofl_handle_small_ei_c(w, x, ixIL, ixOL, ie, subname)
handle small or negative internal energy
logical, public, protected twofl_4th_order
MHD fourth order.
subroutine add_source_lorentz_work(qdt, ixIL, ixOL, w, wCT, x)
subroutine add_source_glm(qdt, ixIL, ixOL, wCT, w, x)
integer, public tcoff_n_
subroutine twofl_write_info(fh)
Write this module's parameters to a snapsoht.
subroutine twofl_add_source_geom(qdt, dtfactor, ixIL, ixOL, wCT, wprim, w, x)
subroutine, public twofl_to_primitive(ixIL, ixOL, w, x)
Transform conservative variables into primitive ones.
subroutine twofl_get_h_speed_species(wprim, x, ixIL, ixOL, idim, Hspeed)
get H speed for H-correction to fix the carbuncle problem at grid-aligned shock front
subroutine twofl_get_v_n(w, x, ixIL, ixOL, v)
Calculate v_n vector.
double precision, dimension(:), allocatable, public, protected c_hyp
subroutine twofl_get_temperature_c_equi(w, x, ixIL, ixOL, res)
subroutine twofl_get_ct_velocity(vcts, wLp, wRp, ixIL, ixOL, idim, cmax, cmin)
prepare velocities for ct methods
integer, public equi_rho_c0_
equi vars indices in the stateequi_vars array
logical, public, protected twofl_glm
Whether GLM-MHD is used.
double precision, public twofl_alpha_coll
collisional alpha
logical, public, protected twofl_trac
Whether TRAC method is used.
subroutine coll_terms(ixIL, ixOL, w, x)
subroutine twofl_get_cbounds_species(wLC, wRC, wLp, wRp, x, ixIL, ixOL, idim, Hspeed, cmax, cmin)
Estimating bounds for the minimum and maximum signal velocities.
subroutine rc_params_read_n(fl)
double precision, public twofl_etah
The MHD Hall coefficient.
subroutine twofl_get_temp_n_pert_from_etot(w, x, ixIL, ixOL, res)
subroutine, public b_from_vector_potential(ixIsL, ixIL, ixOL, ws, x)
calculate magnetic field from vector potential
double precision function, dimension(ixo^s, 1:nwc) convert_vars_splitting(ixIL, ixOL, w, x, nwc)
subroutine twofl_init_hyper(files)
subroutine add_source_res1(qdt, ixIL, ixOL, wCT, w, x)
Add resistive source to w within ixO Uses 3 point stencil (1 neighbour) in each direction,...
subroutine twofl_get_csound(w, x, ixIL, ixOL, idim, csound)
subroutine get_alpha_coll_plasma(ixIL, ixOL, w, x, alpha)
logical, dimension(2 *^nd), public, protected boundary_divbfix
To control divB=0 fix for boundary.
double precision function, dimension(ixo^s) twofl_mag_en(w, ixIL, ixOL)
Compute evolving magnetic energy.
integer, public equi_pe_c0_
subroutine twofl_get_temperature_from_eint_c_with_equi(w, x, ixIL, ixOL, res)
integer, parameter, public eq_energy_tot
subroutine twofl_te_images
integer, dimension(:), allocatable, public mom_n
logical, public, protected twofl_gravity
Whether gravity is added: common flag for charges and neutrals.
double precision function twofl_get_tc_dt_hd_c(w, ixIL, ixOL, dxD, x)
integer, public tcoff_c_
Index of the cutoff temperature for the TRAC method.
subroutine twofl_check_params
subroutine, public twofl_clean_divb_multigrid(qdt, qt, active)
subroutine twofl_get_csound_prim(w, x, ixIL, ixOL, idim, csound)
Calculate fast magnetosonic wave speed when cbounds_species=false.
subroutine twofl_sts_set_source_tc_c_mhd(ixIL, ixOL, w, x, wres, fix_conserve_at_step, my_dt, igrid, nflux)
subroutine twofl_physical_units()
double precision, public, protected he_abundance
subroutine associate_dump_hyper()
double precision, public, protected twofl_trac_mask
Height of the mask used in the TRAC method.
logical, public has_equi_pe_n0
subroutine twofl_get_a2max(w, x, ixIL, ixOL, a2max)
procedure(mask_subroutine), pointer, public usr_mask_alpha
subroutine, public twofl_get_pthermal_n(w, x, ixIL, ixOL, pth)
double precision function, dimension(ixo^s) twofl_mag_en_all(w, ixIL, ixOL)
Compute 2 times total magnetic energy.
subroutine twofl_handle_small_values(primitive, w, x, ixIL, ixOL, subname)
double precision function, dimension(ixo^s) twofl_kin_en_c(w, ixIL, ixOL)
compute kinetic energy of charges w are conserved variables
subroutine twofl_get_temperature_n_equi(w, x, ixIL, ixOL, res)
subroutine twofl_get_temperature_from_eint_n(w, x, ixIL, ixOL, res)
separate routines so that it is faster Calculate temperature=p/rho when in e_ the internal energy is ...
integer, public rho_c_
Index of the density (in the w array)
logical, public, protected twofl_divb_4thorder
Whether divB is computed with a fourth order approximation.
type(rc_fluid), allocatable, public rc_fl_c
logical, public twofl_equi_thermal
subroutine twofl_get_csound2_n_from_conserved(w, x, ixIL, ixOL, csound2)
subroutine tc_c_params_read_hd(fl)
double precision function, dimension(ixo^s) twofl_kin_en_n(w, ixIL, ixOL)
compute kinetic energy of neutrals
subroutine, public get_gamma_ion_rec(ixIL, ixOL, w, x, gamma_rec, gamma_ion)
subroutine twofl_get_temp_c_pert_from_etot(w, x, ixIL, ixOL, res)
subroutine twofl_get_cmax(w, x, ixIL, ixOL, idim, cmax)
Calculate cmax_idim=csound+abs(v_idim) within ixO^L.
subroutine, public get_alpha_coll(ixIL, ixOL, w, x, alpha)
subroutine twofl_ei_to_e_n(ixIL, ixOL, w, x)
double precision function, dimension(ixo^s) twofl_mag_i_all(w, ixIL, ixOL, idir)
Compute full magnetic field by direction.
subroutine twofl_handle_small_ei_n(w, x, ixIL, ixOL, ie, subname)
handle small or negative internal energy
subroutine update_faces_average(ixIL, ixOL, qt, qdt, fC, fE, sCT, s)
get electric field though averaging neighors to update faces in CT
logical, public has_equi_rho_n0
subroutine twofl_add_source(qdt, dtfactor, ixIL, ixOL, wCT, wCTprim, w, x, qsourcesplit, active)
w[iws]=w[iws]+qdt*S[iws,wCT] where S is the source based on wCT within ixO
subroutine tc_n_params_read_hd(fl)
subroutine twofl_e_to_ei_n(ixIL, ixOL, w, x)
Transform total energy to internal energy.
integer, public rho_n_
subroutine fixdivb_boundary(ixGL, ixOL, w, x, iB)
subroutine twofl_get_csound_prim_n(w, x, ixIL, ixOL, idim, csound)
Calculate fast magnetosonic wave speed.
subroutine twofl_get_flux(wC, w, x, ixIL, ixOL, idim, f)
Calculate fluxes within ixO^L.
subroutine tc_c_params_read_mhd(fl)
subroutine twofl_get_cbounds_one(wLC, wRC, wLp, wRp, x, ixIL, ixOL, idim, Hspeed, cmax, cmin)
Estimating bounds for the minimum and maximum signal velocities.
subroutine add_pe_c0_divv(qdt, ixIL, ixOL, wCT, w, x)
logical, public, protected twofl_hyperdiffusivity
Whether hyperdiffusivity is used.
integer, public, protected twofl_eq_energy
subroutine, public twofl_get_v_c_idim(w, x, ixIL, ixOL, idim, v)
Calculate v_c component.
subroutine twofl_get_pe_c_equi(w, x, ixIL, ixOL, res)
subroutine add_geom_pdivv(qdt, ixIL, ixOL, v, p, w, x, ind)
subroutine twofl_get_pe_n_equi(w, x, ixIL, ixOL, res)
subroutine add_source_janhunen(qdt, ixIL, ixOL, wCT, w, x)
integer, dimension(2 *^nd), public, protected boundary_divbfix_skip
To skip * layer of ghost cells during divB=0 fix for boundary.
subroutine twofl_sts_set_source_tc_c_hd(ixIL, ixOL, w, x, wres, fix_conserve_at_step, my_dt, igrid, nflux)
character(len=std_len), public, protected typedivbfix
Method type to clean divergence of B.
double precision, public twofl_gamma
The adiabatic index.
integer, public equi_pe_n0_
logical, public, protected twofl_hall
Whether Hall-MHD is used.
integer, public tweight_n_
subroutine twofl_tc_handle_small_e_n(w, x, ixIL, ixOL, step)
subroutine twofl_get_temperature_from_etot_n_with_equi(w, x, ixIL, ixOL, res)
subroutine twofl_get_temperature_from_eki_c(w, x, ixIL, ixOL, res)
integer, public, protected psi_
Indices of the GLM psi.
subroutine twofl_get_rho_c_equi(w, x, ixIL, ixOL, res)
logical, public, protected source_split_divb
Whether divB cleaning sources are added splitting from fluid solver.
Module with all the methods that users can customize in AMRVAC.
procedure(special_resistivity), pointer usr_special_resistivity
procedure(phys_gravity), pointer usr_gravity
procedure(set_equi_vars), pointer usr_set_equi_vars
procedure(set_electric_field), pointer usr_set_electric_field
procedure(set_wlr), pointer usr_set_wlr
The module add viscous source terms and check time step.
Definition: mod_viscosity.t:10
subroutine viscosity_add_source(qdt, ixIL, ixOL, wCT, w, x, energy, qsourcesplit, active)
Definition: mod_viscosity.t:90
subroutine viscosity_init(phys_wider_stencil, phys_req_diagonal)
Initialize the module.
Definition: mod_viscosity.t:59
The data structure that contains information about a tree node/grid block.
Definition: mod_forest.t:11