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