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 integer, public, protected :: twofl_divb_nth = 1
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 integer, intent(in) :: ixi^l, ixo^l,ind
3416 double precision, intent(in) :: qdt
3417 double precision, intent(in) :: p(ixi^s), v(ixi^s,1:ndir), x(ixi^s,1:ndim)
3418 double precision, intent(inout) :: w(ixi^s,1:nw)
3419 double precision :: divv(ixi^s)
3420
3421 if(slab_uniform) then
3422 if(nghostcells .gt. 2) then
3423 call divvector(v,ixi^l,ixo^l,divv,3)
3424 else
3425 call divvector(v,ixi^l,ixo^l,divv,2)
3426 end if
3427 else
3428 call divvector(v,ixi^l,ixo^l,divv)
3429 end if
3430 w(ixo^s,ind)=w(ixo^s,ind)+qdt*p(ixo^s)*divv(ixo^s)
3431 end subroutine add_geom_pdivv
3432
3433 !> Compute the Lorentz force (JxB)
3434 subroutine get_lorentz(ixI^L,ixO^L,w,JxB)
3436 integer, intent(in) :: ixi^l, ixo^l
3437 double precision, intent(in) :: w(ixi^s,1:nw)
3438 double precision, intent(inout) :: jxb(ixi^s,3)
3439 double precision :: a(ixi^s,3), b(ixi^s,3), tmp(ixi^s,3)
3440 integer :: idir, idirmin
3441 ! For ndir=2 only 3rd component of J can exist, ndir=1 is impossible for MHD
3442 double precision :: current(ixi^s,7-2*ndir:3)
3443
3444 b=0.0d0
3445 do idir = 1, ndir
3446 b(ixo^s, idir) = twofl_mag_i_all(w, ixi^l, ixo^l,idir)
3447 end do
3448
3449 ! store J current in a
3450 call get_current(w,ixi^l,ixo^l,idirmin,current)
3451
3452 a=0.0d0
3453 do idir=7-2*ndir,3
3454 a(ixo^s,idir)=current(ixo^s,idir)
3455 end do
3456
3457 call cross_product(ixi^l,ixo^l,a,b,jxb)
3458 end subroutine get_lorentz
3459
3460 subroutine add_source_lorentz_work(qdt,ixI^L,ixO^L,w,wCT,x)
3462 integer, intent(in) :: ixi^l, ixo^l
3463 double precision, intent(in) :: qdt
3464 double precision, intent(in) :: wct(ixi^s,1:nw), x(ixi^s,1:ndim)
3465 double precision, intent(inout) :: w(ixi^s,1:nw)
3466 double precision :: a(ixi^s,3), b(ixi^s,1:ndir)
3467
3468 call get_lorentz(ixi^l, ixo^l,wct,a)
3469 call twofl_get_v_c(wct,x,ixi^l,ixo^l,b)
3470 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)
3471
3472 end subroutine add_source_lorentz_work
3473
3474 !> Calculate v_n vector
3475 subroutine twofl_get_v_n(w,x,ixI^L,ixO^L,v)
3477
3478 integer, intent(in) :: ixi^l, ixo^l
3479 double precision, intent(in) :: w(ixi^s,nw), x(ixi^s,1:ndim)
3480 double precision, intent(out) :: v(ixi^s,ndir)
3481 double precision :: rhon(ixi^s)
3482 integer :: idir
3483
3484 call get_rhon_tot(w,x,ixi^l,ixo^l,rhon)
3485
3486 do idir=1,ndir
3487 v(ixo^s,idir) = w(ixo^s, mom_n(idir)) / rhon(ixo^s)
3488 end do
3489
3490 end subroutine twofl_get_v_n
3491
3492 subroutine get_rhon_tot(w,x,ixI^L,ixO^L,rhon)
3494 integer, intent(in) :: ixi^l, ixo^l
3495 double precision, intent(in) :: w(ixi^s,1:nw), x(ixi^s,1:ndim)
3496 double precision, intent(out) :: rhon(ixi^s)
3497 if(has_equi_rho_n0) then
3498 rhon(ixo^s) = w(ixo^s,rho_n_) + block%equi_vars(ixo^s,equi_rho_n0_,b0i)
3499 else
3500 rhon(ixo^s) = w(ixo^s,rho_n_)
3501 endif
3502
3503 end subroutine get_rhon_tot
3504
3505 subroutine twofl_get_pthermal_n(w,x,ixI^L,ixO^L,pth)
3508 integer, intent(in) :: ixi^l, ixo^l
3509 double precision, intent(in) :: w(ixi^s,1:nw)
3510 double precision, intent(in) :: x(ixi^s,1:ndim)
3511 double precision, intent(out) :: pth(ixi^s)
3512
3513 integer :: ix^d, iw
3514
3515 if(phys_energy) then
3516 if(phys_internal_e) then
3517 pth(ixo^s)=gamma_1*w(ixo^s,e_n_)
3518 else
3519 pth(ixo^s)=gamma_1*(w(ixo^s,e_n_)&
3520 - twofl_kin_en_n(w,ixi^l,ixo^l))
3521 end if
3522 if(has_equi_pe_n0) then
3523 pth(ixo^s) = pth(ixo^s) + block%equi_vars(ixo^s,equi_pe_n0_,b0i)
3524 endif
3525 else
3526 call get_rhon_tot(w,x,ixi^l,ixo^l,pth)
3527 pth(ixo^s)=twofl_adiab*pth(ixo^s)**twofl_gamma
3528 end if
3529
3530 if (fix_small_values) then
3531 {do ix^db= ixo^lim^db\}
3532 if(pth(ix^d)<small_pressure) then
3533 pth(ix^d)=small_pressure
3534 end if
3535 {enddo^d&\}
3536 else if (check_small_values) then
3537 {do ix^db= ixo^lim^db\}
3538 if(pth(ix^d)<small_pressure) then
3539 write(*,*) "Error: small value of gas pressure",pth(ix^d),&
3540 " encountered when call twofl_get_pthermal_n"
3541 write(*,*) "Iteration: ", it, " Time: ", global_time
3542 write(*,*) "Location: ", x(ix^d,:)
3543 write(*,*) "Cell number: ", ix^d
3544 do iw=1,nw
3545 write(*,*) trim(cons_wnames(iw)),": ",w(ix^d,iw)
3546 end do
3547 ! use erroneous arithmetic operation to crash the run
3548 if(trace_small_values) write(*,*) sqrt(pth(ix^d)-bigdouble)
3549 write(*,*) "Saving status at the previous time step"
3550 crash=.true.
3551 end if
3552 {enddo^d&\}
3553 end if
3554
3555 end subroutine twofl_get_pthermal_n
3556
3557 subroutine twofl_get_pthermal_n_primitive(w,x,ixI^L,ixO^L,pth)
3559 integer, intent(in) :: ixi^l, ixo^l
3560 double precision, intent(in) :: w(ixi^s,1:nw)
3561 double precision, intent(in) :: x(ixi^s,1:ndim)
3562 double precision, intent(out) :: pth(ixi^s)
3563
3564 if(phys_energy) then
3565 if(has_equi_pe_n0) then
3566 pth(ixo^s) = w(ixo^s,e_n_) + block%equi_vars(ixo^s,equi_pe_n0_,b0i)
3567 else
3568 pth(ixo^s) = w(ixo^s,e_n_)
3569 endif
3570 else
3571 call get_rhon_tot(w,x,ixi^l,ixo^l,pth)
3572 pth(ixo^s)=twofl_adiab*pth(ixo^s)**twofl_gamma
3573 end if
3574 end subroutine twofl_get_pthermal_n_primitive
3575
3576 !> Calculate v component
3577 subroutine twofl_get_v_n_idim(w,x,ixI^L,ixO^L,idim,v)
3579
3580 integer, intent(in) :: ixi^l, ixo^l, idim
3581 double precision, intent(in) :: w(ixi^s,nw), x(ixi^s,1:ndim)
3582 double precision, intent(out) :: v(ixi^s)
3583 double precision :: rhon(ixi^s)
3584
3585 call get_rhon_tot(w,x,ixi^l,ixo^l,rhon)
3586 v(ixo^s) = w(ixo^s, mom_n(idim)) / rhon(ixo^s)
3587
3588 end subroutine twofl_get_v_n_idim
3589
3590 subroutine internal_energy_add_source_n(qdt,ixI^L,ixO^L,wCT,w,x)
3592 use mod_geometry
3593
3594 integer, intent(in) :: ixi^l, ixo^l
3595 double precision, intent(in) :: qdt
3596 double precision, intent(in) :: wct(ixi^s,1:nw), x(ixi^s,1:ndim)
3597 double precision, intent(inout) :: w(ixi^s,1:nw)
3598 double precision :: pth(ixi^s),v(ixi^s,1:ndir),divv(ixi^s)
3599
3600 call twofl_get_pthermal_n(wct,x,ixi^l,ixo^l,pth)
3601 call twofl_get_v_n(wct,x,ixi^l,ixi^l,v)
3602 call add_geom_pdivv(qdt,ixi^l,ixo^l,v,-pth,w,x,e_n_)
3603
3604 if(fix_small_values .and. .not. has_equi_pe_n0) then
3605 call twofl_handle_small_ei_n(w,x,ixi^l,ixo^l,e_n_,'internal_energy_add_source')
3606 end if
3607 end subroutine internal_energy_add_source_n
3608
3609 !> Calculate v_c vector
3610 subroutine twofl_get_v_c(w,x,ixI^L,ixO^L,v)
3612
3613 integer, intent(in) :: ixi^l, ixo^l
3614 double precision, intent(in) :: w(ixi^s,nw), x(ixi^s,1:ndim)
3615 double precision, intent(out) :: v(ixi^s,ndir)
3616 double precision :: rhoc(ixi^s)
3617 integer :: idir
3618
3619 call get_rhoc_tot(w,x,ixi^l,ixo^l,rhoc)
3620 do idir=1,ndir
3621 v(ixo^s,idir) = w(ixo^s, mom_c(idir)) / rhoc(ixo^s)
3622 end do
3623
3624 end subroutine twofl_get_v_c
3625
3626 subroutine get_rhoc_tot(w,x,ixI^L,ixO^L,rhoc)
3628 integer, intent(in) :: ixi^l, ixo^l
3629 double precision, intent(in) :: w(ixi^s,1:nw), x(ixi^s,1:ndim)
3630 double precision, intent(out) :: rhoc(ixi^s)
3631 if(has_equi_rho_c0) then
3632 rhoc(ixo^s) = w(ixo^s,rho_c_) + block%equi_vars(ixo^s,equi_rho_c0_,b0i)
3633 else
3634 rhoc(ixo^s) = w(ixo^s,rho_c_)
3635 endif
3636
3637 end subroutine get_rhoc_tot
3638
3639 subroutine twofl_get_pthermal_c(w,x,ixI^L,ixO^L,pth)
3642 integer, intent(in) :: ixi^l, ixo^l
3643 double precision, intent(in) :: w(ixi^s,1:nw)
3644 double precision, intent(in) :: x(ixi^s,1:ndim)
3645 double precision, intent(out) :: pth(ixi^s)
3646 integer :: ix^d, iw
3647
3648 if(phys_energy) then
3649 if(phys_internal_e) then
3650 pth(ixo^s)=gamma_1*w(ixo^s,e_c_)
3651 elseif(phys_total_energy) then
3652 pth(ixo^s)=gamma_1*(w(ixo^s,e_c_)&
3653 - twofl_kin_en_c(w,ixi^l,ixo^l)&
3654 - twofl_mag_en(w,ixi^l,ixo^l))
3655 else
3656 pth(ixo^s)=gamma_1*(w(ixo^s,e_c_)&
3657 - twofl_kin_en_c(w,ixi^l,ixo^l))
3658 end if
3659 if(has_equi_pe_c0) then
3660 pth(ixo^s) = pth(ixo^s) + block%equi_vars(ixo^s,equi_pe_c0_,b0i)
3661 endif
3662 else
3663 call get_rhoc_tot(w,x,ixi^l,ixo^l,pth)
3664 pth(ixo^s)=twofl_adiab*pth(ixo^s)**twofl_gamma
3665 end if
3666
3667 if (fix_small_values) then
3668 {do ix^db= ixo^lim^db\}
3669 if(pth(ix^d)<small_pressure) then
3670 pth(ix^d)=small_pressure
3671 end if
3672 {enddo^d&\}
3673 else if (check_small_values) then
3674 {do ix^db= ixo^lim^db\}
3675 if(pth(ix^d)<small_pressure) then
3676 write(*,*) "Error: small value of gas pressure",pth(ix^d),&
3677 " encountered when call twofl_get_pe_c1"
3678 write(*,*) "Iteration: ", it, " Time: ", global_time
3679 write(*,*) "Location: ", x(ix^d,:)
3680 write(*,*) "Cell number: ", ix^d
3681 do iw=1,nw
3682 write(*,*) trim(cons_wnames(iw)),": ",w(ix^d,iw)
3683 end do
3684 ! use erroneous arithmetic operation to crash the run
3685 if(trace_small_values) write(*,*) sqrt(pth(ix^d)-bigdouble)
3686 write(*,*) "Saving status at the previous time step"
3687 crash=.true.
3688 end if
3689 {enddo^d&\}
3690 end if
3691
3692 end subroutine twofl_get_pthermal_c
3693
3694 subroutine twofl_get_pthermal_c_primitive(w,x,ixI^L,ixO^L,pth)
3696 integer, intent(in) :: ixi^l, ixo^l
3697 double precision, intent(in) :: w(ixi^s,1:nw)
3698 double precision, intent(in) :: x(ixi^s,1:ndim)
3699 double precision, intent(out) :: pth(ixi^s)
3700
3701 if(phys_energy) then
3702 if(has_equi_pe_c0) then
3703 pth(ixo^s) = w(ixo^s,e_c_) + block%equi_vars(ixo^s,equi_pe_c0_,b0i)
3704 else
3705 pth(ixo^s) = w(ixo^s,e_c_)
3706 endif
3707 else
3708 call get_rhoc_tot(w,x,ixi^l,ixo^l,pth)
3709 pth(ixo^s)=twofl_adiab*pth(ixo^s)**twofl_gamma
3710 end if
3711 end subroutine twofl_get_pthermal_c_primitive
3712
3713 !> Calculate v_c component
3714 subroutine twofl_get_v_c_idim(w,x,ixI^L,ixO^L,idim,v)
3716
3717 integer, intent(in) :: ixi^l, ixo^l, idim
3718 double precision, intent(in) :: w(ixi^s,nw), x(ixi^s,1:ndim)
3719 double precision, intent(out) :: v(ixi^s)
3720 double precision :: rhoc(ixi^s)
3721
3722 call get_rhoc_tot(w,x,ixi^l,ixo^l,rhoc)
3723 v(ixo^s) = w(ixo^s, mom_c(idim)) / rhoc(ixo^s)
3724
3725 end subroutine twofl_get_v_c_idim
3726
3727 subroutine internal_energy_add_source_c(qdt,ixI^L,ixO^L,wCT,w,x,ie)
3729 use mod_geometry
3730
3731 integer, intent(in) :: ixi^l, ixo^l,ie
3732 double precision, intent(in) :: qdt
3733 double precision, intent(in) :: wct(ixi^s,1:nw), x(ixi^s,1:ndim)
3734 double precision, intent(inout) :: w(ixi^s,1:nw)
3735 double precision :: pth(ixi^s),v(ixi^s,1:ndir),divv(ixi^s)
3736
3737 call twofl_get_pthermal_c(wct,x,ixi^l,ixo^l,pth)
3738 call twofl_get_v_c(wct,x,ixi^l,ixi^l,v)
3739 call add_geom_pdivv(qdt,ixi^l,ixo^l,v,-pth,w,x,ie)
3740 if(fix_small_values .and. .not. has_equi_pe_c0) then
3741 call twofl_handle_small_ei_c(w,x,ixi^l,ixo^l,ie,'internal_energy_add_source')
3742 end if
3743 end subroutine internal_energy_add_source_c
3744
3745 !> handle small or negative internal energy
3746 subroutine twofl_handle_small_ei_c(w, x, ixI^L, ixO^L, ie, subname)
3749 integer, intent(in) :: ixi^l,ixo^l, ie
3750 double precision, intent(inout) :: w(ixi^s,1:nw)
3751 double precision, intent(in) :: x(ixi^s,1:ndim)
3752 character(len=*), intent(in) :: subname
3753
3754 integer :: idir
3755 logical :: flag(ixi^s,1:nw)
3756 double precision :: rhoc(ixi^s)
3757 double precision :: rhon(ixi^s)
3758
3759 flag=.false.
3760 if(has_equi_pe_c0) then
3761 where(w(ixo^s,ie)+block%equi_vars(ixo^s,equi_pe_c0_,0)*inv_gamma_1<small_e)&
3762 flag(ixo^s,ie)=.true.
3763 else
3764 where(w(ixo^s,ie)<small_e) flag(ixo^s,ie)=.true.
3765 endif
3766 if(any(flag(ixo^s,ie))) then
3767 select case (small_values_method)
3768 case ("replace")
3769 if(has_equi_pe_c0) then
3770 where(flag(ixo^s,ie)) w(ixo^s,ie)=small_e - &
3771 block%equi_vars(ixo^s,equi_pe_c0_,0)*inv_gamma_1
3772 else
3773 where(flag(ixo^s,ie)) w(ixo^s,ie)=small_e
3774 endif
3775 case ("average")
3776 call small_values_average(ixi^l, ixo^l, w, x, flag, ie)
3777 case default
3778 ! small values error shows primitive variables
3779 ! to_primitive subroutine cannot be used as this error handling
3780 ! is also used in TC where e_to_ei is explicitly called
3781 w(ixo^s,e_n_)=w(ixo^s,e_n_)*gamma_1
3782 call get_rhon_tot(w,x,ixi^l,ixo^l,rhon)
3783 w(ixo^s,e_c_)=w(ixo^s,e_c_)*gamma_1
3784 call get_rhoc_tot(w,x,ixi^l,ixo^l,rhoc)
3785 do idir = 1, ndir
3786 w(ixo^s, mom_n(idir)) = w(ixo^s, mom_n(idir))/rhon(ixo^s)
3787 w(ixo^s, mom_c(idir)) = w(ixo^s, mom_c(idir))/rhoc(ixo^s)
3788 end do
3789 call small_values_error(w, x, ixi^l, ixo^l, flag, subname)
3790 end select
3791 end if
3792
3793 end subroutine twofl_handle_small_ei_c
3794
3795 !> handle small or negative internal energy
3796 subroutine twofl_handle_small_ei_n(w, x, ixI^L, ixO^L, ie, subname)
3799 integer, intent(in) :: ixi^l,ixo^l, ie
3800 double precision, intent(inout) :: w(ixi^s,1:nw)
3801 double precision, intent(in) :: x(ixi^s,1:ndim)
3802 character(len=*), intent(in) :: subname
3803
3804 integer :: idir
3805 logical :: flag(ixi^s,1:nw)
3806 double precision :: rhoc(ixi^s)
3807 double precision :: rhon(ixi^s)
3808
3809 flag=.false.
3810 if(has_equi_pe_n0) then
3811 where(w(ixo^s,ie)+block%equi_vars(ixo^s,equi_pe_n0_,0)*inv_gamma_1<small_e)&
3812 flag(ixo^s,ie)=.true.
3813 else
3814 where(w(ixo^s,ie)<small_e) flag(ixo^s,ie)=.true.
3815 endif
3816 if(any(flag(ixo^s,ie))) then
3817 select case (small_values_method)
3818 case ("replace")
3819 if(has_equi_pe_n0) then
3820 where(flag(ixo^s,ie)) w(ixo^s,ie)=small_e - &
3821 block%equi_vars(ixo^s,equi_pe_n0_,0)*inv_gamma_1
3822 else
3823 where(flag(ixo^s,ie)) w(ixo^s,ie)=small_e
3824 endif
3825 case ("average")
3826 call small_values_average(ixi^l, ixo^l, w, x, flag, ie)
3827 case default
3828 ! small values error shows primitive variables
3829 w(ixo^s,e_n_)=w(ixo^s,e_n_)*gamma_1
3830 call get_rhon_tot(w,x,ixi^l,ixo^l,rhon)
3831 w(ixo^s,e_c_)=w(ixo^s,e_c_)*gamma_1
3832 call get_rhoc_tot(w,x,ixi^l,ixo^l,rhoc)
3833 do idir = 1, ndir
3834 w(ixo^s, mom_n(idir)) = w(ixo^s, mom_n(idir))/rhon(ixo^s)
3835 w(ixo^s, mom_c(idir)) = w(ixo^s, mom_c(idir))/rhoc(ixo^s)
3836 end do
3837 call small_values_error(w, x, ixi^l, ixo^l, flag, subname)
3838 end select
3839 end if
3840
3841 end subroutine twofl_handle_small_ei_n
3842
3843 !> Source terms after split off time-independent magnetic field
3844 subroutine add_source_b0split(qdt,ixI^L,ixO^L,wCT,w,x)
3846
3847 integer, intent(in) :: ixi^l, ixo^l
3848 double precision, intent(in) :: qdt, wct(ixi^s,1:nw), x(ixi^s,1:ndim)
3849 double precision, intent(inout) :: w(ixi^s,1:nw)
3850
3851 double precision :: a(ixi^s,3), b(ixi^s,3), axb(ixi^s,3)
3852 integer :: idir
3853
3854 a=0.d0
3855 b=0.d0
3856 ! for force-free field J0xB0 =0
3857 if(.not.b0field_forcefree) then
3858 ! store B0 magnetic field in b
3859 b(ixo^s,1:ndir)=block%B0(ixo^s,1:ndir,0)
3860
3861 ! store J0 current in a
3862 do idir=7-2*ndir,3
3863 a(ixo^s,idir)=block%J0(ixo^s,idir)
3864 end do
3865 call cross_product(ixi^l,ixo^l,a,b,axb)
3866 axb(ixo^s,:)=axb(ixo^s,:)*qdt
3867 ! add J0xB0 source term in momentum equations
3868 w(ixo^s,mom_c(1:ndir))=w(ixo^s,mom_c(1:ndir))+axb(ixo^s,1:ndir)
3869 end if
3870
3871 if(phys_total_energy) then
3872 a=0.d0
3873 ! for free-free field -(vxB0) dot J0 =0
3874 b(ixo^s,:)=wct(ixo^s,mag(:))
3875 ! store full magnetic field B0+B1 in b
3876 if(.not.b0field_forcefree) b(ixo^s,:)=b(ixo^s,:)+block%B0(ixo^s,:,0)
3877 ! store velocity in a
3878 do idir=1,ndir
3879 call twofl_get_v_c_idim(wct,x,ixi^l,ixo^l,idir,a(ixi^s,idir))
3880 end do
3881 call cross_product(ixi^l,ixo^l,a,b,axb)
3882 axb(ixo^s,:)=axb(ixo^s,:)*qdt
3883 ! add -(vxB) dot J0 source term in energy equation
3884 do idir=7-2*ndir,3
3885 w(ixo^s,e_c_)=w(ixo^s,e_c_)-axb(ixo^s,idir)*block%J0(ixo^s,idir)
3886 end do
3887 end if
3888
3889 if (fix_small_values) call twofl_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_B0')
3890
3891 end subroutine add_source_b0split
3892
3893 !> Add resistive source to w within ixO Uses 3 point stencil (1 neighbour) in
3894 !> each direction, non-conservative. If the fourthorder precompiler flag is
3895 !> set, uses fourth order central difference for the laplacian. Then the
3896 !> stencil is 5 (2 neighbours).
3897 subroutine add_source_res1(qdt,ixI^L,ixO^L,wCT,w,x)
3899 use mod_usr_methods
3900 use mod_geometry
3901
3902 integer, intent(in) :: ixi^l, ixo^l
3903 double precision, intent(in) :: qdt
3904 double precision, intent(in) :: wct(ixi^s,1:nw), x(ixi^s,1:ndim)
3905 double precision, intent(inout) :: w(ixi^s,1:nw)
3906 integer :: ixa^l,idir,jdir,kdir,idirmin,idim,jxo^l,hxo^l,ix
3907 integer :: lxo^l, kxo^l
3908
3909 double precision :: tmp(ixi^s),tmp2(ixi^s)
3910
3911 ! For ndir=2 only 3rd component of J can exist, ndir=1 is impossible for MHD
3912 double precision :: current(ixi^s,7-2*ndir:3),eta(ixi^s)
3913 double precision :: gradeta(ixi^s,1:ndim), bf(ixi^s,1:ndir)
3914
3915 ! Calculating resistive sources involve one extra layer
3916 if (twofl_4th_order) then
3917 ixa^l=ixo^l^ladd2;
3918 else
3919 ixa^l=ixo^l^ladd1;
3920 end if
3921
3922 if (iximin^d>ixamin^d.or.iximax^d<ixamax^d|.or.) &
3923 call mpistop("Error in add_source_res1: Non-conforming input limits")
3924
3925 ! Calculate current density and idirmin
3926 call get_current(wct,ixi^l,ixo^l,idirmin,current)
3927
3928 if (twofl_eta>zero)then
3929 eta(ixa^s)=twofl_eta
3930 gradeta(ixo^s,1:ndim)=zero
3931 else
3932 call usr_special_resistivity(wct,ixi^l,ixa^l,idirmin,x,current,eta)
3933 ! assumes that eta is not function of current?
3934 do idim=1,ndim
3935 call gradient(eta,ixi^l,ixo^l,idim,tmp)
3936 gradeta(ixo^s,idim)=tmp(ixo^s)
3937 end do
3938 end if
3939
3940 if(b0field) then
3941 bf(ixi^s,1:ndir)=wct(ixi^s,mag(1:ndir))+block%B0(ixi^s,1:ndir,0)
3942 else
3943 bf(ixi^s,1:ndir)=wct(ixi^s,mag(1:ndir))
3944 end if
3945
3946 do idir=1,ndir
3947 ! Put B_idir into tmp2 and eta*Laplace B_idir into tmp
3948 if (twofl_4th_order) then
3949 tmp(ixo^s)=zero
3950 tmp2(ixi^s)=bf(ixi^s,idir)
3951 do idim=1,ndim
3952 lxo^l=ixo^l+2*kr(idim,^d);
3953 jxo^l=ixo^l+kr(idim,^d);
3954 hxo^l=ixo^l-kr(idim,^d);
3955 kxo^l=ixo^l-2*kr(idim,^d);
3956 tmp(ixo^s)=tmp(ixo^s)+&
3957 (-tmp2(lxo^s)+16.0d0*tmp2(jxo^s)-30.0d0*tmp2(ixo^s)+16.0d0*tmp2(hxo^s)-tmp2(kxo^s)) &
3958 /(12.0d0 * dxlevel(idim)**2)
3959 end do
3960 else
3961 tmp(ixo^s)=zero
3962 tmp2(ixi^s)=bf(ixi^s,idir)
3963 do idim=1,ndim
3964 jxo^l=ixo^l+kr(idim,^d);
3965 hxo^l=ixo^l-kr(idim,^d);
3966 tmp(ixo^s)=tmp(ixo^s)+&
3967 (tmp2(jxo^s)-2.0d0*tmp2(ixo^s)+tmp2(hxo^s))/dxlevel(idim)**2
3968 end do
3969 end if
3970
3971 ! Multiply by eta
3972 tmp(ixo^s)=tmp(ixo^s)*eta(ixo^s)
3973
3974 ! Subtract grad(eta) x J = eps_ijk d_j eta J_k if eta is non-constant
3975 if (twofl_eta<zero)then
3976 do jdir=1,ndim; do kdir=idirmin,3
3977 if (lvc(idir,jdir,kdir)/=0)then
3978 if (lvc(idir,jdir,kdir)==1)then
3979 tmp(ixo^s)=tmp(ixo^s)-gradeta(ixo^s,jdir)*current(ixo^s,kdir)
3980 else
3981 tmp(ixo^s)=tmp(ixo^s)+gradeta(ixo^s,jdir)*current(ixo^s,kdir)
3982 end if
3983 end if
3984 end do; end do
3985 end if
3986
3987 ! Add sources related to eta*laplB-grad(eta) x J to B and e
3988 w(ixo^s,mag(idir))=w(ixo^s,mag(idir))+qdt*tmp(ixo^s)
3989 if (phys_total_energy) then
3990 w(ixo^s,e_c_)=w(ixo^s,e_c_)+qdt*tmp(ixo^s)*bf(ixo^s,idir)
3991 end if
3992 end do ! idir
3993
3994 if (phys_energy) then
3995 ! de/dt+=eta*J**2
3996 w(ixo^s,e_c_)=w(ixo^s,e_c_)+qdt*eta(ixo^s)*sum(current(ixo^s,:)**2,dim=ndim+1)
3997 end if
3998
3999 if (fix_small_values) call twofl_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_res1')
4000
4001 end subroutine add_source_res1
4002
4003 !> Add resistive source to w within ixO
4004 !> Uses 5 point stencil (2 neighbours) in each direction, conservative
4005 subroutine add_source_res2(qdt,ixI^L,ixO^L,wCT,w,x)
4007 use mod_usr_methods
4008 use mod_geometry
4009
4010 integer, intent(in) :: ixi^l, ixo^l
4011 double precision, intent(in) :: qdt
4012 double precision, intent(in) :: wct(ixi^s,1:nw), x(ixi^s,1:ndim)
4013 double precision, intent(inout) :: w(ixi^s,1:nw)
4014
4015 ! For ndir=2 only 3rd component of J can exist, ndir=1 is impossible for MHD
4016 double precision :: current(ixi^s,7-2*ndir:3),eta(ixi^s),curlj(ixi^s,1:3)
4017 double precision :: tmpvec(ixi^s,1:3),tmp(ixo^s)
4018 integer :: ixa^l,idir,idirmin,idirmin1
4019
4020 ixa^l=ixo^l^ladd2;
4021
4022 if (iximin^d>ixamin^d.or.iximax^d<ixamax^d|.or.) &
4023 call mpistop("Error in add_source_res2: Non-conforming input limits")
4024
4025 ixa^l=ixo^l^ladd1;
4026 ! Calculate current density within ixL: J=curl B, thus J_i=eps_ijk*d_j B_k
4027 ! Determine exact value of idirmin while doing the loop.
4028 call get_current(wct,ixi^l,ixa^l,idirmin,current)
4029
4030 if (twofl_eta>zero)then
4031 eta(ixa^s)=twofl_eta
4032 else
4033 call usr_special_resistivity(wct,ixi^l,ixa^l,idirmin,x,current,eta)
4034 end if
4035
4036 ! dB/dt= -curl(J*eta), thus B_i=B_i-eps_ijk d_j Jeta_k
4037 tmpvec(ixa^s,1:ndir)=zero
4038 do idir=idirmin,3
4039 tmpvec(ixa^s,idir)=current(ixa^s,idir)*eta(ixa^s)
4040 end do
4041 curlj=0.d0
4042 call curlvector(tmpvec,ixi^l,ixo^l,curlj,idirmin1,1,3)
4043 if(stagger_grid.and.ndim==2.and.ndir==3) then
4044 ! if 2.5D
4045 w(ixo^s,mag(ndir)) = w(ixo^s,mag(ndir))-qdt*curlj(ixo^s,ndir)
4046 else
4047 w(ixo^s,mag(1:ndir)) = w(ixo^s,mag(1:ndir))-qdt*curlj(ixo^s,1:ndir)
4048 end if
4049
4050 if(phys_energy) then
4051 if(phys_total_energy) then
4052 ! de/dt= +div(B x Jeta) = eta J^2 - B dot curl(eta J)
4053 ! de1/dt= eta J^2 - B1 dot curl(eta J)
4054 w(ixo^s,e_c_)=w(ixo^s,e_c_)+qdt*(eta(ixo^s)*sum(current(ixo^s,:)**2,dim=ndim+1)-&
4055 sum(wct(ixo^s,mag(1:ndir))*curlj(ixo^s,1:ndir),dim=ndim+1))
4056 else
4057 ! add eta*J**2 source term in the internal energy equation
4058 w(ixo^s,e_c_)=w(ixo^s,e_c_)+qdt*eta(ixo^s)*sum(current(ixo^s,:)**2,dim=ndim+1)
4059 end if
4060
4061 end if
4062
4063 if (fix_small_values) call twofl_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_res2')
4064 end subroutine add_source_res2
4065
4066 !> Add Hyper-resistive source to w within ixO
4067 !> Uses 9 point stencil (4 neighbours) in each direction.
4068 subroutine add_source_hyperres(qdt,ixI^L,ixO^L,wCT,w,x)
4070 use mod_geometry
4071
4072 integer, intent(in) :: ixi^l, ixo^l
4073 double precision, intent(in) :: qdt
4074 double precision, intent(in) :: wct(ixi^s,1:nw), x(ixi^s,1:ndim)
4075 double precision, intent(inout) :: w(ixi^s,1:nw)
4076 !.. local ..
4077 double precision :: current(ixi^s,7-2*ndir:3)
4078 double precision :: tmpvec(ixi^s,1:3),tmpvec2(ixi^s,1:3),tmp(ixi^s),ehyper(ixi^s,1:3)
4079 integer :: ixa^l,idir,jdir,kdir,idirmin,idirmin1
4080
4081 ixa^l=ixo^l^ladd3;
4082 if (iximin^d>ixamin^d.or.iximax^d<ixamax^d|.or.) &
4083 call mpistop("Error in add_source_hyperres: Non-conforming input limits")
4084
4085 call get_current(wct,ixi^l,ixa^l,idirmin,current)
4086 tmpvec(ixa^s,1:ndir)=zero
4087 do jdir=idirmin,3
4088 tmpvec(ixa^s,jdir)=current(ixa^s,jdir)
4089 end do
4090
4091 ixa^l=ixo^l^ladd2;
4092 call curlvector(tmpvec,ixi^l,ixa^l,tmpvec2,idirmin1,1,3)
4093
4094 ixa^l=ixo^l^ladd1;
4095 tmpvec(ixa^s,1:ndir)=zero
4096 call curlvector(tmpvec2,ixi^l,ixa^l,tmpvec,idirmin1,1,3)
4097 ehyper(ixa^s,1:ndir) = - tmpvec(ixa^s,1:ndir)*twofl_eta_hyper
4098
4099 ixa^l=ixo^l;
4100 tmpvec2(ixa^s,1:ndir)=zero
4101 call curlvector(ehyper,ixi^l,ixa^l,tmpvec2,idirmin1,1,3)
4102
4103 do idir=1,ndir
4104 w(ixo^s,mag(idir)) = w(ixo^s,mag(idir))-tmpvec2(ixo^s,idir)*qdt
4105 end do
4106
4107 if (phys_energy) then
4108 ! de/dt= +div(B x Ehyper)
4109 ixa^l=ixo^l^ladd1;
4110 tmpvec2(ixa^s,1:ndir)=zero
4111 do idir=1,ndir; do jdir=1,ndir; do kdir=idirmin,3
4112 tmpvec2(ixa^s,idir) = tmpvec(ixa^s,idir)&
4113 + lvc(idir,jdir,kdir)*wct(ixa^s,mag(jdir))*ehyper(ixa^s,kdir)
4114 end do; end do; end do
4115 tmp(ixo^s)=zero
4116 call divvector(tmpvec2,ixi^l,ixo^l,tmp)
4117 w(ixo^s,e_c_)=w(ixo^s,e_c_)+tmp(ixo^s)*qdt
4118 end if
4119
4120 if (fix_small_values) call twofl_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_hyperres')
4121
4122 end subroutine add_source_hyperres
4123
4124 subroutine add_source_glm(qdt,ixI^L,ixO^L,wCT,w,x)
4125 ! Add divB related sources to w within ixO
4126 ! corresponding to Dedner JCP 2002, 175, 645 _equation 24_
4127 ! giving the EGLM-MHD scheme
4129 use mod_geometry
4130
4131 integer, intent(in) :: ixi^l, ixo^l
4132 double precision, intent(in) :: qdt, wct(ixi^s,1:nw), x(ixi^s,1:ndim)
4133 double precision, intent(inout) :: w(ixi^s,1:nw)
4134 double precision:: divb(ixi^s)
4135 integer :: idim,idir
4136 double precision :: gradpsi(ixi^s)
4137
4138 ! We calculate now div B
4139 call get_divb(wct,ixi^l,ixo^l,divb, twofl_divb_nth)
4140
4141 ! dPsi/dt = - Ch^2/Cp^2 Psi
4142 if (twofl_glm_alpha < zero) then
4143 w(ixo^s,psi_) = abs(twofl_glm_alpha)*wct(ixo^s,psi_)
4144 else
4145 ! implicit update of Psi variable
4146 ! equation (27) in Mignone 2010 J. Com. Phys. 229, 2117
4147 if(slab_uniform) then
4148 w(ixo^s,psi_) = dexp(-qdt*cmax_global*twofl_glm_alpha/minval(dxlevel(:)))*w(ixo^s,psi_)
4149 else
4150 w(ixo^s,psi_) = dexp(-qdt*cmax_global*twofl_glm_alpha/minval(block%ds(ixo^s,:),dim=ndim+1))*w(ixo^s,psi_)
4151 end if
4152 end if
4153
4154 ! gradient of Psi
4155 do idim=1,ndim
4156 select case(typegrad)
4157 case("central")
4158 call gradient(wct(ixi^s,psi_),ixi^l,ixo^l,idim,gradpsi)
4159 case("limited")
4160 call gradientl(wct(ixi^s,psi_),ixi^l,ixo^l,idim,gradpsi)
4161 end select
4162 if (phys_total_energy) then
4163 ! e = e -qdt (b . grad(Psi))
4164 w(ixo^s,e_c_) = w(ixo^s,e_c_)-qdt*wct(ixo^s,mag(idim))*gradpsi(ixo^s)
4165 end if
4166 end do
4167
4168 ! m = m - qdt b div b
4169 do idir=1,ndir
4170 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)
4171 end do
4172
4173 if (fix_small_values) call twofl_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_glm')
4174
4175 end subroutine add_source_glm
4176
4177 !> Add divB related sources to w within ixO corresponding to Powel
4178 subroutine add_source_powel(qdt,ixI^L,ixO^L,wCT,w,x)
4180
4181 integer, intent(in) :: ixi^l, ixo^l
4182 double precision, intent(in) :: qdt, wct(ixi^s,1:nw), x(ixi^s,1:ndim)
4183 double precision, intent(inout) :: w(ixi^s,1:nw)
4184 double precision :: divb(ixi^s),v(ixi^s,1:ndir)
4185 integer :: idir
4186
4187 ! We calculate now div B
4188 call get_divb(wct,ixi^l,ixo^l,divb, twofl_divb_nth)
4189
4190 ! calculate velocity
4191 call twofl_get_v_c(wct,x,ixi^l,ixo^l,v)
4192
4193 if (phys_total_energy) then
4194 ! e = e - qdt (v . b) * div b
4195 w(ixo^s,e_c_)=w(ixo^s,e_c_)-&
4196 qdt*sum(v(ixo^s,:)*wct(ixo^s,mag(:)),dim=ndim+1)*divb(ixo^s)
4197 end if
4198
4199 ! b = b - qdt v * div b
4200 do idir=1,ndir
4201 w(ixo^s,mag(idir))=w(ixo^s,mag(idir))-qdt*v(ixo^s,idir)*divb(ixo^s)
4202 end do
4203
4204 ! m = m - qdt b div b
4205 do idir=1,ndir
4206 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)
4207 end do
4208
4209 if (fix_small_values) call twofl_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_powel')
4210
4211 end subroutine add_source_powel
4212
4213 subroutine add_source_janhunen(qdt,ixI^L,ixO^L,wCT,w,x)
4214 ! Add divB related sources to w within ixO
4215 ! corresponding to Janhunen, just the term in the induction equation.
4217
4218 integer, intent(in) :: ixi^l, ixo^l
4219 double precision, intent(in) :: qdt, wct(ixi^s,1:nw), x(ixi^s,1:ndim)
4220 double precision, intent(inout) :: w(ixi^s,1:nw)
4221 double precision :: divb(ixi^s),vel(ixi^s)
4222 integer :: idir
4223
4224 ! We calculate now div B
4225 call get_divb(wct,ixi^l,ixo^l,divb, twofl_divb_nth)
4226
4227 ! b = b - qdt v * div b
4228 do idir=1,ndir
4229 call twofl_get_v_c_idim(wct,x,ixi^l,ixo^l,idir,vel)
4230 w(ixo^s,mag(idir))=w(ixo^s,mag(idir))-qdt*vel(ixo^s)*divb(ixo^s)
4231 end do
4232
4233 if (fix_small_values) call twofl_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_janhunen')
4234
4235 end subroutine add_source_janhunen
4236
4237 subroutine add_source_linde(qdt,ixI^L,ixO^L,wCT,w,x)
4238 ! Add Linde's divB related sources to wnew within ixO
4240 use mod_geometry
4241
4242 integer, intent(in) :: ixi^l, ixo^l
4243 double precision, intent(in) :: qdt, wct(ixi^s,1:nw), x(ixi^s,1:ndim)
4244 double precision, intent(inout) :: w(ixi^s,1:nw)
4245 integer :: idim, idir, ixp^l, i^d, iside
4246 double precision :: divb(ixi^s),graddivb(ixi^s)
4247 logical, dimension(-1:1^D&) :: leveljump
4248
4249 ! Calculate div B
4250 ixp^l=ixo^l^ladd1;
4251 call get_divb(wct,ixi^l,ixp^l,divb, twofl_divb_nth)
4252
4253 ! for AMR stability, retreat one cell layer from the boarders of level jump
4254 {do i^db=-1,1\}
4255 if(i^d==0|.and.) cycle
4256 if(neighbor_type(i^d,block%igrid)==2 .or. neighbor_type(i^d,block%igrid)==4) then
4257 leveljump(i^d)=.true.
4258 else
4259 leveljump(i^d)=.false.
4260 end if
4261 {end do\}
4262
4263 ixp^l=ixo^l;
4264 do idim=1,ndim
4265 select case(idim)
4266 {case(^d)
4267 do iside=1,2
4268 i^dd=kr(^dd,^d)*(2*iside-3);
4269 if (leveljump(i^dd)) then
4270 if (iside==1) then
4271 ixpmin^d=ixomin^d-i^d
4272 else
4273 ixpmax^d=ixomax^d-i^d
4274 end if
4275 end if
4276 end do
4277 \}
4278 end select
4279 end do
4280
4281 ! Add Linde's diffusive terms
4282 do idim=1,ndim
4283 ! Calculate grad_idim(divb)
4284 select case(typegrad)
4285 case("central")
4286 call gradient(divb,ixi^l,ixp^l,idim,graddivb)
4287 case("limited")
4288 call gradientl(divb,ixi^l,ixp^l,idim,graddivb)
4289 end select
4290
4291 ! Multiply by Linde's eta*dt = divbdiff*(c_max*dx)*dt = divbdiff*dx**2
4292 if (slab_uniform) then
4293 graddivb(ixp^s)=graddivb(ixp^s)*divbdiff/(^d&1.0d0/dxlevel(^d)**2+)
4294 else
4295 graddivb(ixp^s)=graddivb(ixp^s)*divbdiff &
4296 /(^d&1.0d0/block%ds(ixp^s,^d)**2+)
4297 end if
4298
4299 w(ixp^s,mag(idim))=w(ixp^s,mag(idim))+graddivb(ixp^s)
4300
4301 if (typedivbdiff=='all' .and. phys_total_energy) then
4302 ! e += B_idim*eta*grad_idim(divb)
4303 w(ixp^s,e_c_)=w(ixp^s,e_c_)+wct(ixp^s,mag(idim))*graddivb(ixp^s)
4304 end if
4305 end do
4306
4307 if (fix_small_values) call twofl_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_linde')
4308
4309 end subroutine add_source_linde
4310
4311
4312 !> get dimensionless div B = |divB| * volume / area / |B|
4313 subroutine get_normalized_divb(w,ixI^L,ixO^L,divb)
4314
4316
4317 integer, intent(in) :: ixi^l, ixo^l
4318 double precision, intent(in) :: w(ixi^s,1:nw)
4319 double precision :: divb(ixi^s), dsurface(ixi^s)
4320
4321 double precision :: invb(ixo^s)
4322 integer :: ixa^l,idims
4323
4324 call get_divb(w,ixi^l,ixo^l,divb)
4325 invb(ixo^s)=sqrt(twofl_mag_en_all(w,ixi^l,ixo^l))
4326 where(invb(ixo^s)/=0.d0)
4327 invb(ixo^s)=1.d0/invb(ixo^s)
4328 end where
4329 if(slab_uniform) then
4330 divb(ixo^s)=0.5d0*abs(divb(ixo^s))*invb(ixo^s)/sum(1.d0/dxlevel(:))
4331 else
4332 ixamin^d=ixomin^d-1;
4333 ixamax^d=ixomax^d-1;
4334 dsurface(ixo^s)= sum(block%surfaceC(ixo^s,:),dim=ndim+1)
4335 do idims=1,ndim
4336 ixa^l=ixo^l-kr(idims,^d);
4337 dsurface(ixo^s)=dsurface(ixo^s)+block%surfaceC(ixa^s,idims)
4338 end do
4339 divb(ixo^s)=abs(divb(ixo^s))*invb(ixo^s)*&
4340 block%dvolume(ixo^s)/dsurface(ixo^s)
4341 end if
4342
4343 end subroutine get_normalized_divb
4344
4345 !> Calculate idirmin and the idirmin:3 components of the common current array
4346 !> make sure that dxlevel(^D) is set correctly.
4347 subroutine get_current(w,ixI^L,ixO^L,idirmin,current)
4349 use mod_geometry
4350
4351 integer, intent(in) :: ixo^l, ixi^l
4352 double precision, intent(in) :: w(ixi^s,1:nw)
4353 integer, intent(out) :: idirmin
4354 integer :: idir, idirmin0
4355
4356 ! For ndir=2 only 3rd component of J can exist, ndir=1 is impossible for MHD
4357 double precision :: current(ixi^s,7-2*ndir:3),bvec(ixi^s,1:ndir)
4358
4359 idirmin0 = 7-2*ndir
4360
4361 bvec(ixi^s,1:ndir)=w(ixi^s,mag(1:ndir))
4362
4363 call curlvector(bvec,ixi^l,ixo^l,current,idirmin,idirmin0,ndir)
4364
4365 if(b0field) current(ixo^s,idirmin0:3)=current(ixo^s,idirmin0:3)+&
4366 block%J0(ixo^s,idirmin0:3)
4367
4368 end subroutine get_current
4369
4370 ! copied from gravity
4371 !> w[iw]=w[iw]+qdt*S[wCT,qtC,x] where S is the source based on wCT within ixO
4372 subroutine gravity_add_source(qdt,ixI^L,ixO^L,wCT,w,x,&
4373 energy,qsourcesplit,active)
4375 use mod_usr_methods
4376
4377 integer, intent(in) :: ixi^l, ixo^l
4378 double precision, intent(in) :: qdt, x(ixi^s,1:ndim)
4379 double precision, intent(in) :: wct(ixi^s,1:nw)
4380 double precision, intent(inout) :: w(ixi^s,1:nw)
4381 logical, intent(in) :: energy,qsourcesplit
4382 logical, intent(inout) :: active
4383 double precision :: vel(ixi^s)
4384 integer :: idim
4385
4386 double precision :: gravity_field(ixi^s,ndim)
4387
4388 if(qsourcesplit .eqv. grav_split) then
4389 active = .true.
4390
4391 if (.not. associated(usr_gravity)) then
4392 write(*,*) "mod_usr.t: please point usr_gravity to a subroutine"
4393 write(*,*) "like the phys_gravity in mod_usr_methods.t"
4394 call mpistop("gravity_add_source: usr_gravity not defined")
4395 else
4396 call usr_gravity(ixi^l,ixo^l,wct,x,gravity_field)
4397 end if
4398
4399 do idim = 1, ndim
4400 w(ixo^s,mom_n(idim)) = w(ixo^s,mom_n(idim)) &
4401 + qdt * gravity_field(ixo^s,idim) * wct(ixo^s,rho_n_)
4402 w(ixo^s,mom_c(idim)) = w(ixo^s,mom_c(idim)) &
4403 + qdt * gravity_field(ixo^s,idim) * wct(ixo^s,rho_c_)
4404 if(energy) then
4405#if !defined(E_RM_W0) || E_RM_W0 == 1
4406 call twofl_get_v_n_idim(wct,x,ixi^l,ixo^l,idim,vel)
4407 w(ixo^s,e_n_)=w(ixo^s,e_n_) &
4408 + qdt * gravity_field(ixo^s,idim) * vel(ixo^s) * wct(ixo^s,rho_n_)
4409 call twofl_get_v_c_idim(wct,x,ixi^l,ixo^l,idim,vel)
4410 w(ixo^s,e_c_)=w(ixo^s,e_c_) &
4411 + qdt * gravity_field(ixo^s,idim) * vel(ixo^s) * wct(ixo^s,rho_c_)
4412#else
4413 w(ixo^s,e_n_)=w(ixo^s,e_n_) &
4414 + qdt * gravity_field(ixo^s,idim) * wct(ixo^s,mom_n(idim))
4415 w(ixo^s,e_c_)=w(ixo^s,e_c_) &
4416 + qdt * gravity_field(ixo^s,idim) * wct(ixo^s,mom_c(idim))
4417#endif
4418
4419
4420 end if
4421 end do
4422 end if
4423
4424 end subroutine gravity_add_source
4425
4426 subroutine gravity_get_dt(w,ixI^L,ixO^L,dtnew,dx^D,x)
4428 use mod_usr_methods
4429
4430 integer, intent(in) :: ixi^l, ixo^l
4431 double precision, intent(in) :: dx^d, x(ixi^s,1:ndim), w(ixi^s,1:nw)
4432 double precision, intent(inout) :: dtnew
4433
4434 double precision :: dxinv(1:ndim), max_grav
4435 integer :: idim
4436
4437 double precision :: gravity_field(ixi^s,ndim)
4438
4439 ^d&dxinv(^d)=one/dx^d;
4440
4441 if(.not. associated(usr_gravity)) then
4442 write(*,*) "mod_usr.t: please point usr_gravity to a subroutine"
4443 write(*,*) "like the phys_gravity in mod_usr_methods.t"
4444 call mpistop("gravity_get_dt: usr_gravity not defined")
4445 else
4446 call usr_gravity(ixi^l,ixo^l,w,x,gravity_field)
4447 end if
4448
4449 do idim = 1, ndim
4450 max_grav = maxval(abs(gravity_field(ixo^s,idim)))
4451 max_grav = max(max_grav, epsilon(1.0d0))
4452 dtnew = min(dtnew, 1.0d0 / sqrt(max_grav * dxinv(idim)))
4453 end do
4454
4455 end subroutine gravity_get_dt
4456
4457 !> If resistivity is not zero, check diffusion time limit for dt
4458 subroutine twofl_get_dt(w,ixI^L,ixO^L,dtnew,dx^D,x)
4460 use mod_usr_methods
4462 !use mod_viscosity, only: viscosity_get_dt
4463 !use mod_gravity, only: gravity_get_dt
4464
4465 integer, intent(in) :: ixi^l, ixo^l
4466 double precision, intent(inout) :: dtnew
4467 double precision, intent(in) :: dx^d
4468 double precision, intent(in) :: w(ixi^s,1:nw)
4469 double precision, intent(in) :: x(ixi^s,1:ndim)
4470
4471 integer :: idirmin,idim
4472 double precision :: dxarr(ndim)
4473 double precision :: current(ixi^s,7-2*ndir:3),eta(ixi^s)
4474
4475 dtnew = bigdouble
4476
4477 ^d&dxarr(^d)=dx^d;
4478 if (twofl_eta>zero)then
4479 dtnew=dtdiffpar*minval(dxarr(1:ndim))**2/twofl_eta
4480 else if (twofl_eta<zero)then
4481 call get_current(w,ixi^l,ixo^l,idirmin,current)
4482 call usr_special_resistivity(w,ixi^l,ixo^l,idirmin,x,current,eta)
4483 dtnew=bigdouble
4484 do idim=1,ndim
4485 if(slab_uniform) then
4486 dtnew=min(dtnew,&
4487 dtdiffpar/(smalldouble+maxval(eta(ixo^s)/dxarr(idim)**2)))
4488 else
4489 dtnew=min(dtnew,&
4490 dtdiffpar/(smalldouble+maxval(eta(ixo^s)/block%ds(ixo^s,idim)**2)))
4491 end if
4492 end do
4493 end if
4494
4495 if(twofl_eta_hyper>zero) then
4496 if(slab_uniform) then
4497 dtnew=min(dtdiffpar*minval(dxarr(1:ndim))**4/twofl_eta_hyper,dtnew)
4498 else
4499 dtnew=min(dtdiffpar*minval(block%ds(ixo^s,1:ndim))**4/twofl_eta_hyper,dtnew)
4500 end if
4501 end if
4502
4503 ! the timestep related to coll terms: 1/(rho_n rho_c alpha)
4504 if(dtcollpar>0d0 .and. has_collisions()) then
4505 call coll_get_dt(w,x,ixi^l,ixo^l,dtnew)
4506 endif
4507
4509 call cooling_get_dt(w,ixi^l,ixo^l,dtnew,dx^d,x,rc_fl_c)
4510 end if
4512 call cooling_get_dt(w,ixi^l,ixo^l,dtnew,dx^d,x,rc_fl_n)
4513 end if
4514!
4515! if(twofl_viscosity) then
4516! call viscosity_get_dt(w,ixI^L,ixO^L,dtnew,dx^D,x)
4517! end if
4518!
4519 if(twofl_gravity) then
4520 call gravity_get_dt(w,ixi^l,ixo^l,dtnew,dx^d,x)
4521 end if
4522 if(twofl_hyperdiffusivity) then
4523 call hyperdiffusivity_get_dt(w,ixi^l,ixo^l,dtnew,dx^d,x)
4524 end if
4525
4526
4527 end subroutine twofl_get_dt
4528
4529 pure function has_collisions() result(res)
4530 logical :: res
4531 res = .not. twofl_alpha_coll_constant .or. twofl_alpha_coll >0d0
4532 end function has_collisions
4533
4534 subroutine coll_get_dt(w,x,ixI^L,ixO^L,dtnew)
4536 integer, intent(in) :: ixi^l, ixo^l
4537 double precision, intent(in) :: w(ixi^s,1:nw)
4538 double precision, intent(in) :: x(ixi^s,1:ndim)
4539 double precision, intent(inout) :: dtnew
4540
4541 double precision :: rhon(ixi^s), rhoc(ixi^s), alpha(ixi^s)
4542 double precision, allocatable :: gamma_rec(:^d&), gamma_ion(:^D&)
4543 double precision :: max_coll_rate
4544
4545 call get_rhon_tot(w,x,ixi^l,ixo^l,rhon)
4546 call get_rhoc_tot(w,x,ixi^l,ixo^l,rhoc)
4547
4548 call get_alpha_coll(ixi^l, ixo^l, w, x, alpha)
4549 max_coll_rate = maxval(alpha(ixo^s) * max(rhon(ixo^s), rhoc(ixo^s)))
4550
4551 if(twofl_coll_inc_ionrec) then
4552 allocate(gamma_ion(ixi^s), gamma_rec(ixi^s))
4553 call get_gamma_ion_rec(ixi^l, ixo^l, w, x, gamma_rec, gamma_ion)
4554 max_coll_rate=max(max_coll_rate, maxval(gamma_ion(ixo^s)), maxval(gamma_rec(ixo^s)))
4555 deallocate(gamma_ion, gamma_rec)
4556 endif
4557 dtnew = min(dtcollpar/max_coll_rate, dtnew)
4558
4559 end subroutine coll_get_dt
4560
4561 ! Add geometrical source terms to w
4562 subroutine twofl_add_source_geom(qdt,dtfactor,ixI^L,ixO^L,wCT,wprim,w,x)
4564 use mod_geometry
4565
4566 integer, intent(in) :: ixi^l, ixo^l
4567 double precision, intent(in) :: qdt, dtfactor,x(ixi^s,1:ndim)
4568 double precision, intent(inout) :: wct(ixi^s,1:nw), wprim(ixi^s,1:nw), w(ixi^s,1:nw)
4569
4570 integer :: iw,idir, h1x^l{^nooned, h2x^l}
4571 double precision :: tmp(ixi^s),tmp1(ixi^s),tmp2(ixi^s),rho(ixi^s)
4572
4573 integer :: mr_,mphi_ ! Polar var. names
4574 integer :: br_,bphi_
4575
4576 ! charges
4577
4578 mr_=mom_c(1); mphi_=mom_c(1)-1+phi_ ! Polar var. names
4579 br_=mag(1); bphi_=mag(1)-1+phi_
4580 call get_rhoc_tot(wct,x,ixi^l,ixo^l,rho)
4581
4582 select case (coordinate)
4583 case (cylindrical)
4584 call twofl_get_p_c_total(wct,x,ixi^l,ixo^l,tmp)
4585
4586 if(phi_>0) then
4587 w(ixo^s,mr_)=w(ixo^s,mr_)+qdt/x(ixo^s,1)*(tmp(ixo^s)-&
4588 wct(ixo^s,bphi_)**2+wct(ixo^s,mphi_)**2/rho(ixo^s))
4589 w(ixo^s,mphi_)=w(ixo^s,mphi_)+qdt/x(ixo^s,1)*(&
4590 -wct(ixo^s,mphi_)*wct(ixo^s,mr_)/rho(ixo^s) &
4591 +wct(ixo^s,bphi_)*wct(ixo^s,br_))
4592 if(.not.stagger_grid) then
4593 w(ixo^s,bphi_)=w(ixo^s,bphi_)+qdt/x(ixo^s,1)*&
4594 (wct(ixo^s,bphi_)*wct(ixo^s,mr_) &
4595 -wct(ixo^s,br_)*wct(ixo^s,mphi_)) &
4596 /rho(ixo^s)
4597 end if
4598 else
4599 w(ixo^s,mr_)=w(ixo^s,mr_)+qdt/x(ixo^s,1)*tmp(ixo^s)
4600 end if
4601 if(twofl_glm) w(ixo^s,br_)=w(ixo^s,br_)+qdt*wct(ixo^s,psi_)/x(ixo^s,1)
4602 case (spherical)
4603 h1x^l=ixo^l-kr(1,^d); {^nooned h2x^l=ixo^l-kr(2,^d);}
4604 call twofl_get_p_c_total(wct,x,ixi^l,ixo^l,tmp1)
4605 tmp(ixo^s)=tmp1(ixo^s)
4606 if(b0field) then
4607 tmp2(ixo^s)=sum(block%B0(ixo^s,:,0)*wct(ixo^s,mag(:)),dim=ndim+1)
4608 tmp(ixo^s)=tmp(ixo^s)+tmp2(ixo^s)
4609 end if
4610 ! m1
4611 tmp(ixo^s)=tmp(ixo^s)*x(ixo^s,1) &
4612 *(block%surfaceC(ixo^s,1)-block%surfaceC(h1x^s,1))/block%dvolume(ixo^s)
4613 if(ndir>1) then
4614 do idir=2,ndir
4615 tmp(ixo^s)=tmp(ixo^s)+wct(ixo^s,mom_c(idir))**2/rho(ixo^s)-wct(ixo^s,mag(idir))**2
4616 if(b0field) tmp(ixo^s)=tmp(ixo^s)-2.0d0*block%B0(ixo^s,idir,0)*wct(ixo^s,mag(idir))
4617 end do
4618 end if
4619 w(ixo^s,mom_c(1))=w(ixo^s,mom_c(1))+qdt*tmp(ixo^s)/x(ixo^s,1)
4620 ! b1
4621 if(twofl_glm) then
4622 w(ixo^s,mag(1))=w(ixo^s,mag(1))+qdt/x(ixo^s,1)*2.0d0*wct(ixo^s,psi_)
4623 end if
4624
4625 {^nooned
4626 ! m2
4627 tmp(ixo^s)=tmp1(ixo^s)
4628 if(b0field) then
4629 tmp(ixo^s)=tmp(ixo^s)+tmp2(ixo^s)
4630 end if
4631 ! This will make hydrostatic p=const an exact solution
4632 w(ixo^s,mom_c(2))=w(ixo^s,mom_c(2))+qdt*tmp(ixo^s) &
4633 *(block%surfaceC(ixo^s,2)-block%surfaceC(h2x^s,2)) &
4634 /block%dvolume(ixo^s)
4635 tmp(ixo^s)=-(wct(ixo^s,mom_c(1))*wct(ixo^s,mom_c(2))/rho(ixo^s) &
4636 -wct(ixo^s,mag(1))*wct(ixo^s,mag(2)))
4637 if (b0field) then
4638 tmp(ixo^s)=tmp(ixo^s)+block%B0(ixo^s,1,0)*wct(ixo^s,mag(2)) &
4639 +wct(ixo^s,mag(1))*block%B0(ixo^s,2,0)
4640 end if
4641 if(ndir==3) then
4642 tmp(ixo^s)=tmp(ixo^s)+(wct(ixo^s,mom_c(3))**2/rho(ixo^s) &
4643 -wct(ixo^s,mag(3))**2)*dcos(x(ixo^s,2))/dsin(x(ixo^s,2))
4644 if (b0field) then
4645 tmp(ixo^s)=tmp(ixo^s)-2.0d0*block%B0(ixo^s,3,0)*wct(ixo^s,mag(3))&
4646 *dcos(x(ixo^s,2))/dsin(x(ixo^s,2))
4647 end if
4648 end if
4649 w(ixo^s,mom_c(2))=w(ixo^s,mom_c(2))+qdt*tmp(ixo^s)/x(ixo^s,1)
4650 ! b2
4651 if(.not.stagger_grid) then
4652 tmp(ixo^s)=(wct(ixo^s,mom_c(1))*wct(ixo^s,mag(2)) &
4653 -wct(ixo^s,mom_c(2))*wct(ixo^s,mag(1)))/rho(ixo^s)
4654 if(b0field) then
4655 tmp(ixo^s)=tmp(ixo^s)+(wct(ixo^s,mom_c(1))*block%B0(ixo^s,2,0) &
4656 -wct(ixo^s,mom_c(2))*block%B0(ixo^s,1,0))/rho(ixo^s)
4657 end if
4658 if(twofl_glm) then
4659 tmp(ixo^s)=tmp(ixo^s) &
4660 + dcos(x(ixo^s,2))/dsin(x(ixo^s,2))*wct(ixo^s,psi_)
4661 end if
4662 w(ixo^s,mag(2))=w(ixo^s,mag(2))+qdt*tmp(ixo^s)/x(ixo^s,1)
4663 end if
4664 }
4665
4666 if(ndir==3) then
4667 ! m3
4668 tmp(ixo^s)=-(wct(ixo^s,mom_c(3))*wct(ixo^s,mom_c(1))/rho(ixo^s) &
4669 -wct(ixo^s,mag(3))*wct(ixo^s,mag(1))) {^nooned &
4670 -(wct(ixo^s,mom_c(2))*wct(ixo^s,mom_c(3))/rho(ixo^s) &
4671 -wct(ixo^s,mag(2))*wct(ixo^s,mag(3))) &
4672 *dcos(x(ixo^s,2))/dsin(x(ixo^s,2)) }
4673 if (b0field) then
4674 tmp(ixo^s)=tmp(ixo^s)+block%B0(ixo^s,1,0)*wct(ixo^s,mag(3)) &
4675 +wct(ixo^s,mag(1))*block%B0(ixo^s,3,0) {^nooned &
4676 +(block%B0(ixo^s,2,0)*wct(ixo^s,mag(3)) &
4677 +wct(ixo^s,mag(2))*block%B0(ixo^s,3,0)) &
4678 *dcos(x(ixo^s,2))/dsin(x(ixo^s,2)) }
4679 end if
4680 w(ixo^s,mom_c(3))=w(ixo^s,mom_c(3))+qdt*tmp(ixo^s)/x(ixo^s,1)
4681 ! b3
4682 if(.not.stagger_grid) then
4683 tmp(ixo^s)=(wct(ixo^s,mom_c(1))*wct(ixo^s,mag(3)) &
4684 -wct(ixo^s,mom_c(3))*wct(ixo^s,mag(1)))/rho(ixo^s) {^nooned &
4685 -(wct(ixo^s,mom_c(3))*wct(ixo^s,mag(2)) &
4686 -wct(ixo^s,mom_c(2))*wct(ixo^s,mag(3)))*dcos(x(ixo^s,2)) &
4687 /(rho(ixo^s)*dsin(x(ixo^s,2))) }
4688 if (b0field) then
4689 tmp(ixo^s)=tmp(ixo^s)+(wct(ixo^s,mom_c(1))*block%B0(ixo^s,3,0) &
4690 -wct(ixo^s,mom_c(3))*block%B0(ixo^s,1,0))/rho(ixo^s){^nooned &
4691 -(wct(ixo^s,mom_c(3))*block%B0(ixo^s,2,0) &
4692 -wct(ixo^s,mom_c(2))*block%B0(ixo^s,3,0))*dcos(x(ixo^s,2)) &
4693 /(rho(ixo^s)*dsin(x(ixo^s,2))) }
4694 end if
4695 w(ixo^s,mag(3))=w(ixo^s,mag(3))+qdt*tmp(ixo^s)/x(ixo^s,1)
4696 end if
4697 end if
4698 end select
4699
4700 ! neutrals
4701 !TODO no dust: see and implement them from hd/mod_hd_phys !
4702 !uncomment cartesian expansion
4703 call get_rhon_tot(wct,x,ixi^l,ixo^l,rho)
4704 call twofl_get_pthermal_n(wct, x, ixi^l, ixo^l, tmp1)
4705
4706 select case (coordinate)
4707! case(Cartesian_expansion)
4708! !the user provides the functions of exp_factor and del_exp_factor
4709! if(associated(usr_set_surface)) call usr_set_surface(ixI^L,x,block%dx,exp_factor,del_exp_factor,exp_factor_primitive)
4710! tmp(ixO^S) = tmp1(ixO^S)*del_exp_factor(ixO^S)/exp_factor(ixO^S)
4711! w(ixO^S,mom(1)) = w(ixO^S,mom(1)) + qdt*tmp(ixO^S)
4712
4713 case (cylindrical)
4714 mr_ = mom_n(r_)
4715 if (phi_ > 0) then
4716 where (rho(ixo^s) > 0d0)
4717 tmp(ixo^s) = tmp1(ixo^s) + wct(ixo^s, mphi_)**2 / rho(ixo^s)
4718 w(ixo^s, mr_) = w(ixo^s, mr_) + qdt * tmp(ixo^s) / x(ixo^s, r_)
4719 end where
4720 ! s[mphi]=(-mphi*mr/rho)/radius
4721 where (rho(ixo^s) > 0d0)
4722 tmp(ixo^s) = -wct(ixo^s, mphi_) * wct(ixo^s, mr_) / rho(ixo^s)
4723 w(ixo^s, mphi_) = w(ixo^s, mphi_) + qdt * tmp(ixo^s) / x(ixo^s, r_)
4724 end where
4725 else
4726 ! s[mr]=2pthermal/radius
4727 w(ixo^s, mr_) = w(ixo^s, mr_) + qdt * tmp1(ixo^s) / x(ixo^s, r_)
4728 end if
4729 case (spherical)
4730 if(phi_>0) mphi_ = mom_n(phi_)
4731 h1x^l=ixo^l-kr(1,^d); {^nooned h2x^l=ixo^l-kr(2,^d);}
4732 ! s[mr]=((mtheta**2+mphi**2)/rho+2*p)/r
4733 tmp(ixo^s) = tmp1(ixo^s) * x(ixo^s, 1) &
4734 *(block%surfaceC(ixo^s, 1) - block%surfaceC(h1x^s, 1)) &
4735 /block%dvolume(ixo^s)
4736 if (ndir > 1) then
4737 do idir = 2, ndir
4738 tmp(ixo^s) = tmp(ixo^s) + wct(ixo^s, mom_n(idir))**2 / rho(ixo^s)
4739 end do
4740 end if
4741 w(ixo^s, mr_) = w(ixo^s, mr_) + qdt * tmp(ixo^s) / x(ixo^s, 1)
4742
4743 {^nooned
4744 ! s[mtheta]=-(mr*mtheta/rho)/r+cot(theta)*(mphi**2/rho+p)/r
4745 tmp(ixo^s) = tmp1(ixo^s) * x(ixo^s, 1) &
4746 * (block%surfaceC(ixo^s, 2) - block%surfaceC(h2x^s, 2)) &
4747 / block%dvolume(ixo^s)
4748 if (ndir == 3) then
4749 tmp(ixo^s) = tmp(ixo^s) + (wct(ixo^s, mom_n(3))**2 / rho(ixo^s)) / tan(x(ixo^s, 2))
4750 end if
4751 tmp(ixo^s) = tmp(ixo^s) - (wct(ixo^s, mom_n(2)) * wct(ixo^s, mr_)) / rho(ixo^s)
4752 w(ixo^s, mom_n(2)) = w(ixo^s, mom_n(2)) + qdt * tmp(ixo^s) / x(ixo^s, 1)
4753
4754 if (ndir == 3) then
4755 ! s[mphi]=-(mphi*mr/rho)/r-cot(theta)*(mtheta*mphi/rho)/r
4756 tmp(ixo^s) = -(wct(ixo^s, mom_n(3)) * wct(ixo^s, mr_)) / rho(ixo^s)&
4757 - (wct(ixo^s, mom_n(2)) * wct(ixo^s, mom_n(3))) / rho(ixo^s) / tan(x(ixo^s, 2))
4758 w(ixo^s, mom_n(3)) = w(ixo^s, mom_n(3)) + qdt * tmp(ixo^s) / x(ixo^s, 1)
4759 end if
4760 }
4761 end select
4762
4763 contains
4764 subroutine twofl_get_p_c_total(w,x,ixI^L,ixO^L,p)
4766
4767 integer, intent(in) :: ixI^L, ixO^L
4768 double precision, intent(in) :: w(ixI^S,nw)
4769 double precision, intent(in) :: x(ixI^S,1:ndim)
4770 double precision, intent(out) :: p(ixI^S)
4771
4772 call twofl_get_pthermal_c(w,x,ixi^l,ixo^l,p)
4773
4774 p(ixo^s) = p(ixo^s) + 0.5d0 * sum(w(ixo^s, mag(:))**2, dim=ndim+1)
4775
4776 end subroutine twofl_get_p_c_total
4777
4778 end subroutine twofl_add_source_geom
4779
4780 subroutine twofl_get_temp_c_pert_from_etot(w, x, ixI^L, ixO^L, res)
4782 integer, intent(in) :: ixI^L, ixO^L
4783 double precision, intent(in) :: w(ixI^S, 1:nw)
4784 double precision, intent(in) :: x(ixI^S, 1:ndim)
4785 double precision, intent(out):: res(ixI^S)
4786
4787 ! store pe1 in res
4788 res(ixo^s)=(gamma_1*(w(ixo^s,e_c_)&
4789 - twofl_kin_en_c(w,ixi^l,ixo^l)&
4790 - twofl_mag_en(w,ixi^l,ixo^l)))
4791 if(has_equi_pe_c0) then
4792 res(ixo^s) = res(ixo^s) + block%equi_vars(ixo^s,equi_pe_c0_,b0i)
4793 if(has_equi_rho_c0) then
4794 res(ixo^s) = res(ixo^s)/(rc * (w(ixo^s,rho_c_)+ block%equi_vars(ixo^s,equi_rho_c0_,b0i))) - &
4795 block%equi_vars(ixo^s,equi_pe_c0_,b0i)/(rc * block%equi_vars(ixo^s,equi_rho_c0_,b0i))
4796 else
4797 ! infinite equi temperature with p0 and 0 density
4798 res(ixo^s) = 0d0
4799 endif
4800 else
4801 res(ixo^s) = res(ixo^s)/(rc * w(ixo^s,rho_c_))
4802 endif
4803
4804 end subroutine twofl_get_temp_c_pert_from_etot
4805
4806 !> Compute 2 times total magnetic energy
4807 function twofl_mag_en_all(w, ixI^L, ixO^L) result(mge)
4809 integer, intent(in) :: ixI^L, ixO^L
4810 double precision, intent(in) :: w(ixI^S, nw)
4811 double precision :: mge(ixO^S)
4812
4813 if (b0field) then
4814 mge(ixo^s) = sum((w(ixo^s, mag(:))+block%B0(ixo^s,:,b0i))**2, dim=ndim+1)
4815 else
4816 mge(ixo^s) = sum(w(ixo^s, mag(:))**2, dim=ndim+1)
4817 end if
4818 end function twofl_mag_en_all
4819
4820 !> Compute full magnetic field by direction
4821 function twofl_mag_i_all(w, ixI^L, ixO^L,idir) result(mgf)
4823 integer, intent(in) :: ixI^L, ixO^L, idir
4824 double precision, intent(in) :: w(ixI^S, nw)
4825 double precision :: mgf(ixO^S)
4826
4827 if (b0field) then
4828 mgf(ixo^s) = w(ixo^s, mag(idir))+block%B0(ixo^s,idir,b0i)
4829 else
4830 mgf(ixo^s) = w(ixo^s, mag(idir))
4831 end if
4832 end function twofl_mag_i_all
4833
4834 !> Compute evolving magnetic energy
4835 function twofl_mag_en(w, ixI^L, ixO^L) result(mge)
4836 use mod_global_parameters, only: nw, ndim
4837 integer, intent(in) :: ixI^L, ixO^L
4838 double precision, intent(in) :: w(ixI^S, nw)
4839 double precision :: mge(ixO^S)
4840
4841 mge(ixo^s) = 0.5d0 * sum(w(ixo^s, mag(:))**2, dim=ndim+1)
4842 end function twofl_mag_en
4843
4844 !> compute kinetic energy of neutrals
4845 function twofl_kin_en_n(w, ixI^L, ixO^L) result(ke)
4846 use mod_global_parameters, only: nw, ndim,block
4847 integer, intent(in) :: ixI^L, ixO^L
4848 double precision, intent(in) :: w(ixI^S, nw)
4849 double precision :: ke(ixO^S)
4850
4851 if(has_equi_rho_n0) then
4852 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))
4853 else
4854 ke(ixo^s) = 0.5d0 * sum(w(ixo^s, mom_n(:))**2, dim=ndim+1) / w(ixo^s, rho_n_)
4855 endif
4856
4857 end function twofl_kin_en_n
4858
4859 subroutine twofl_get_temp_n_pert_from_etot(w, x, ixI^L, ixO^L, res)
4861 integer, intent(in) :: ixI^L, ixO^L
4862 double precision, intent(in) :: w(ixI^S, 1:nw)
4863 double precision, intent(in) :: x(ixI^S, 1:ndim)
4864 double precision, intent(out):: res(ixI^S)
4865
4866 ! store pe1 in res
4867 res(ixo^s)=(gamma_1*(w(ixo^s,e_c_)- twofl_kin_en_c(w,ixi^l,ixo^l)))
4868 if(has_equi_pe_n0) then
4869 res(ixo^s) = res(ixo^s) + block%equi_vars(ixo^s,equi_pe_n0_,b0i)
4870 if(has_equi_rho_n0) then
4871 res(ixo^s) = res(ixo^s)/(rn * (w(ixo^s,rho_n_)+ block%equi_vars(ixo^s,equi_rho_n0_,b0i))) - &
4872 block%equi_vars(ixo^s,equi_pe_n0_,b0i)/(rn * block%equi_vars(ixo^s,equi_rho_n0_,b0i))
4873 else
4874 ! infinite equi temperature with p0 and 0 density
4875 res(ixo^s) = 0d0
4876 endif
4877 else
4878 res(ixo^s) = res(ixo^s)/(rn * w(ixo^s,rho_n_))
4879 endif
4880
4881 end subroutine twofl_get_temp_n_pert_from_etot
4882
4883 !> compute kinetic energy of charges
4884 !> w are conserved variables
4885 function twofl_kin_en_c(w, ixI^L, ixO^L) result(ke)
4886 use mod_global_parameters, only: nw, ndim,block
4887 integer, intent(in) :: ixI^L, ixO^L
4888 double precision, intent(in) :: w(ixI^S, nw)
4889 double precision :: ke(ixO^S)
4890
4891 if(has_equi_rho_c0) then
4892 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))
4893 else
4894 ke(ixo^s) = 0.5d0 * sum(w(ixo^s, mom_c(:))**2, dim=ndim+1) / w(ixo^s, rho_c_)
4895 endif
4896 end function twofl_kin_en_c
4897
4898 subroutine twofl_getv_hall(w,x,ixI^L,ixO^L,vHall)
4900
4901 integer, intent(in) :: ixI^L, ixO^L
4902 double precision, intent(in) :: w(ixI^S,nw)
4903 double precision, intent(in) :: x(ixI^S,1:ndim)
4904 double precision, intent(inout) :: vHall(ixI^S,1:3)
4905
4906 integer :: idir, idirmin
4907 double precision :: current(ixI^S,7-2*ndir:3)
4908 double precision :: rho(ixI^S)
4909
4910 call get_rhoc_tot(w,x,ixi^l,ixo^l,rho)
4911 ! Calculate current density and idirmin
4912 call get_current(w,ixi^l,ixo^l,idirmin,current)
4913 vhall(ixo^s,1:3) = zero
4914 vhall(ixo^s,idirmin:3) = - twofl_etah*current(ixo^s,idirmin:3)
4915 do idir = idirmin, 3
4916 vhall(ixo^s,idir) = vhall(ixo^s,idir)/rho(ixo^s)
4917 end do
4918
4919 end subroutine twofl_getv_hall
4920
4921! the following not used
4922! subroutine twofl_getdt_Hall(w,x,ixI^L,ixO^L,dx^D,dthall)
4923! use mod_global_parameters
4924!
4925! integer, intent(in) :: ixI^L, ixO^L
4926! double precision, intent(in) :: dx^D
4927! double precision, intent(in) :: w(ixI^S,1:nw)
4928! double precision, intent(in) :: x(ixI^S,1:ndim)
4929! double precision, intent(out) :: dthall
4930! !.. local ..
4931! double precision :: dxarr(ndim)
4932! double precision :: bmag(ixI^S)
4933!
4934! dthall=bigdouble
4935!
4936! ! because we have that in cmax now:
4937! return
4938!
4939! ^D&dxarr(^D)=dx^D;
4940!
4941! if (.not. B0field) then
4942! bmag(ixO^S)=sqrt(sum(w(ixO^S,mag(:))**2, dim=ndim+1))
4943! bmag(ixO^S)=sqrt(sum((w(ixO^S,mag(:)) + block%B0(ixO^S,1:ndir,b0i))**2))
4944! end if
4945!
4946! if(slab_uniform) then
4947! dthall=dtdiffpar*minval(dxarr(1:ndim))**2.0d0/(twofl_etah*maxval(bmag(ixO^S)/w(ixO^S,rho_c_)))
4948! else
4949! dthall=dtdiffpar*minval(block%ds(ixO^S,1:ndim))**2.0d0/(twofl_etah*maxval(bmag(ixO^S)/w(ixO^S,rho_c_)))
4950! end if
4951!
4952! end subroutine twofl_getdt_Hall
4953
4954 subroutine twofl_modify_wlr(ixI^L,ixO^L,qt,wLC,wRC,wLp,wRp,s,idir)
4956 use mod_usr_methods
4957 integer, intent(in) :: ixI^L, ixO^L, idir
4958 double precision, intent(in) :: qt
4959 double precision, intent(inout) :: wLC(ixI^S,1:nw), wRC(ixI^S,1:nw)
4960 double precision, intent(inout) :: wLp(ixI^S,1:nw), wRp(ixI^S,1:nw)
4961 type(state) :: s
4962 double precision :: dB(ixI^S), dPsi(ixI^S)
4963
4964 if(stagger_grid) then
4965 wlc(ixo^s,mag(idir))=s%ws(ixo^s,idir)
4966 wrc(ixo^s,mag(idir))=s%ws(ixo^s,idir)
4967 wlp(ixo^s,mag(idir))=s%ws(ixo^s,idir)
4968 wrp(ixo^s,mag(idir))=s%ws(ixo^s,idir)
4969 else
4970 ! Solve the Riemann problem for the linear 2x2 system for normal
4971 ! B-field and GLM_Psi according to Dedner 2002:
4972 ! This implements eq. (42) in Dedner et al. 2002 JcP 175
4973 ! Gives the Riemann solution on the interface
4974 ! for the normal B component and Psi in the GLM-MHD system.
4975 ! 23/04/2013 Oliver Porth
4976 db(ixo^s) = wrp(ixo^s,mag(idir)) - wlp(ixo^s,mag(idir))
4977 dpsi(ixo^s) = wrp(ixo^s,psi_) - wlp(ixo^s,psi_)
4978
4979 wlp(ixo^s,mag(idir)) = 0.5d0 * (wrp(ixo^s,mag(idir)) + wlp(ixo^s,mag(idir))) &
4980 - 0.5d0/cmax_global * dpsi(ixo^s)
4981 wlp(ixo^s,psi_) = 0.5d0 * (wrp(ixo^s,psi_) + wlp(ixo^s,psi_)) &
4982 - 0.5d0*cmax_global * db(ixo^s)
4983
4984 wrp(ixo^s,mag(idir)) = wlp(ixo^s,mag(idir))
4985 wrp(ixo^s,psi_) = wlp(ixo^s,psi_)
4986
4987 if(phys_total_energy) then
4988 wrc(ixo^s,e_c_)=wrc(ixo^s,e_c_)-half*wrc(ixo^s,mag(idir))**2
4989 wlc(ixo^s,e_c_)=wlc(ixo^s,e_c_)-half*wlc(ixo^s,mag(idir))**2
4990 end if
4991 wrc(ixo^s,mag(idir)) = wlp(ixo^s,mag(idir))
4992 wrc(ixo^s,psi_) = wlp(ixo^s,psi_)
4993 wlc(ixo^s,mag(idir)) = wlp(ixo^s,mag(idir))
4994 wlc(ixo^s,psi_) = wlp(ixo^s,psi_)
4995 ! modify total energy according to the change of magnetic field
4996 if(phys_total_energy) then
4997 wrc(ixo^s,e_c_)=wrc(ixo^s,e_c_)+half*wrc(ixo^s,mag(idir))**2
4998 wlc(ixo^s,e_c_)=wlc(ixo^s,e_c_)+half*wlc(ixo^s,mag(idir))**2
4999 end if
5000 end if
5001
5002 if(associated(usr_set_wlr)) call usr_set_wlr(ixi^l,ixo^l,qt,wlc,wrc,wlp,wrp,s,idir)
5003
5004 end subroutine twofl_modify_wlr
5005
5006 subroutine twofl_boundary_adjust(igrid,psb)
5008 integer, intent(in) :: igrid
5009 type(state), target :: psb(max_blocks)
5010
5011 integer :: iB, idims, iside, ixO^L, i^D
5012
5013 block=>ps(igrid)
5014 ^d&dxlevel(^d)=rnode(rpdx^d_,igrid);
5015 do idims=1,ndim
5016 ! to avoid using as yet unknown corner info in more than 1D, we
5017 ! fill only interior mesh ranges of the ghost cell ranges at first,
5018 ! and progressively enlarge the ranges to include corners later
5019 do iside=1,2
5020 i^d=kr(^d,idims)*(2*iside-3);
5021 if (neighbor_type(i^d,igrid)/=1) cycle
5022 ib=(idims-1)*2+iside
5023 if(.not.boundary_divbfix(ib)) cycle
5024 if(any(typeboundary(:,ib)==bc_special)) then
5025 ! MF nonlinear force-free B field extrapolation and data driven
5026 ! require normal B of the first ghost cell layer to be untouched by
5027 ! fixdivB=0 process, set boundary_divbfix_skip(iB)=1 in par file
5028 select case (idims)
5029 {case (^d)
5030 if (iside==2) then
5031 ! maximal boundary
5032 ixomin^dd=ixghi^d+1-nghostcells+boundary_divbfix_skip(2*^d)^d%ixOmin^dd=ixglo^dd;
5033 ixomax^dd=ixghi^dd;
5034 else
5035 ! minimal boundary
5036 ixomin^dd=ixglo^dd;
5037 ixomax^dd=ixglo^d-1+nghostcells-boundary_divbfix_skip(2*^d-1)^d%ixOmax^dd=ixghi^dd;
5038 end if \}
5039 end select
5040 call fixdivb_boundary(ixg^ll,ixo^l,psb(igrid)%w,psb(igrid)%x,ib)
5041 end if
5042 end do
5043 end do
5044
5045 end subroutine twofl_boundary_adjust
5046
5047 subroutine fixdivb_boundary(ixG^L,ixO^L,w,x,iB)
5049
5050 integer, intent(in) :: ixG^L,ixO^L,iB
5051 double precision, intent(inout) :: w(ixG^S,1:nw)
5052 double precision, intent(in) :: x(ixG^S,1:ndim)
5053
5054 double precision :: dx1x2,dx1x3,dx2x1,dx2x3,dx3x1,dx3x2
5055 integer :: ix^D,ixF^L
5056
5057 select case(ib)
5058 case(1)
5059 ! 2nd order CD for divB=0 to set normal B component better
5060 {^iftwod
5061 ixfmin1=ixomin1+1
5062 ixfmax1=ixomax1+1
5063 ixfmin2=ixomin2+1
5064 ixfmax2=ixomax2-1
5065 if(slab_uniform) then
5066 dx1x2=dxlevel(1)/dxlevel(2)
5067 do ix1=ixfmax1,ixfmin1,-1
5068 w(ix1-1,ixfmin2:ixfmax2,mag(1))=w(ix1+1,ixfmin2:ixfmax2,mag(1)) &
5069 +dx1x2*(w(ix1,ixfmin2+1:ixfmax2+1,mag(2))-&
5070 w(ix1,ixfmin2-1:ixfmax2-1,mag(2)))
5071 enddo
5072 else
5073 do ix1=ixfmax1,ixfmin1,-1
5074 w(ix1-1,ixfmin2:ixfmax2,mag(1))=( (w(ix1+1,ixfmin2:ixfmax2,mag(1))+&
5075 w(ix1,ixfmin2:ixfmax2,mag(1)))*block%surfaceC(ix1,ixfmin2:ixfmax2,1)&
5076 +(w(ix1,ixfmin2+1:ixfmax2+1,mag(2))+w(ix1,ixfmin2:ixfmax2,mag(2)))*&
5077 block%surfaceC(ix1,ixfmin2:ixfmax2,2)&
5078 -(w(ix1,ixfmin2:ixfmax2,mag(2))+w(ix1,ixfmin2-1:ixfmax2-1,mag(2)))*&
5079 block%surfaceC(ix1,ixfmin2-1:ixfmax2-1,2) )&
5080 /block%surfaceC(ix1-1,ixfmin2:ixfmax2,1)-w(ix1,ixfmin2:ixfmax2,mag(1))
5081 end do
5082 end if
5083 }
5084 {^ifthreed
5085 ixfmin1=ixomin1+1
5086 ixfmax1=ixomax1+1
5087 ixfmin2=ixomin2+1
5088 ixfmax2=ixomax2-1
5089 ixfmin3=ixomin3+1
5090 ixfmax3=ixomax3-1
5091 if(slab_uniform) then
5092 dx1x2=dxlevel(1)/dxlevel(2)
5093 dx1x3=dxlevel(1)/dxlevel(3)
5094 do ix1=ixfmax1,ixfmin1,-1
5095 w(ix1-1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))=&
5096 w(ix1+1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1)) &
5097 +dx1x2*(w(ix1,ixfmin2+1:ixfmax2+1,ixfmin3:ixfmax3,mag(2))-&
5098 w(ix1,ixfmin2-1:ixfmax2-1,ixfmin3:ixfmax3,mag(2))) &
5099 +dx1x3*(w(ix1,ixfmin2:ixfmax2,ixfmin3+1:ixfmax3+1,mag(3))-&
5100 w(ix1,ixfmin2:ixfmax2,ixfmin3-1:ixfmax3-1,mag(3)))
5101 end do
5102 else
5103 do ix1=ixfmax1,ixfmin1,-1
5104 w(ix1-1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))=&
5105 ( (w(ix1+1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))+&
5106 w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1)))*&
5107 block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,1)&
5108 +(w(ix1,ixfmin2+1:ixfmax2+1,ixfmin3:ixfmax3,mag(2))+&
5109 w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(2)))*&
5110 block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,2)&
5111 -(w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(2))+&
5112 w(ix1,ixfmin2-1:ixfmax2-1,ixfmin3:ixfmax3,mag(2)))*&
5113 block%surfaceC(ix1,ixfmin2-1:ixfmax2-1,ixfmin3:ixfmax3,2)&
5114 +(w(ix1,ixfmin2:ixfmax2,ixfmin3+1:ixfmax3+1,mag(3))+&
5115 w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(3)))*&
5116 block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,3)&
5117 -(w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(3))+&
5118 w(ix1,ixfmin2:ixfmax2,ixfmin3-1:ixfmax3-1,mag(3)))*&
5119 block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3-1:ixfmax3-1,3) )&
5120 /block%surfaceC(ix1-1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,1)-&
5121 w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))
5122 end do
5123 end if
5124 }
5125 case(2)
5126 {^iftwod
5127 ixfmin1=ixomin1-1
5128 ixfmax1=ixomax1-1
5129 ixfmin2=ixomin2+1
5130 ixfmax2=ixomax2-1
5131 if(slab_uniform) then
5132 dx1x2=dxlevel(1)/dxlevel(2)
5133 do ix1=ixfmin1,ixfmax1
5134 w(ix1+1,ixfmin2:ixfmax2,mag(1))=w(ix1-1,ixfmin2:ixfmax2,mag(1)) &
5135 -dx1x2*(w(ix1,ixfmin2+1:ixfmax2+1,mag(2))-&
5136 w(ix1,ixfmin2-1:ixfmax2-1,mag(2)))
5137 enddo
5138 else
5139 do ix1=ixfmin1,ixfmax1
5140 w(ix1+1,ixfmin2:ixfmax2,mag(1))=( (w(ix1-1,ixfmin2:ixfmax2,mag(1))+&
5141 w(ix1,ixfmin2:ixfmax2,mag(1)))*block%surfaceC(ix1-1,ixfmin2:ixfmax2,1)&
5142 -(w(ix1,ixfmin2+1:ixfmax2+1,mag(2))+w(ix1,ixfmin2:ixfmax2,mag(2)))*&
5143 block%surfaceC(ix1,ixfmin2:ixfmax2,2)&
5144 +(w(ix1,ixfmin2:ixfmax2,mag(2))+w(ix1,ixfmin2-1:ixfmax2-1,mag(2)))*&
5145 block%surfaceC(ix1,ixfmin2-1:ixfmax2-1,2) )&
5146 /block%surfaceC(ix1,ixfmin2:ixfmax2,1)-w(ix1,ixfmin2:ixfmax2,mag(1))
5147 end do
5148 end if
5149 }
5150 {^ifthreed
5151 ixfmin1=ixomin1-1
5152 ixfmax1=ixomax1-1
5153 ixfmin2=ixomin2+1
5154 ixfmax2=ixomax2-1
5155 ixfmin3=ixomin3+1
5156 ixfmax3=ixomax3-1
5157 if(slab_uniform) then
5158 dx1x2=dxlevel(1)/dxlevel(2)
5159 dx1x3=dxlevel(1)/dxlevel(3)
5160 do ix1=ixfmin1,ixfmax1
5161 w(ix1+1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))=&
5162 w(ix1-1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1)) &
5163 -dx1x2*(w(ix1,ixfmin2+1:ixfmax2+1,ixfmin3:ixfmax3,mag(2))-&
5164 w(ix1,ixfmin2-1:ixfmax2-1,ixfmin3:ixfmax3,mag(2))) &
5165 -dx1x3*(w(ix1,ixfmin2:ixfmax2,ixfmin3+1:ixfmax3+1,mag(3))-&
5166 w(ix1,ixfmin2:ixfmax2,ixfmin3-1:ixfmax3-1,mag(3)))
5167 end do
5168 else
5169 do ix1=ixfmin1,ixfmax1
5170 w(ix1+1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))=&
5171 ( (w(ix1-1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))+&
5172 w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1)))*&
5173 block%surfaceC(ix1-1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,1)&
5174 -(w(ix1,ixfmin2+1:ixfmax2+1,ixfmin3:ixfmax3,mag(2))+&
5175 w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(2)))*&
5176 block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,2)&
5177 +(w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(2))+&
5178 w(ix1,ixfmin2-1:ixfmax2-1,ixfmin3:ixfmax3,mag(2)))*&
5179 block%surfaceC(ix1,ixfmin2-1:ixfmax2-1,ixfmin3:ixfmax3,2)&
5180 -(w(ix1,ixfmin2:ixfmax2,ixfmin3+1:ixfmax3+1,mag(3))+&
5181 w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(3)))*&
5182 block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,3)&
5183 +(w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(3))+&
5184 w(ix1,ixfmin2:ixfmax2,ixfmin3-1:ixfmax3-1,mag(3)))*&
5185 block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3-1:ixfmax3-1,3) )&
5186 /block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,1)-&
5187 w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))
5188 end do
5189 end if
5190 }
5191 case(3)
5192 {^iftwod
5193 ixfmin1=ixomin1+1
5194 ixfmax1=ixomax1-1
5195 ixfmin2=ixomin2+1
5196 ixfmax2=ixomax2+1
5197 if(slab_uniform) then
5198 dx2x1=dxlevel(2)/dxlevel(1)
5199 do ix2=ixfmax2,ixfmin2,-1
5200 w(ixfmin1:ixfmax1,ix2-1,mag(2))=w(ixfmin1:ixfmax1,ix2+1,mag(2)) &
5201 +dx2x1*(w(ixfmin1+1:ixfmax1+1,ix2,mag(1))-&
5202 w(ixfmin1-1:ixfmax1-1,ix2,mag(1)))
5203 enddo
5204 else
5205 do ix2=ixfmax2,ixfmin2,-1
5206 w(ixfmin1:ixfmax1,ix2-1,mag(2))=( (w(ixfmin1:ixfmax1,ix2+1,mag(2))+&
5207 w(ixfmin1:ixfmax1,ix2,mag(2)))*block%surfaceC(ixfmin1:ixfmax1,ix2,2)&
5208 +(w(ixfmin1+1:ixfmax1+1,ix2,mag(1))+w(ixfmin1:ixfmax1,ix2,mag(1)))*&
5209 block%surfaceC(ixfmin1:ixfmax1,ix2,1)&
5210 -(w(ixfmin1:ixfmax1,ix2,mag(1))+w(ixfmin1-1:ixfmax1-1,ix2,mag(1)))*&
5211 block%surfaceC(ixfmin1-1:ixfmax1-1,ix2,1) )&
5212 /block%surfaceC(ixfmin1:ixfmax1,ix2-1,2)-w(ixfmin1:ixfmax1,ix2,mag(2))
5213 end do
5214 end if
5215 }
5216 {^ifthreed
5217 ixfmin1=ixomin1+1
5218 ixfmax1=ixomax1-1
5219 ixfmin3=ixomin3+1
5220 ixfmax3=ixomax3-1
5221 ixfmin2=ixomin2+1
5222 ixfmax2=ixomax2+1
5223 if(slab_uniform) then
5224 dx2x1=dxlevel(2)/dxlevel(1)
5225 dx2x3=dxlevel(2)/dxlevel(3)
5226 do ix2=ixfmax2,ixfmin2,-1
5227 w(ixfmin1:ixfmax1,ix2-1,ixfmin3:ixfmax3,mag(2))=w(ixfmin1:ixfmax1,&
5228 ix2+1,ixfmin3:ixfmax3,mag(2)) &
5229 +dx2x1*(w(ixfmin1+1:ixfmax1+1,ix2,ixfmin3:ixfmax3,mag(1))-&
5230 w(ixfmin1-1:ixfmax1-1,ix2,ixfmin3:ixfmax3,mag(1))) &
5231 +dx2x3*(w(ixfmin1:ixfmax1,ix2,ixfmin3+1:ixfmax3+1,mag(3))-&
5232 w(ixfmin1:ixfmax1,ix2,ixfmin3-1:ixfmax3-1,mag(3)))
5233 end do
5234 else
5235 do ix2=ixfmax2,ixfmin2,-1
5236 w(ixfmin1:ixfmax1,ix2-1,ixfmin3:ixfmax3,mag(2))=&
5237 ( (w(ixfmin1:ixfmax1,ix2+1,ixfmin3:ixfmax3,mag(2))+&
5238 w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(2)))*&
5239 block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,2)&
5240 +(w(ixfmin1+1:ixfmax1+1,ix2,ixfmin3:ixfmax3,mag(1))+&
5241 w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(1)))*&
5242 block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,1)&
5243 -(w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(1))+&
5244 w(ixfmin1-1:ixfmax1-1,ix2,ixfmin3:ixfmax3,mag(1)))*&
5245 block%surfaceC(ixfmin1-1:ixfmax1-1,ix2,ixfmin3:ixfmax3,1)&
5246 +(w(ixfmin1:ixfmax1,ix2,ixfmin3+1:ixfmax3+1,mag(3))+&
5247 w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(3)))*&
5248 block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,3)&
5249 -(w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(3))+&
5250 w(ixfmin1:ixfmax1,ix2,ixfmin3-1:ixfmax3-1,mag(3)))*&
5251 block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3-1:ixfmax3-1,3) )&
5252 /block%surfaceC(ixfmin1:ixfmax1,ix2-1,ixfmin3:ixfmax3,2)-&
5253 w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(2))
5254 end do
5255 end if
5256 }
5257 case(4)
5258 {^iftwod
5259 ixfmin1=ixomin1+1
5260 ixfmax1=ixomax1-1
5261 ixfmin2=ixomin2-1
5262 ixfmax2=ixomax2-1
5263 if(slab_uniform) then
5264 dx2x1=dxlevel(2)/dxlevel(1)
5265 do ix2=ixfmin2,ixfmax2
5266 w(ixfmin1:ixfmax1,ix2+1,mag(2))=w(ixfmin1:ixfmax1,ix2-1,mag(2)) &
5267 -dx2x1*(w(ixfmin1+1:ixfmax1+1,ix2,mag(1))-&
5268 w(ixfmin1-1:ixfmax1-1,ix2,mag(1)))
5269 end do
5270 else
5271 do ix2=ixfmin2,ixfmax2
5272 w(ixfmin1:ixfmax1,ix2+1,mag(2))=( (w(ixfmin1:ixfmax1,ix2-1,mag(2))+&
5273 w(ixfmin1:ixfmax1,ix2,mag(2)))*block%surfaceC(ixfmin1:ixfmax1,ix2-1,2)&
5274 -(w(ixfmin1+1:ixfmax1+1,ix2,mag(1))+w(ixfmin1:ixfmax1,ix2,mag(1)))*&
5275 block%surfaceC(ixfmin1:ixfmax1,ix2,1)&
5276 +(w(ixfmin1:ixfmax1,ix2,mag(1))+w(ixfmin1-1:ixfmax1-1,ix2,mag(1)))*&
5277 block%surfaceC(ixfmin1-1:ixfmax1-1,ix2,1) )&
5278 /block%surfaceC(ixfmin1:ixfmax1,ix2,2)-w(ixfmin1:ixfmax1,ix2,mag(2))
5279 end do
5280 end if
5281 }
5282 {^ifthreed
5283 ixfmin1=ixomin1+1
5284 ixfmax1=ixomax1-1
5285 ixfmin3=ixomin3+1
5286 ixfmax3=ixomax3-1
5287 ixfmin2=ixomin2-1
5288 ixfmax2=ixomax2-1
5289 if(slab_uniform) then
5290 dx2x1=dxlevel(2)/dxlevel(1)
5291 dx2x3=dxlevel(2)/dxlevel(3)
5292 do ix2=ixfmin2,ixfmax2
5293 w(ixfmin1:ixfmax1,ix2+1,ixfmin3:ixfmax3,mag(2))=w(ixfmin1:ixfmax1,&
5294 ix2-1,ixfmin3:ixfmax3,mag(2)) &
5295 -dx2x1*(w(ixfmin1+1:ixfmax1+1,ix2,ixfmin3:ixfmax3,mag(1))-&
5296 w(ixfmin1-1:ixfmax1-1,ix2,ixfmin3:ixfmax3,mag(1))) &
5297 -dx2x3*(w(ixfmin1:ixfmax1,ix2,ixfmin3+1:ixfmax3+1,mag(3))-&
5298 w(ixfmin1:ixfmax1,ix2,ixfmin3-1:ixfmax3-1,mag(3)))
5299 end do
5300 else
5301 do ix2=ixfmin2,ixfmax2
5302 w(ixfmin1:ixfmax1,ix2+1,ixfmin3:ixfmax3,mag(2))=&
5303 ( (w(ixfmin1:ixfmax1,ix2-1,ixfmin3:ixfmax3,mag(2))+&
5304 w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(2)))*&
5305 block%surfaceC(ixfmin1:ixfmax1,ix2-1,ixfmin3:ixfmax3,2)&
5306 -(w(ixfmin1+1:ixfmax1+1,ix2,ixfmin3:ixfmax3,mag(1))+&
5307 w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(1)))*&
5308 block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,1)&
5309 +(w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(1))+&
5310 w(ixfmin1-1:ixfmax1-1,ix2,ixfmin3:ixfmax3,mag(1)))*&
5311 block%surfaceC(ixfmin1-1:ixfmax1-1,ix2,ixfmin3:ixfmax3,1)&
5312 -(w(ixfmin1:ixfmax1,ix2,ixfmin3+1:ixfmax3+1,mag(3))+&
5313 w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(3)))*&
5314 block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,3)&
5315 +(w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(3))+&
5316 w(ixfmin1:ixfmax1,ix2,ixfmin3-1:ixfmax3-1,mag(3)))*&
5317 block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3-1:ixfmax3-1,3) )&
5318 /block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,2)-&
5319 w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(2))
5320 end do
5321 end if
5322 }
5323 {^ifthreed
5324 case(5)
5325 ixfmin1=ixomin1+1
5326 ixfmax1=ixomax1-1
5327 ixfmin2=ixomin2+1
5328 ixfmax2=ixomax2-1
5329 ixfmin3=ixomin3+1
5330 ixfmax3=ixomax3+1
5331 if(slab_uniform) then
5332 dx3x1=dxlevel(3)/dxlevel(1)
5333 dx3x2=dxlevel(3)/dxlevel(2)
5334 do ix3=ixfmax3,ixfmin3,-1
5335 w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3-1,mag(3))=w(ixfmin1:ixfmax1,&
5336 ixfmin2:ixfmax2,ix3+1,mag(3)) &
5337 +dx3x1*(w(ixfmin1+1:ixfmax1+1,ixfmin2:ixfmax2,ix3,mag(1))-&
5338 w(ixfmin1-1:ixfmax1-1,ixfmin2:ixfmax2,ix3,mag(1))) &
5339 +dx3x2*(w(ixfmin1:ixfmax1,ixfmin2+1:ixfmax2+1,ix3,mag(2))-&
5340 w(ixfmin1:ixfmax1,ixfmin2-1:ixfmax2-1,ix3,mag(2)))
5341 end do
5342 else
5343 do ix3=ixfmax3,ixfmin3,-1
5344 w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3-1,mag(3))=&
5345 ( (w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3+1,mag(3))+&
5346 w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(3)))*&
5347 block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,3)&
5348 +(w(ixfmin1+1:ixfmax1+1,ixfmin2:ixfmax2,ix3,mag(1))+&
5349 w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(1)))*&
5350 block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,1)&
5351 -(w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(1))+&
5352 w(ixfmin1-1:ixfmax1-1,ixfmin2:ixfmax2,ix3,mag(1)))*&
5353 block%surfaceC(ixfmin1-1:ixfmax1-1,ixfmin2:ixfmax2,ix3,1)&
5354 +(w(ixfmin1:ixfmax1,ixfmin2+1:ixfmax2+1,ix3,mag(2))+&
5355 w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(2)))*&
5356 block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,2)&
5357 -(w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(2))+&
5358 w(ixfmin1:ixfmax1,ixfmin2-1:ixfmax2-1,ix3,mag(2)))*&
5359 block%surfaceC(ixfmin1:ixfmax1,ixfmin2-1:ixfmax2-1,ix3,2) )&
5360 /block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3-1,3)-&
5361 w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(3))
5362 end do
5363 end if
5364 case(6)
5365 ixfmin1=ixomin1+1
5366 ixfmax1=ixomax1-1
5367 ixfmin2=ixomin2+1
5368 ixfmax2=ixomax2-1
5369 ixfmin3=ixomin3-1
5370 ixfmax3=ixomax3-1
5371 if(slab_uniform) then
5372 dx3x1=dxlevel(3)/dxlevel(1)
5373 dx3x2=dxlevel(3)/dxlevel(2)
5374 do ix3=ixfmin3,ixfmax3
5375 w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3+1,mag(3))=w(ixfmin1:ixfmax1,&
5376 ixfmin2:ixfmax2,ix3-1,mag(3)) &
5377 -dx3x1*(w(ixfmin1+1:ixfmax1+1,ixfmin2:ixfmax2,ix3,mag(1))-&
5378 w(ixfmin1-1:ixfmax1-1,ixfmin2:ixfmax2,ix3,mag(1))) &
5379 -dx3x2*(w(ixfmin1:ixfmax1,ixfmin2+1:ixfmax2+1,ix3,mag(2))-&
5380 w(ixfmin1:ixfmax1,ixfmin2-1:ixfmax2-1,ix3,mag(2)))
5381 end do
5382 else
5383 do ix3=ixfmin3,ixfmax3
5384 w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3+1,mag(3))=&
5385 ( (w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3-1,mag(3))+&
5386 w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(3)))*&
5387 block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3-1,3)&
5388 -(w(ixfmin1+1:ixfmax1+1,ixfmin2:ixfmax2,ix3,mag(1))+&
5389 w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(1)))*&
5390 block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,1)&
5391 +(w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(1))+&
5392 w(ixfmin1-1:ixfmax1-1,ixfmin2:ixfmax2,ix3,mag(1)))*&
5393 block%surfaceC(ixfmin1-1:ixfmax1-1,ixfmin2:ixfmax2,ix3,1)&
5394 -(w(ixfmin1:ixfmax1,ixfmin2+1:ixfmax2+1,ix3,mag(2))+&
5395 w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(2)))*&
5396 block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,2)&
5397 +(w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(2))+&
5398 w(ixfmin1:ixfmax1,ixfmin2-1:ixfmax2-1,ix3,mag(2)))*&
5399 block%surfaceC(ixfmin1:ixfmax1,ixfmin2-1:ixfmax2-1,ix3,2) )&
5400 /block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,3)-&
5401 w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(3))
5402 end do
5403 end if
5404 }
5405 case default
5406 call mpistop("Special boundary is not defined for this region")
5407 end select
5408
5409 end subroutine fixdivb_boundary
5410
5411 {^nooned
5412 subroutine twofl_clean_divb_multigrid(qdt, qt, active)
5413 use mod_forest
5416 use mod_geometry
5417
5418 double precision, intent(in) :: qdt !< Current time step
5419 double precision, intent(in) :: qt !< Current time
5420 logical, intent(inout) :: active !< Output if the source is active
5421 integer :: iigrid, igrid, id
5422 integer :: n, nc, lvl, ix^l, ixc^l, idim
5423 type(tree_node), pointer :: pnode
5424 double precision :: tmp(ixg^t), grad(ixg^t, ndim)
5425 double precision :: res
5426 double precision, parameter :: max_residual = 1d-3
5427 double precision, parameter :: residual_reduction = 1d-10
5428 integer, parameter :: max_its = 50
5429 double precision :: residual_it(max_its), max_divb
5430
5431 mg%operator_type = mg_laplacian
5432
5433 ! Set boundary conditions
5434 do n = 1, 2*ndim
5435 idim = (n+1)/2
5436 select case (typeboundary(mag(idim), n))
5437 case (bc_symm)
5438 ! d/dx B = 0, take phi = 0
5439 mg%bc(n, mg_iphi)%bc_type = mg_bc_dirichlet
5440 mg%bc(n, mg_iphi)%bc_value = 0.0_dp
5441 case (bc_asymm)
5442 ! B = 0, so grad(phi) = 0
5443 mg%bc(n, mg_iphi)%bc_type = mg_bc_neumann
5444 mg%bc(n, mg_iphi)%bc_value = 0.0_dp
5445 case (bc_cont)
5446 mg%bc(n, mg_iphi)%bc_type = mg_bc_dirichlet
5447 mg%bc(n, mg_iphi)%bc_value = 0.0_dp
5448 case (bc_special)
5449 ! Assume Dirichlet boundary conditions, derivative zero
5450 mg%bc(n, mg_iphi)%bc_type = mg_bc_dirichlet
5451 mg%bc(n, mg_iphi)%bc_value = 0.0_dp
5452 case (bc_periodic)
5453 ! Nothing to do here
5454 case default
5455 print *, "divb_multigrid warning: unknown b.c.: ", &
5456 typeboundary(mag(idim), n)
5457 mg%bc(n, mg_iphi)%bc_type = mg_bc_dirichlet
5458 mg%bc(n, mg_iphi)%bc_value = 0.0_dp
5459 end select
5460 end do
5461
5462 ix^l=ixm^ll^ladd1;
5463 max_divb = 0.0d0
5464
5465 ! Store divergence of B as right-hand side
5466 do iigrid = 1, igridstail
5467 igrid = igrids(iigrid);
5468 pnode => igrid_to_node(igrid, mype)%node
5469 id = pnode%id
5470 lvl = mg%boxes(id)%lvl
5471 nc = mg%box_size_lvl(lvl)
5472
5473 ! Geometry subroutines expect this to be set
5474 block => ps(igrid)
5475 ^d&dxlevel(^d)=rnode(rpdx^d_,igrid);
5476
5477 call get_divb(ps(igrid)%w(ixg^t, 1:nw), ixg^ll, ixm^ll, tmp, &
5479 mg%boxes(id)%cc({1:nc}, mg_irhs) = tmp(ixm^t)
5480 max_divb = max(max_divb, maxval(abs(tmp(ixm^t))))
5481 end do
5482
5483 ! Solve laplacian(phi) = divB
5484 if(stagger_grid) then
5485 call mpi_allreduce(mpi_in_place, max_divb, 1, mpi_double_precision, &
5486 mpi_max, icomm, ierrmpi)
5487
5488 if (mype == 0) print *, "Performing multigrid divB cleaning"
5489 if (mype == 0) print *, "iteration vs residual"
5490 ! Solve laplacian(phi) = divB
5491 do n = 1, max_its
5492 call mg_fas_fmg(mg, n>1, max_res=residual_it(n))
5493 if (mype == 0) write(*, "(I4,E11.3)") n, residual_it(n)
5494 if (residual_it(n) < residual_reduction * max_divb) exit
5495 end do
5496 if (mype == 0 .and. n > max_its) then
5497 print *, "divb_multigrid warning: not fully converged"
5498 print *, "current amplitude of divb: ", residual_it(max_its)
5499 print *, "multigrid smallest grid: ", &
5500 mg%domain_size_lvl(:, mg%lowest_lvl)
5501 print *, "note: smallest grid ideally has <= 8 cells"
5502 print *, "multigrid dx/dy/dz ratio: ", mg%dr(:, 1)/mg%dr(1, 1)
5503 print *, "note: dx/dy/dz should be similar"
5504 end if
5505 else
5506 do n = 1, max_its
5507 call mg_fas_vcycle(mg, max_res=res)
5508 if (res < max_residual) exit
5509 end do
5510 if (res > max_residual) call mpistop("divb_multigrid: no convergence")
5511 end if
5512
5513
5514 ! Correct the magnetic field
5515 do iigrid = 1, igridstail
5516 igrid = igrids(iigrid);
5517 pnode => igrid_to_node(igrid, mype)%node
5518 id = pnode%id
5519
5520 ! Geometry subroutines expect this to be set
5521 block => ps(igrid)
5522 ^d&dxlevel(^d)=rnode(rpdx^d_,igrid);
5523
5524 ! Compute the gradient of phi
5525 tmp(ix^s) = mg%boxes(id)%cc({:,}, mg_iphi)
5526
5527 if(stagger_grid) then
5528 do idim =1, ndim
5529 ixcmin^d=ixmlo^d-kr(idim,^d);
5530 ixcmax^d=ixmhi^d;
5531 call gradientf(tmp,ps(igrid)%x,ixg^ll,ixc^l,idim,grad(ixg^t,idim))
5532 ! Apply the correction B* = B - gradient(phi)
5533 ps(igrid)%ws(ixc^s,idim)=ps(igrid)%ws(ixc^s,idim)-grad(ixc^s,idim)
5534 end do
5535 ! store cell-center magnetic energy
5536 tmp(ixm^t) = sum(ps(igrid)%w(ixm^t, mag(1:ndim))**2, dim=ndim+1)
5537 ! change cell-center magnetic field
5538 call twofl_face_to_center(ixm^ll,ps(igrid))
5539 else
5540 do idim = 1, ndim
5541 call gradient(tmp,ixg^ll,ixm^ll,idim,grad(ixg^t, idim))
5542 end do
5543 ! store cell-center magnetic energy
5544 tmp(ixm^t) = sum(ps(igrid)%w(ixm^t, mag(1:ndim))**2, dim=ndim+1)
5545 ! Apply the correction B* = B - gradient(phi)
5546 ps(igrid)%w(ixm^t, mag(1:ndim)) = &
5547 ps(igrid)%w(ixm^t, mag(1:ndim)) - grad(ixm^t, :)
5548 end if
5549
5550 if(phys_total_energy) then
5551 ! Determine magnetic energy difference
5552 tmp(ixm^t) = 0.5_dp * (sum(ps(igrid)%w(ixm^t, &
5553 mag(1:ndim))**2, dim=ndim+1) - tmp(ixm^t))
5554 ! Keep thermal pressure the same
5555 ps(igrid)%w(ixm^t, e_c_) = ps(igrid)%w(ixm^t, e_c_) + tmp(ixm^t)
5556 end if
5557 end do
5558
5559 active = .true.
5560
5561 end subroutine twofl_clean_divb_multigrid
5562 }
5563
5564 subroutine twofl_update_faces(ixI^L,ixO^L,qt,qdt,wprim,fC,fE,sCT,s,vcts)
5566
5567 integer, intent(in) :: ixi^l, ixo^l
5568 double precision, intent(in) :: qt,qdt
5569 ! cell-center primitive variables
5570 double precision, intent(in) :: wprim(ixi^s,1:nw)
5571 type(state) :: sct, s
5572 type(ct_velocity) :: vcts
5573 double precision, intent(in) :: fc(ixi^s,1:nwflux,1:ndim)
5574 double precision, intent(inout) :: fe(ixi^s,sdim:3)
5575
5576 select case(type_ct)
5577 case('average')
5578 call update_faces_average(ixi^l,ixo^l,qt,qdt,fc,fe,sct,s)
5579 case('uct_contact')
5580 call update_faces_contact(ixi^l,ixo^l,qt,qdt,wprim,fc,fe,sct,s,vcts)
5581 case('uct_hll')
5582 call update_faces_hll(ixi^l,ixo^l,qt,qdt,fe,sct,s,vcts)
5583 case default
5584 call mpistop('choose average, uct_contact,or uct_hll for type_ct!')
5585 end select
5586
5587 end subroutine twofl_update_faces
5588
5589 !> get electric field though averaging neighors to update faces in CT
5590 subroutine update_faces_average(ixI^L,ixO^L,qt,qdt,fC,fE,sCT,s)
5592 use mod_usr_methods
5593
5594 integer, intent(in) :: ixi^l, ixo^l
5595 double precision, intent(in) :: qt, qdt
5596 type(state) :: sct, s
5597 double precision, intent(in) :: fc(ixi^s,1:nwflux,1:ndim)
5598 double precision, intent(inout) :: fe(ixi^s,sdim:3)
5599
5600 integer :: hxc^l,ixc^l,jxc^l,ixcm^l
5601 integer :: idim1,idim2,idir,iwdim1,iwdim2
5602 double precision :: circ(ixi^s,1:ndim)
5603 ! non-ideal electric field on cell edges
5604 double precision, dimension(ixI^S,sdim:3) :: e_resi
5605
5606 associate(bfaces=>s%ws,x=>s%x)
5607
5608 ! Calculate contribution to FEM of each edge,
5609 ! that is, estimate value of line integral of
5610 ! electric field in the positive idir direction.
5611 ixcmax^d=ixomax^d;
5612 ixcmin^d=ixomin^d-1;
5613
5614 ! if there is resistivity, get eta J
5615 if(twofl_eta/=zero) call get_resistive_electric_field(ixi^l,ixo^l,sct,s,e_resi)
5616
5617 fe=zero
5618
5619 do idim1=1,ndim
5620 iwdim1 = mag(idim1)
5621 do idim2=1,ndim
5622 iwdim2 = mag(idim2)
5623 do idir=sdim,3! Direction of line integral
5624 ! Allow only even permutations
5625 if (lvc(idim1,idim2,idir)==1) then
5626 ! Assemble indices
5627 jxc^l=ixc^l+kr(idim1,^d);
5628 hxc^l=ixc^l+kr(idim2,^d);
5629 ! Interpolate to edges
5630 fe(ixc^s,idir)=quarter*(fc(ixc^s,iwdim1,idim2)+fc(jxc^s,iwdim1,idim2)&
5631 -fc(ixc^s,iwdim2,idim1)-fc(hxc^s,iwdim2,idim1))
5632
5633 ! add resistive electric field at cell edges E=-vxB+eta J
5634 if(twofl_eta/=zero) fe(ixc^s,idir)=fe(ixc^s,idir)+e_resi(ixc^s,idir)
5635 fe(ixc^s,idir)=qdt*s%dsC(ixc^s,idir)*fe(ixc^s,idir)
5636
5637 if (.not.slab) then
5638 where(abs(x(ixc^s,r_)+half*dxlevel(r_))<1.0d-9)
5639 fe(ixc^s,idir)=zero
5640 end where
5641 end if
5642 end if
5643 end do
5644 end do
5645 end do
5646
5647 ! allow user to change inductive electric field, especially for boundary driven applications
5648 if(associated(usr_set_electric_field)) &
5649 call usr_set_electric_field(ixi^l,ixo^l,qt,qdt,fe,sct)
5650
5651 circ(ixi^s,1:ndim)=zero
5652
5653 ! Calculate circulation on each face
5654
5655 do idim1=1,ndim ! Coordinate perpendicular to face
5656 do idim2=1,ndim
5657 do idir=sdim,3 ! Direction of line integral
5658 ! Assemble indices
5659 hxc^l=ixc^l-kr(idim2,^d);
5660 ! Add line integrals in direction idir
5661 circ(ixc^s,idim1)=circ(ixc^s,idim1)&
5662 +lvc(idim1,idim2,idir)&
5663 *(fe(ixc^s,idir)&
5664 -fe(hxc^s,idir))
5665 end do
5666 end do
5667 end do
5668
5669 ! Divide by the area of the face to get dB/dt
5670 do idim1=1,ndim
5671 ixcmax^d=ixomax^d;
5672 ixcmin^d=ixomin^d-kr(idim1,^d);
5673 where(s%surfaceC(ixc^s,idim1) > 1.0d-9*s%dvolume(ixc^s))
5674 circ(ixc^s,idim1)=circ(ixc^s,idim1)/s%surfaceC(ixc^s,idim1)
5675 elsewhere
5676 circ(ixc^s,idim1)=zero
5677 end where
5678 ! Time update
5679 bfaces(ixc^s,idim1)=bfaces(ixc^s,idim1)-circ(ixc^s,idim1)
5680 end do
5681
5682 end associate
5683
5684 end subroutine update_faces_average
5685
5686 !> update faces using UCT contact mode by Gardiner and Stone 2005 JCP 205, 509
5687 subroutine update_faces_contact(ixI^L,ixO^L,qt,qdt,wp,fC,fE,sCT,s,vcts)
5689 use mod_usr_methods
5690
5691 integer, intent(in) :: ixi^l, ixo^l
5692 double precision, intent(in) :: qt, qdt
5693 ! cell-center primitive variables
5694 double precision, intent(in) :: wp(ixi^s,1:nw)
5695 type(state) :: sct, s
5696 type(ct_velocity) :: vcts
5697 double precision, intent(in) :: fc(ixi^s,1:nwflux,1:ndim)
5698 double precision, intent(inout) :: fe(ixi^s,sdim:3)
5699
5700 double precision :: circ(ixi^s,1:ndim)
5701 ! electric field at cell centers
5702 double precision :: ecc(ixi^s,sdim:3)
5703 ! gradient of E at left and right side of a cell face
5704 double precision :: el(ixi^s),er(ixi^s)
5705 ! gradient of E at left and right side of a cell corner
5706 double precision :: elc(ixi^s),erc(ixi^s)
5707 ! non-ideal electric field on cell edges
5708 double precision, dimension(ixI^S,sdim:3) :: e_resi, e_ambi
5709 ! total magnetic field at cell centers
5710 double precision :: btot(ixi^s,1:ndim)
5711 integer :: hxc^l,ixc^l,jxc^l,ixa^l,ixb^l
5712 integer :: idim1,idim2,idir,iwdim1,iwdim2
5713
5714 associate(bfaces=>s%ws,x=>s%x,w=>s%w,vnorm=>vcts%vnorm)
5715
5716 if(b0field) then
5717 btot(ixi^s,1:ndim)=wp(ixi^s,mag(1:ndim))+block%B0(ixi^s,1:ndim,0)
5718 else
5719 btot(ixi^s,1:ndim)=wp(ixi^s,mag(1:ndim))
5720 end if
5721 ecc=0.d0
5722 ! Calculate electric field at cell centers
5723 do idim1=1,ndim; do idim2=1,ndim; do idir=sdim,3
5724 if(lvc(idim1,idim2,idir)==1)then
5725 ecc(ixi^s,idir)=ecc(ixi^s,idir)+btot(ixi^s,idim1)*wp(ixi^s,mom_c(idim2))
5726 else if(lvc(idim1,idim2,idir)==-1) then
5727 ecc(ixi^s,idir)=ecc(ixi^s,idir)-btot(ixi^s,idim1)*wp(ixi^s,mom_c(idim2))
5728 endif
5729 enddo; enddo; enddo
5730
5731 ! if there is resistivity, get eta J
5732 if(twofl_eta/=zero) call get_resistive_electric_field(ixi^l,ixo^l,sct,s,e_resi)
5733 ! Calculate contribution to FEM of each edge,
5734 ! that is, estimate value of line integral of
5735 ! electric field in the positive idir direction.
5736 fe=zero
5737 ! evaluate electric field along cell edges according to equation (41)
5738 do idim1=1,ndim
5739 iwdim1 = mag(idim1)
5740 do idim2=1,ndim
5741 iwdim2 = mag(idim2)
5742 do idir=sdim,3 ! Direction of line integral
5743 ! Allow only even permutations
5744 if (lvc(idim1,idim2,idir)==1) then
5745 ixcmax^d=ixomax^d;
5746 ixcmin^d=ixomin^d+kr(idir,^d)-1;
5747 ! Assemble indices
5748 jxc^l=ixc^l+kr(idim1,^d);
5749 hxc^l=ixc^l+kr(idim2,^d);
5750 ! average cell-face electric field to cell edges
5751 fe(ixc^s,idir)=quarter*&
5752 (fc(ixc^s,iwdim1,idim2)+fc(jxc^s,iwdim1,idim2)&
5753 -fc(ixc^s,iwdim2,idim1)-fc(hxc^s,iwdim2,idim1))
5754
5755 ! add slope in idim2 direction from equation (50)
5756 ixamin^d=ixcmin^d;
5757 ixamax^d=ixcmax^d+kr(idim1,^d);
5758 el(ixa^s)=fc(ixa^s,iwdim1,idim2)-ecc(ixa^s,idir)
5759 hxc^l=ixa^l+kr(idim2,^d);
5760 er(ixa^s)=fc(ixa^s,iwdim1,idim2)-ecc(hxc^s,idir)
5761 where(vnorm(ixc^s,idim1)>0.d0)
5762 elc(ixc^s)=el(ixc^s)
5763 else where(vnorm(ixc^s,idim1)<0.d0)
5764 elc(ixc^s)=el(jxc^s)
5765 else where
5766 elc(ixc^s)=0.5d0*(el(ixc^s)+el(jxc^s))
5767 end where
5768 hxc^l=ixc^l+kr(idim2,^d);
5769 where(vnorm(hxc^s,idim1)>0.d0)
5770 erc(ixc^s)=er(ixc^s)
5771 else where(vnorm(hxc^s,idim1)<0.d0)
5772 erc(ixc^s)=er(jxc^s)
5773 else where
5774 erc(ixc^s)=0.5d0*(er(ixc^s)+er(jxc^s))
5775 end where
5776 fe(ixc^s,idir)=fe(ixc^s,idir)+0.25d0*(elc(ixc^s)+erc(ixc^s))
5777
5778 ! add slope in idim1 direction from equation (50)
5779 jxc^l=ixc^l+kr(idim2,^d);
5780 ixamin^d=ixcmin^d;
5781 ixamax^d=ixcmax^d+kr(idim2,^d);
5782 el(ixa^s)=-fc(ixa^s,iwdim2,idim1)-ecc(ixa^s,idir)
5783 hxc^l=ixa^l+kr(idim1,^d);
5784 er(ixa^s)=-fc(ixa^s,iwdim2,idim1)-ecc(hxc^s,idir)
5785 where(vnorm(ixc^s,idim2)>0.d0)
5786 elc(ixc^s)=el(ixc^s)
5787 else where(vnorm(ixc^s,idim2)<0.d0)
5788 elc(ixc^s)=el(jxc^s)
5789 else where
5790 elc(ixc^s)=0.5d0*(el(ixc^s)+el(jxc^s))
5791 end where
5792 hxc^l=ixc^l+kr(idim1,^d);
5793 where(vnorm(hxc^s,idim2)>0.d0)
5794 erc(ixc^s)=er(ixc^s)
5795 else where(vnorm(hxc^s,idim2)<0.d0)
5796 erc(ixc^s)=er(jxc^s)
5797 else where
5798 erc(ixc^s)=0.5d0*(er(ixc^s)+er(jxc^s))
5799 end where
5800 fe(ixc^s,idir)=fe(ixc^s,idir)+0.25d0*(elc(ixc^s)+erc(ixc^s))
5801
5802 ! add current component of electric field at cell edges E=-vxB+eta J
5803 if(twofl_eta/=zero) fe(ixc^s,idir)=fe(ixc^s,idir)+e_resi(ixc^s,idir)
5804 ! times time step and edge length
5805 fe(ixc^s,idir)=fe(ixc^s,idir)*qdt*s%dsC(ixc^s,idir)
5806 if (.not.slab) then
5807 where(abs(x(ixc^s,r_)+half*dxlevel(r_))<1.0d-9)
5808 fe(ixc^s,idir)=zero
5809 end where
5810 end if
5811 end if
5812 end do
5813 end do
5814 end do
5815
5816 ! allow user to change inductive electric field, especially for boundary driven applications
5817 if(associated(usr_set_electric_field)) &
5818 call usr_set_electric_field(ixi^l,ixo^l,qt,qdt,fe,sct)
5819
5820 circ(ixi^s,1:ndim)=zero
5821
5822 ! Calculate circulation on each face
5823 do idim1=1,ndim ! Coordinate perpendicular to face
5824 ixcmax^d=ixomax^d;
5825 ixcmin^d=ixomin^d-kr(idim1,^d);
5826 do idim2=1,ndim
5827 do idir=sdim,3 ! Direction of line integral
5828 ! Assemble indices
5829 hxc^l=ixc^l-kr(idim2,^d);
5830 ! Add line integrals in direction idir
5831 circ(ixc^s,idim1)=circ(ixc^s,idim1)&
5832 +lvc(idim1,idim2,idir)&
5833 *(fe(ixc^s,idir)&
5834 -fe(hxc^s,idir))
5835 end do
5836 end do
5837 ! Divide by the area of the face to get dB/dt
5838 ixcmax^d=ixomax^d;
5839 ixcmin^d=ixomin^d-kr(idim1,^d);
5840 where(s%surfaceC(ixc^s,idim1) > 1.0d-9*s%dvolume(ixc^s))
5841 circ(ixc^s,idim1)=circ(ixc^s,idim1)/s%surfaceC(ixc^s,idim1)
5842 elsewhere
5843 circ(ixc^s,idim1)=zero
5844 end where
5845 ! Time update cell-face magnetic field component
5846 bfaces(ixc^s,idim1)=bfaces(ixc^s,idim1)-circ(ixc^s,idim1)
5847 end do
5848
5849 end associate
5850
5851 end subroutine update_faces_contact
5852
5853 !> update faces
5854 subroutine update_faces_hll(ixI^L,ixO^L,qt,qdt,fE,sCT,s,vcts)
5857 use mod_usr_methods
5858
5859 integer, intent(in) :: ixi^l, ixo^l
5860 double precision, intent(in) :: qt, qdt
5861 double precision, intent(inout) :: fe(ixi^s,sdim:3)
5862 type(state) :: sct, s
5863 type(ct_velocity) :: vcts
5864
5865 double precision :: vtill(ixi^s,2)
5866 double precision :: vtilr(ixi^s,2)
5867 double precision :: bfacetot(ixi^s,ndim)
5868 double precision :: btill(s%ixgs^s,ndim)
5869 double precision :: btilr(s%ixgs^s,ndim)
5870 double precision :: cp(ixi^s,2)
5871 double precision :: cm(ixi^s,2)
5872 double precision :: circ(ixi^s,1:ndim)
5873 ! non-ideal electric field on cell edges
5874 double precision, dimension(ixI^S,sdim:3) :: e_resi, e_ambi
5875 integer :: hxc^l,ixc^l,ixcp^l,jxc^l,ixcm^l
5876 integer :: idim1,idim2,idir
5877
5878 associate(bfaces=>s%ws,bfacesct=>sct%ws,x=>s%x,vbarc=>vcts%vbarC,cbarmin=>vcts%cbarmin,&
5879 cbarmax=>vcts%cbarmax)
5880
5881 ! Calculate contribution to FEM of each edge,
5882 ! that is, estimate value of line integral of
5883 ! electric field in the positive idir direction.
5884
5885 ! Loop over components of electric field
5886
5887 ! idir: electric field component we need to calculate
5888 ! idim1: directions in which we already performed the reconstruction
5889 ! idim2: directions in which we perform the reconstruction
5890
5891 ! if there is resistivity, get eta J
5892 if(twofl_eta/=zero) call get_resistive_electric_field(ixi^l,ixo^l,sct,s,e_resi)
5893 fe=zero
5894
5895 do idir=sdim,3
5896 ! Indices
5897 ! idir: electric field component
5898 ! idim1: one surface
5899 ! idim2: the other surface
5900 ! cyclic permutation: idim1,idim2,idir=1,2,3
5901 ! Velocity components on the surface
5902 ! follow cyclic premutations:
5903 ! Sx(1),Sx(2)=y,z ; Sy(1),Sy(2)=z,x ; Sz(1),Sz(2)=x,y
5904
5905 ixcmax^d=ixomax^d;
5906 ixcmin^d=ixomin^d-1+kr(idir,^d);
5907
5908 ! Set indices and directions
5909 idim1=mod(idir,3)+1
5910 idim2=mod(idir+1,3)+1
5911
5912 jxc^l=ixc^l+kr(idim1,^d);
5913 ixcp^l=ixc^l+kr(idim2,^d);
5914
5915 ! Reconstruct transverse transport velocities
5916 call reconstruct(ixi^l,ixc^l,idim2,vbarc(ixi^s,idim1,1),&
5917 vtill(ixi^s,2),vtilr(ixi^s,2))
5918
5919 call reconstruct(ixi^l,ixc^l,idim1,vbarc(ixi^s,idim2,2),&
5920 vtill(ixi^s,1),vtilr(ixi^s,1))
5921
5922 ! Reconstruct magnetic fields
5923 ! Eventhough the arrays are larger, reconstruct works with
5924 ! the limits ixG.
5925 if(b0field) then
5926 bfacetot(ixi^s,idim1)=bfacesct(ixi^s,idim1)+block%B0(ixi^s,idim1,idim1)
5927 bfacetot(ixi^s,idim2)=bfacesct(ixi^s,idim2)+block%B0(ixi^s,idim2,idim2)
5928 else
5929 bfacetot(ixi^s,idim1)=bfacesct(ixi^s,idim1)
5930 bfacetot(ixi^s,idim2)=bfacesct(ixi^s,idim2)
5931 end if
5932 call reconstruct(ixi^l,ixc^l,idim2,bfacetot(ixi^s,idim1),&
5933 btill(ixi^s,idim1),btilr(ixi^s,idim1))
5934
5935 call reconstruct(ixi^l,ixc^l,idim1,bfacetot(ixi^s,idim2),&
5936 btill(ixi^s,idim2),btilr(ixi^s,idim2))
5937
5938 ! Take the maximum characteristic
5939
5940 cm(ixc^s,1)=max(cbarmin(ixcp^s,idim1),cbarmin(ixc^s,idim1))
5941 cp(ixc^s,1)=max(cbarmax(ixcp^s,idim1),cbarmax(ixc^s,idim1))
5942
5943 cm(ixc^s,2)=max(cbarmin(jxc^s,idim2),cbarmin(ixc^s,idim2))
5944 cp(ixc^s,2)=max(cbarmax(jxc^s,idim2),cbarmax(ixc^s,idim2))
5945
5946
5947 ! Calculate eletric field
5948 fe(ixc^s,idir)=-(cp(ixc^s,1)*vtill(ixc^s,1)*btill(ixc^s,idim2) &
5949 + cm(ixc^s,1)*vtilr(ixc^s,1)*btilr(ixc^s,idim2) &
5950 - cp(ixc^s,1)*cm(ixc^s,1)*(btilr(ixc^s,idim2)-btill(ixc^s,idim2)))&
5951 /(cp(ixc^s,1)+cm(ixc^s,1)) &
5952 +(cp(ixc^s,2)*vtill(ixc^s,2)*btill(ixc^s,idim1) &
5953 + cm(ixc^s,2)*vtilr(ixc^s,2)*btilr(ixc^s,idim1) &
5954 - cp(ixc^s,2)*cm(ixc^s,2)*(btilr(ixc^s,idim1)-btill(ixc^s,idim1)))&
5955 /(cp(ixc^s,2)+cm(ixc^s,2))
5956
5957 ! add current component of electric field at cell edges E=-vxB+eta J
5958 if(twofl_eta/=zero) fe(ixc^s,idir)=fe(ixc^s,idir)+e_resi(ixc^s,idir)
5959 fe(ixc^s,idir)=qdt*s%dsC(ixc^s,idir)*fe(ixc^s,idir)
5960
5961 if (.not.slab) then
5962 where(abs(x(ixc^s,r_)+half*dxlevel(r_)).lt.1.0d-9)
5963 fe(ixc^s,idir)=zero
5964 end where
5965 end if
5966
5967 end do
5968
5969 ! allow user to change inductive electric field, especially for boundary driven applications
5970 if(associated(usr_set_electric_field)) &
5971 call usr_set_electric_field(ixi^l,ixo^l,qt,qdt,fe,sct)
5972
5973 circ(ixi^s,1:ndim)=zero
5974
5975 ! Calculate circulation on each face: interal(fE dot dl)
5976
5977 do idim1=1,ndim ! Coordinate perpendicular to face
5978 ixcmax^d=ixomax^d;
5979 ixcmin^d=ixomin^d-kr(idim1,^d);
5980 do idim2=1,ndim
5981 do idir=sdim,3 ! Direction of line integral
5982 ! Assemble indices
5983 hxc^l=ixc^l-kr(idim2,^d);
5984 ! Add line integrals in direction idir
5985 circ(ixc^s,idim1)=circ(ixc^s,idim1)&
5986 +lvc(idim1,idim2,idir)&
5987 *(fe(ixc^s,idir)&
5988 -fe(hxc^s,idir))
5989 end do
5990 end do
5991 end do
5992
5993 ! Divide by the area of the face to get dB/dt
5994 do idim1=1,ndim
5995 ixcmax^d=ixomax^d;
5996 ixcmin^d=ixomin^d-kr(idim1,^d);
5997 where(s%surfaceC(ixc^s,idim1) > 1.0d-9*s%dvolume(ixc^s))
5998 circ(ixc^s,idim1)=circ(ixc^s,idim1)/s%surfaceC(ixc^s,idim1)
5999 elsewhere
6000 circ(ixc^s,idim1)=zero
6001 end where
6002 ! Time update
6003 bfaces(ixc^s,idim1)=bfaces(ixc^s,idim1)-circ(ixc^s,idim1)
6004 end do
6005
6006 end associate
6007 end subroutine update_faces_hll
6008
6009 !> calculate eta J at cell edges
6010 subroutine get_resistive_electric_field(ixI^L,ixO^L,sCT,s,jce)
6012 use mod_usr_methods
6013 use mod_geometry
6014
6015 integer, intent(in) :: ixi^l, ixo^l
6016 type(state), intent(in) :: sct, s
6017 ! current on cell edges
6018 double precision :: jce(ixi^s,sdim:3)
6019
6020 ! current on cell centers
6021 double precision :: jcc(ixi^s,7-2*ndir:3)
6022 ! location at cell faces
6023 double precision :: xs(ixgs^t,1:ndim)
6024 ! resistivity
6025 double precision :: eta(ixi^s)
6026 double precision :: gradi(ixgs^t)
6027 integer :: ix^d,ixc^l,ixa^l,ixb^l,idir,idirmin,idim1,idim2
6028
6029 associate(x=>s%x,dx=>s%dx,w=>s%w,wct=>sct%w,wcts=>sct%ws)
6030 ! calculate current density at cell edges
6031 jce=0.d0
6032 do idim1=1,ndim
6033 do idim2=1,ndim
6034 do idir=sdim,3
6035 if (lvc(idim1,idim2,idir)==0) cycle
6036 ixcmax^d=ixomax^d;
6037 ixcmin^d=ixomin^d+kr(idir,^d)-1;
6038 ixbmax^d=ixcmax^d-kr(idir,^d)+1;
6039 ixbmin^d=ixcmin^d;
6040 ! current at transverse faces
6041 xs(ixb^s,:)=x(ixb^s,:)
6042 xs(ixb^s,idim2)=x(ixb^s,idim2)+half*dx(ixb^s,idim2)
6043 call gradientf(wcts(ixgs^t,idim2),xs,ixgs^ll,ixc^l,idim1,gradi,2)
6044 if (lvc(idim1,idim2,idir)==1) then
6045 jce(ixc^s,idir)=jce(ixc^s,idir)+gradi(ixc^s)
6046 else
6047 jce(ixc^s,idir)=jce(ixc^s,idir)-gradi(ixc^s)
6048 end if
6049 end do
6050 end do
6051 end do
6052 ! get resistivity
6053 if(twofl_eta>zero)then
6054 jce(ixi^s,:)=jce(ixi^s,:)*twofl_eta
6055 else
6056 ixa^l=ixo^l^ladd1;
6057 call get_current(wct,ixi^l,ixa^l,idirmin,jcc)
6058 call usr_special_resistivity(wct,ixi^l,ixa^l,idirmin,x,jcc,eta)
6059 ! calcuate eta on cell edges
6060 do idir=sdim,3
6061 ixcmax^d=ixomax^d;
6062 ixcmin^d=ixomin^d+kr(idir,^d)-1;
6063 jcc(ixc^s,idir)=0.d0
6064 {do ix^db=0,1\}
6065 if({ ix^d==1 .and. ^d==idir | .or.}) cycle
6066 ixamin^d=ixcmin^d+ix^d;
6067 ixamax^d=ixcmax^d+ix^d;
6068 jcc(ixc^s,idir)=jcc(ixc^s,idir)+eta(ixa^s)
6069 {end do\}
6070 jcc(ixc^s,idir)=jcc(ixc^s,idir)*0.25d0
6071 jce(ixc^s,idir)=jce(ixc^s,idir)*jcc(ixc^s,idir)
6072 enddo
6073 end if
6074
6075 end associate
6076 end subroutine get_resistive_electric_field
6077
6078 !> calculate cell-center values from face-center values
6079 subroutine twofl_face_to_center(ixO^L,s)
6081 ! Non-staggered interpolation range
6082 integer, intent(in) :: ixo^l
6083 type(state) :: s
6084
6085 integer :: fxo^l, gxo^l, hxo^l, jxo^l, kxo^l, idim
6086
6087 associate(w=>s%w, ws=>s%ws)
6088
6089 ! calculate cell-center values from face-center values in 2nd order
6090 do idim=1,ndim
6091 ! Displace index to the left
6092 ! Even if ixI^L is the full size of the w arrays, this is ok
6093 ! because the staggered arrays have an additional place to the left.
6094 hxo^l=ixo^l-kr(idim,^d);
6095 ! Interpolate to cell barycentre using arithmetic average
6096 ! This might be done better later, to make the method less diffusive.
6097 w(ixo^s,mag(idim))=half/s%surface(ixo^s,idim)*&
6098 (ws(ixo^s,idim)*s%surfaceC(ixo^s,idim)&
6099 +ws(hxo^s,idim)*s%surfaceC(hxo^s,idim))
6100 end do
6101
6102 ! calculate cell-center values from face-center values in 4th order
6103 !do idim=1,ndim
6104 ! gxO^L=ixO^L-2*kr(idim,^D);
6105 ! hxO^L=ixO^L-kr(idim,^D);
6106 ! jxO^L=ixO^L+kr(idim,^D);
6107
6108 ! ! Interpolate to cell barycentre using fourth order central formula
6109 ! w(ixO^S,mag(idim))=(0.0625d0/s%surface(ixO^S,idim))*&
6110 ! ( -ws(gxO^S,idim)*s%surfaceC(gxO^S,idim) &
6111 ! +9.0d0*ws(hxO^S,idim)*s%surfaceC(hxO^S,idim) &
6112 ! +9.0d0*ws(ixO^S,idim)*s%surfaceC(ixO^S,idim) &
6113 ! -ws(jxO^S,idim)*s%surfaceC(jxO^S,idim) )
6114 !end do
6115
6116 ! calculate cell-center values from face-center values in 6th order
6117 !do idim=1,ndim
6118 ! fxO^L=ixO^L-3*kr(idim,^D);
6119 ! gxO^L=ixO^L-2*kr(idim,^D);
6120 ! hxO^L=ixO^L-kr(idim,^D);
6121 ! jxO^L=ixO^L+kr(idim,^D);
6122 ! kxO^L=ixO^L+2*kr(idim,^D);
6123
6124 ! ! Interpolate to cell barycentre using sixth order central formula
6125 ! w(ixO^S,mag(idim))=(0.00390625d0/s%surface(ixO^S,idim))* &
6126 ! ( +3.0d0*ws(fxO^S,idim)*s%surfaceC(fxO^S,idim) &
6127 ! -25.0d0*ws(gxO^S,idim)*s%surfaceC(gxO^S,idim) &
6128 ! +150.0d0*ws(hxO^S,idim)*s%surfaceC(hxO^S,idim) &
6129 ! +150.0d0*ws(ixO^S,idim)*s%surfaceC(ixO^S,idim) &
6130 ! -25.0d0*ws(jxO^S,idim)*s%surfaceC(jxO^S,idim) &
6131 ! +3.0d0*ws(kxO^S,idim)*s%surfaceC(kxO^S,idim) )
6132 !end do
6133
6134 end associate
6135
6136 end subroutine twofl_face_to_center
6137
6138 !> calculate magnetic field from vector potential
6139 subroutine b_from_vector_potential(ixIs^L, ixI^L, ixO^L, ws, x)
6142
6143 integer, intent(in) :: ixis^l, ixi^l, ixo^l
6144 double precision, intent(inout) :: ws(ixis^s,1:nws)
6145 double precision, intent(in) :: x(ixi^s,1:ndim)
6146
6147 double precision :: adummy(ixis^s,1:3)
6148
6149 call b_from_vector_potentiala(ixis^l, ixi^l, ixo^l, ws, x, adummy)
6150
6151 end subroutine b_from_vector_potential
6152
6153 subroutine hyperdiffusivity_get_dt(w,ixI^L,ixO^L,dtnew,dx^D,x)
6156 integer, intent(in) :: ixi^l, ixo^l
6157 double precision, intent(in) :: w(ixi^s,1:nw)
6158 double precision, intent(in) :: x(ixi^s,1:ndim)
6159 double precision, intent(in) :: dx^d
6160 double precision, intent(inout) :: dtnew
6161
6162 double precision :: nu(ixi^s),tmp(ixi^s),rho(ixi^s),temp(ixi^s)
6163 double precision :: divv(ixi^s,1:ndim)
6164 double precision :: vel(ixi^s,1:ndir)
6165 double precision :: csound(ixi^s),csound_dim(ixi^s,1:ndim)
6166 double precision :: dxarr(ndim)
6167 double precision :: maxcoef
6168 integer :: ixoo^l, hxb^l, hx^l, ii, jj
6169
6170
6171 ^d&dxarr(^d)=dx^d;
6172 maxcoef = smalldouble
6173
6174 ! charges
6175 call twofl_get_v_c(w,x,ixi^l,ixi^l,vel)
6176 call get_rhoc_tot(w,x,ixi^l,ixi^l,rho)
6177 call twofl_get_csound2_c_from_conserved(w,x,ixi^l,ixi^l,csound)
6178 csound(ixi^s) = sqrt(csound(ixi^s)) + sqrt(twofl_mag_en_all(w,ixi^l,ixi^l) /rho(ixi^s))
6179 csound(ixi^s) = csound(ixi^s) + sqrt(sum(vel(ixi^s,1:ndir)**2 ,dim=ndim+1))
6180 do ii=1,ndim
6181 call div_vel_coeff(ixi^l, ixoo^l, vel, ii, divv(ixi^s,ii))
6182 hxmin^d=iximin^d+1;
6183 hxmax^d=iximax^d-1;
6184 hxb^l=hx^l-kr(ii,^d);
6185 csound_dim(hx^s,ii) = (csound(hxb^s)+csound(hx^s))/2d0
6186 enddo
6187 call twofl_get_temp_c_pert_from_etot(w, x, ixi^l, ixi^l, temp)
6188 do ii=1,ndim
6189 !TODO the following is copied
6190 !rho_c
6191 call hyp_coeff(ixi^l, ixoo^l, w(ixi^s,rho_c_), ii, tmp(ixi^s))
6192 nu(ixo^s) = c_hyp(rho_c_) * csound_dim(ixo^s,ii) * dxlevel(ii) * tmp(ixo^s) + &
6193 c_shk(rho_c_) * (dxlevel(ii)**2) *divv(ixo^s,ii)
6194 maxcoef = max(maxcoef,maxval(nu(ixo^s)))
6195
6196 !TH c
6197 call hyp_coeff(ixi^l, ixoo^l, temp(ixi^s), ii, tmp(ixi^s))
6198 nu(ixo^s) = c_hyp(e_c_) * csound_dim(ixo^s,ii) * dxlevel(ii) * tmp(ixo^s) + &
6199 c_shk(e_c_) * (dxlevel(ii)**2) *divv(ixo^s,ii)
6200 nu(ixo^s) = nu(ixo^s) * rho(ixo^s) * rc/(twofl_gamma-1d0)
6201 maxcoef = max(maxcoef,maxval(nu(ixo^s)))
6202
6203 !visc c
6204 do jj=1,ndir
6205 call hyp_coeff(ixi^l, ixoo^l, vel(ixi^s,jj), ii, tmp(ixi^s))
6206 nu(ixo^s) = c_hyp(mom_c(jj)) * csound_dim(ixo^s,ii) * dxlevel(ii) * tmp(ixo^s) + &
6207 c_shk(mom_c(jj)) * (dxlevel(ii)**2) *divv(ixo^s,ii)
6208 nu(ixo^s) = nu(ixo^s) * rho(ixo^s)
6209 maxcoef = max(maxcoef,maxval(nu(ixo^s)))
6210 enddo
6211
6212 ! Ohmic
6213 do jj=1,ndir
6214 if(ii .ne. jj) then
6215 call hyp_coeff(ixi^l, ixoo^l, w(ixi^s,mag(jj)), ii, tmp(ixi^s))
6216 nu(ixo^s) = c_hyp(mag(jj)) * csound_dim(ixo^s,ii) * dxlevel(ii) * tmp(ixo^s) + &
6217 c_shk(mag(jj)) * (dxlevel(ii)**2) *divv(ixo^s,ii)
6218 maxcoef = max(maxcoef,maxval(nu(ixo^s)))
6219 endif
6220 enddo
6221
6222 enddo
6223
6224 !TODO the following is copied, as charges, and as in add_source!
6225 ! neutrals
6226 call twofl_get_v_n(w,x,ixi^l,ixi^l,vel)
6227 call twofl_get_csound_n(w,x,ixi^l,ixi^l,csound)
6228 csound(ixi^s) = csound(ixi^s) + sqrt(sum(vel(ixi^s,1:ndir)**2 ,dim=ndim+1))
6229 do ii=1,ndim
6230 call div_vel_coeff(ixi^l, ixoo^l, vel, ii, divv(ixi^s,ii))
6231 hxmin^d=iximin^d+1;
6232 hxmax^d=iximax^d-1;
6233 hxb^l=hx^l-kr(ii,^d);
6234 csound_dim(hx^s,ii) = (csound(hxb^s)+csound(hx^s))/2d0
6235 enddo
6236 call get_rhon_tot(w,x,ixi^l,ixo^l,rho)
6237 call twofl_get_temp_n_pert_from_etot(w, x, ixi^l, ixi^l, temp)
6238 do ii=1,ndim
6239 !rho_n
6240 call hyp_coeff(ixi^l, ixoo^l, w(ixi^s,rho_n_), ii, tmp(ixi^s))
6241 nu(ixo^s) = c_hyp(rho_n_) * csound_dim(ixo^s,ii) * dxlevel(ii) * tmp(ixo^s) + &
6242 c_shk(rho_n_) * (dxlevel(ii)**2) *divv(ixoo^s,ii)
6243 maxcoef = max(maxcoef,maxval(nu(ixo^s)))
6244
6245 !TH n
6246 call hyp_coeff(ixi^l, ixoo^l, temp(ixi^s), ii, tmp(ixi^s))
6247 nu(ixo^s) = c_hyp(e_n_) * csound_dim(ixo^s,ii) * dxlevel(ii) * tmp(ixo^s) + &
6248 c_shk(e_n_) * (dxlevel(ii)**2) *divv(ixo^s,ii)
6249 nu(ixo^s) = nu(ixo^s) * rho(ixo^s) * rn/(twofl_gamma-1d0)
6250 maxcoef = max(maxcoef,maxval(nu(ixo^s)))
6251
6252 !visc n
6253 do jj=1,ndir
6254 call hyp_coeff(ixi^l, ixoo^l, vel(ixi^s,jj), ii, tmp(ixi^s))
6255 nu(ixo^s) = c_hyp(mom_n(jj)) * csound_dim(ixo^s,ii) * dxlevel(ii) * tmp(ixo^s) + &
6256 c_shk(mom_n(jj)) * (dxlevel(ii)**2) *divv(ixo^s,ii)
6257 nu(ixo^s) = nu(ixo^s) * rho(ixo^s)
6258 maxcoef = max(maxcoef,maxval(nu(ixo^s)))
6259 enddo
6260 enddo
6261
6262 dtnew=min(dtdiffpar*minval(dxarr(1:ndim))**2/maxcoef,dtnew)
6263 end subroutine hyperdiffusivity_get_dt
6264
6265 subroutine add_source_hyperdiffusive(qdt,ixI^L,ixO^L,w,wCT,x)
6268
6269 integer, intent(in) :: ixi^l, ixo^l
6270 double precision, intent(in) :: qdt, x(ixi^s,1:ndim)
6271 double precision, intent(inout) :: w(ixi^s,1:nw)
6272 double precision, intent(in) :: wct(ixi^s,1:nw)
6273
6274 double precision :: divv(ixi^s,1:ndim)
6275 double precision :: vel(ixi^s,1:ndir)
6276 double precision :: csound(ixi^s),csound_dim(ixi^s,1:ndim)
6277 integer :: ii,ixoo^l,hxb^l,hx^l
6278 double precision :: rho(ixi^s)
6279
6280 call twofl_get_v_c(wct,x,ixi^l,ixi^l,vel)
6281 call get_rhoc_tot(wct,x,ixi^l,ixi^l,rho)
6282 call twofl_get_csound2_c_from_conserved(wct,x,ixi^l,ixi^l,csound)
6283 csound(ixi^s) = sqrt(csound(ixi^s)) + sqrt(twofl_mag_en_all(wct,ixi^l,ixi^l) /rho(ixi^s))
6284 csound(ixi^s) = csound(ixi^s) + sqrt(sum(vel(ixi^s,1:ndir)**2 ,dim=ndim+1))
6285 do ii=1,ndim
6286 call div_vel_coeff(ixi^l, ixoo^l, vel, ii, divv(ixi^s,ii))
6287 hxmin^d=iximin^d+1;
6288 hxmax^d=iximax^d-1;
6289 hxb^l=hx^l-kr(ii,^d);
6290 csound_dim(hx^s,ii) = (csound(hxb^s)+csound(hx^s))/2d0
6291 enddo
6293 call add_viscosity_hyper_source(rho,mom_c(1), e_c_)
6294 call add_th_cond_c_hyper_source(rho)
6295 call add_ohmic_hyper_source()
6296
6297 call twofl_get_v_n(wct,x,ixi^l,ixi^l,vel)
6298 call twofl_get_csound_n(wct,x,ixi^l,ixi^l,csound)
6299 csound(ixi^s) = csound(ixi^s) + sqrt(sum(vel(ixi^s,1:ndir)**2 ,dim=ndim+1))
6300 do ii=1,ndim
6301 call div_vel_coeff(ixi^l, ixoo^l, vel, ii, divv(ixi^s,ii))
6302 hxmin^d=iximin^d+1;
6303 hxmax^d=iximax^d-1;
6304 hxb^l=hx^l-kr(ii,^d);
6305 csound_dim(hx^s,ii) = (csound(hxb^s)+csound(hx^s))/2d0
6306 enddo
6308 call get_rhon_tot(wct,x,ixi^l,ixi^l,rho)
6309 call add_viscosity_hyper_source(rho,mom_n(1), e_n_)
6310 call add_th_cond_n_hyper_source(rho)
6311
6312 contains
6313
6314 subroutine add_density_hyper_source(index_rho)
6315 integer, intent(in) :: index_rho
6316
6317 double precision :: nu(ixI^S), tmp(ixI^S)
6318
6319 do ii=1,ndim
6320 call hyp_coeff(ixi^l, ixoo^l, wct(ixi^s,index_rho), ii, tmp(ixi^s))
6321 nu(ixoo^s) = c_hyp(index_rho) * csound_dim(ixoo^s,ii) * dxlevel(ii) * tmp(ixoo^s) + &
6322 c_shk(index_rho) * (dxlevel(ii)**2) *divv(ixoo^s,ii)
6323 !print*, "IXOO HYP ", ixOO^L, " IDIMM ", ii
6324 call second_same_deriv(ixi^l, ixoo^l, nu(ixi^s), wct(ixi^s,index_rho), ii, tmp)
6325
6326 w(ixo^s,index_rho) = w(ixo^s,index_rho) + qdt * tmp(ixo^s)
6327 !print*, "RHO ", index_rho, maxval(abs(tmp(ixO^S)))
6328 enddo
6329 end subroutine add_density_hyper_source
6330
6331 subroutine add_th_cond_c_hyper_source(var2)
6332 double precision, intent(in) :: var2(ixI^S)
6333 double precision :: nu(ixI^S), tmp(ixI^S), var(ixI^S)
6334 call twofl_get_temp_c_pert_from_etot(wct, x, ixi^l, ixi^l, var)
6335 do ii=1,ndim
6336 call hyp_coeff(ixi^l, ixoo^l, var(ixi^s), ii, tmp(ixi^s))
6337 nu(ixoo^s) = c_hyp(e_c_) * csound_dim(ixoo^s,ii) * dxlevel(ii) * tmp(ixoo^s) + &
6338 c_shk(e_c_) * (dxlevel(ii)**2) *divv(ixoo^s,ii)
6339 call second_same_deriv2(ixi^l, ixoo^l, nu(ixi^s), var2(ixi^s) ,var(ixi^s), ii, tmp)
6340 w(ixo^s,e_c_) = w(ixo^s,e_c_) + qdt * tmp(ixo^s) * rc/(twofl_gamma-1d0)
6341 !print*, "TH C ", maxval(abs(tmp(ixO^S)))
6342 enddo
6343 end subroutine add_th_cond_c_hyper_source
6344
6345 subroutine add_th_cond_n_hyper_source(var2)
6346 double precision, intent(in) :: var2(ixI^S)
6347 double precision :: nu(ixI^S), tmp(ixI^S), var(ixI^S)
6348 call twofl_get_temp_n_pert_from_etot(wct, x, ixi^l, ixi^l, var)
6349 do ii=1,ndim
6350 call hyp_coeff(ixi^l, ixoo^l, var(ixi^s), ii, tmp(ixi^s))
6351 nu(ixoo^s) = c_hyp(e_n_) * csound_dim(ixoo^s,ii) * dxlevel(ii) * tmp(ixoo^s) + &
6352 c_shk(e_n_) * (dxlevel(ii)**2) *divv(ixoo^s,ii)
6353 call second_same_deriv2(ixi^l, ixoo^l, nu(ixi^s), var2(ixi^s) ,var(ixi^s), ii, tmp)
6354 w(ixo^s,e_n_) = w(ixo^s,e_n_) + qdt * tmp(ixo^s) * rn/(twofl_gamma-1d0)
6355 !print*, "TH N ", maxval(abs(tmp(ixO^S)))
6356 enddo
6357 end subroutine add_th_cond_n_hyper_source
6358
6359 subroutine add_viscosity_hyper_source(rho,index_mom1, index_e)
6360 double precision, intent(in) :: rho(ixI^S)
6361 integer, intent(in) :: index_mom1, index_e
6362
6363 double precision :: nu(ixI^S,1:ndir,1:ndim), tmp(ixI^S),tmp2(ixI^S)
6364 integer :: jj
6365
6366 do jj=1,ndir
6367 do ii=1,ndim
6368 call hyp_coeff(ixi^l, ixoo^l, vel(ixi^s,jj), ii, tmp(ixi^s))
6369 nu(ixoo^s,jj,ii) = c_hyp(index_mom1-1+jj) * csound_dim(ixoo^s,ii) * dxlevel(ii) * tmp(ixoo^s) + &
6370 c_shk(index_mom1-1+jj) * (dxlevel(ii)**2) *divv(ixoo^s,ii)
6371 enddo
6372 enddo
6373
6374 do jj=1,ndir
6375 do ii=1,ndim
6376 call second_same_deriv2(ixi^l, ixoo^l, nu(ixi^s,jj,ii), rho(ixi^s), vel(ixi^s,jj), ii, tmp)
6377 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)
6378 if(ii .eq. jj) then
6379 w(ixo^s,index_mom1-1+jj) = w(ixo^s,index_mom1-1+jj) + qdt * tmp(ixo^s)
6380 w(ixo^s,index_e) = w(ixo^s,index_e) + qdt * tmp2(ixo^s)
6381
6382 else
6383 w(ixo^s,index_mom1-1+jj) = w(ixo^s,index_mom1-1+jj) + 0.5*qdt * tmp(ixo^s)
6384 w(ixo^s,index_e) = w(ixo^s,index_e) + 0.5*qdt * tmp2(ixo^s)
6385 call second_cross_deriv2(ixi^l, ixoo^l, nu(ixi^s,ii,jj), rho(ixi^s), vel(ixi^s,ii), jj, ii, tmp)
6386 w(ixo^s,index_mom1-1+jj) = w(ixo^s,index_mom1-1+jj) + 0.5*qdt * tmp(ixo^s)
6387 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)
6388 w(ixo^s,index_e) = w(ixo^s,index_e) + 0.5*qdt * tmp2(ixo^s)
6389 endif
6390
6391 enddo
6392 enddo
6393
6394 end subroutine add_viscosity_hyper_source
6395
6396 subroutine add_ohmic_hyper_source()
6397 double precision :: nu(ixI^S,1:ndir,1:ndim), tmp(ixI^S)
6398 integer :: jj
6399
6400 do jj=1,ndir
6401 do ii=1,ndim
6402 if(ii .ne. jj) then
6403 call hyp_coeff(ixi^l, ixoo^l, wct(ixi^s,mag(jj)), ii, tmp(ixi^s))
6404 nu(ixoo^s,jj,ii) = c_hyp(mag(jj)) * csound_dim(ixoo^s,ii) * dxlevel(ii) * tmp(ixoo^s) + &
6405 c_shk(mag(jj)) * (dxlevel(ii)**2) *divv(ixoo^s,ii)
6406 endif
6407 enddo
6408 enddo
6409
6410 do jj=1,ndir
6411 do ii=1,ndim
6412 if(ii .ne. jj) then
6413 !mag field
6414 call second_same_deriv(ixi^l, ixoo^l, nu(ixi^s,jj,ii), wct(ixi^s,mag(jj)), ii, tmp)
6415 w(ixo^s,mag(jj)) = w(ixo^s,mag(jj)) + qdt * tmp(ixo^s)
6416 call second_cross_deriv(ixi^l, ixoo^l, nu(ixi^s,ii,jj), wct(ixi^s,mag(ii)), jj, ii, tmp)
6417 w(ixo^s,mag(jj)) = w(ixo^s,mag(jj)) + qdt * tmp(ixo^s)
6418 !in the total energy
6419 call second_same_deriv(ixi^l, ixoo^l, nu(ixi^s,jj,ii), wct(ixi^s,mag(jj)), ii, tmp)
6420 w(ixo^s,e_c_) = w(ixo^s,e_c_) + qdt * tmp(ixo^s)
6421 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)
6422 w(ixo^s,e_c_) = w(ixo^s,e_c_) + qdt * tmp(ixo^s)
6423 endif
6424
6425 enddo
6426 enddo
6427
6428 end subroutine add_ohmic_hyper_source
6429
6430 end subroutine add_source_hyperdiffusive
6431
6432 function dump_hyperdiffusivity_coef_x(ixI^L,ixO^L, w, x, nwc) result(wnew)
6435 integer, intent(in) :: ixI^L, ixO^L, nwc
6436 double precision, intent(in) :: w(ixI^S, 1:nw)
6437 double precision, intent(in) :: x(ixI^S,1:ndim)
6438 double precision :: wnew(ixO^S, 1:nwc)
6439
6440 if(nw .ne. nwc) call mpistop("nw != nwc")
6441 wnew(ixo^s,1:nw) = dump_hyperdiffusivity_coef_dim(ixi^l,ixo^l, w, x, 1)
6442
6443 end function dump_hyperdiffusivity_coef_x
6444
6445 function dump_hyperdiffusivity_coef_y(ixI^L,ixO^L, w, x, nwc) result(wnew)
6448 integer, intent(in) :: ixI^L, ixO^L, nwc
6449 double precision, intent(in) :: w(ixI^S, 1:nw)
6450 double precision, intent(in) :: x(ixI^S,1:ndim)
6451 double precision :: wnew(ixO^S, 1:nwc)
6452
6453 if(nw .ne. nwc) call mpistop("nw != nwc")
6454 wnew(ixo^s,1:nw) = dump_hyperdiffusivity_coef_dim(ixi^l,ixo^l, w, x, 2)
6455
6456 end function dump_hyperdiffusivity_coef_y
6457
6458 function dump_hyperdiffusivity_coef_z(ixI^L,ixO^L, w, x, nwc) result(wnew)
6461 integer, intent(in) :: ixI^L, ixO^L, nwc
6462 double precision, intent(in) :: w(ixI^S, 1:nw)
6463 double precision, intent(in) :: x(ixI^S,1:ndim)
6464 double precision :: wnew(ixO^S, 1:nwc)
6465
6466 if(nw .ne. nwc) call mpistop("nw != nwc")
6467 wnew(ixo^s,1:nw) = dump_hyperdiffusivity_coef_dim(ixi^l,ixo^l, w, x, 3)
6468
6469 end function dump_hyperdiffusivity_coef_z
6470
6471 function dump_hyperdiffusivity_coef_dim(ixI^L,ixOP^L, w, x, ii) result(wnew)
6474 integer, intent(in) :: ixI^L, ixOP^L, ii
6475 double precision, intent(in) :: w(ixI^S, 1:nw)
6476 double precision, intent(in) :: x(ixI^S,1:ndim)
6477 double precision :: wnew(ixOP^S, 1:nw)
6478
6479 double precision :: nu(ixI^S),tmp(ixI^S),rho(ixI^S),temp(ixI^S)
6480 double precision :: divv(ixI^S)
6481 double precision :: vel(ixI^S,1:ndir)
6482 double precision :: csound(ixI^S),csound_dim(ixI^S)
6483 double precision :: dxarr(ndim)
6484 integer :: ixOO^L, hxb^L, hx^L, jj, ixO^L
6485
6486 ! this is done because of save_physical_boundary = true
6487 ixomin^d=max(ixopmin^d,iximin^d+3);
6488 ixomax^d=min(ixopmax^d,iximax^d-3);
6489
6490 wnew(ixop^s,1:nw) = 0d0
6491
6492 ! charges
6493 call twofl_get_temp_c_pert_from_etot(w, x, ixi^l, ixi^l, temp)
6494 call twofl_get_v_c(w,x,ixi^l,ixi^l,vel)
6495 call get_rhoc_tot(w,x,ixi^l,ixi^l,rho)
6496 call twofl_get_csound2_c_from_conserved(w,x,ixi^l,ixi^l,csound)
6497 csound(ixi^s) = sqrt(csound(ixi^s)) + sqrt(twofl_mag_en_all(w,ixi^l,ixi^l) /rho(ixi^s))
6498 csound(ixi^s) = csound(ixi^s) + sqrt(sum(vel(ixi^s,1:ndir)**2 ,dim=ndim+1))
6499 !for dim
6500 call div_vel_coeff(ixi^l, ixoo^l, vel, ii, divv(ixi^s))
6501 hxmin^d=iximin^d+1;
6502 hxmax^d=iximax^d-1;
6503 hxb^l=hx^l-kr(ii,^d);
6504 csound_dim(hx^s) = (csound(hxb^s)+csound(hx^s))/2d0
6505
6506 !TODO the following is copied
6507 !rho_c
6508 call hyp_coeff(ixi^l, ixoo^l, w(ixi^s,rho_c_), ii, tmp(ixi^s))
6509 nu(ixo^s) = c_hyp(rho_c_) * csound_dim(ixo^s) * dxlevel(ii) * tmp(ixo^s) + &
6510 c_shk(rho_c_) * (dxlevel(ii)**2) *divv(ixo^s)
6511
6512 wnew(ixo^s,rho_c_) = nu(ixo^s)
6513
6514 !TH c
6515 call hyp_coeff(ixi^l, ixoo^l, temp(ixi^s), ii, tmp(ixi^s))
6516 nu(ixo^s) = c_hyp(e_c_) * csound_dim(ixo^s) * dxlevel(ii) * tmp(ixo^s) + &
6517 c_shk(e_c_) * (dxlevel(ii)**2) *divv(ixo^s)
6518 nu(ixo^s) = nu(ixo^s) * rho(ixo^s) * rc/(twofl_gamma-1d0)
6519 wnew(ixo^s,e_c_) = nu(ixo^s)
6520
6521 !visc c
6522 do jj=1,ndir
6523 call hyp_coeff(ixi^l, ixoo^l, vel(ixi^s,jj), ii, tmp(ixi^s))
6524 nu(ixo^s) = c_hyp(mom_c(jj)) * csound_dim(ixo^s) * dxlevel(ii) * tmp(ixo^s) + &
6525 c_shk(mom_c(jj)) * (dxlevel(ii)**2) *divv(ixo^s)
6526 nu(ixo^s) = nu(ixo^s) * rho(ixo^s)
6527 wnew(ixo^s,mom_c(jj)) = nu(ixo^s)
6528 enddo
6529
6530 ! Ohmic
6531 do jj=1,ndir
6532 if(ii .ne. jj) then
6533 call hyp_coeff(ixi^l, ixoo^l, w(ixi^s,mag(jj)), ii, tmp(ixi^s))
6534 nu(ixo^s) = c_hyp(mag(jj)) * csound_dim(ixo^s) * dxlevel(ii) * tmp(ixo^s) + &
6535 c_shk(mag(jj)) * (dxlevel(ii)**2) *divv(ixo^s)
6536 wnew(ixo^s,mag(jj)) = nu(ixo^s)
6537 endif
6538 enddo
6539
6540 !end for dim
6541
6542 ! neutrals
6543 call get_rhon_tot(w,x,ixi^l,ixo^l,rho)
6544 call twofl_get_temp_n_pert_from_etot(w, x, ixi^l, ixi^l, temp)
6545 call twofl_get_v_n(w,x,ixi^l,ixi^l,vel)
6546 call twofl_get_csound_n(w,x,ixi^l,ixi^l,csound)
6547 csound(ixi^s) = csound(ixi^s) + sqrt(sum(vel(ixi^s,1:ndir)**2 ,dim=ndim+1))
6548 !for dim
6549 call div_vel_coeff(ixi^l, ixoo^l, vel, ii, divv(ixi^s))
6550 hxb^l=ixoo^l-kr(ii,^d);
6551 csound_dim(ixoo^s) = (csound(hxb^s)+csound(ixoo^s))/2d0
6552 !rho_n
6553 call hyp_coeff(ixi^l, ixoo^l, w(ixi^s,rho_n_), ii, tmp(ixi^s))
6554 nu(ixo^s) = c_hyp(rho_n_) * csound_dim(ixo^s) * dxlevel(ii) * tmp(ixo^s) + &
6555 c_shk(rho_n_) * (dxlevel(ii)**2) *divv(ixoo^s)
6556 wnew(ixo^s,rho_n_) = nu(ixo^s)
6557
6558 !TH n
6559 call hyp_coeff(ixi^l, ixoo^l, temp(ixi^s), ii, tmp(ixi^s))
6560 nu(ixo^s) = c_hyp(e_n_) * csound_dim(ixo^s) * dxlevel(ii) * tmp(ixo^s) + &
6561 c_shk(e_n_) * (dxlevel(ii)**2) *divv(ixo^s)
6562 nu(ixo^s) = nu(ixo^s) * rho(ixo^s) * rn/(twofl_gamma-1d0)
6563 wnew(ixo^s,e_n_) = nu(ixo^s)
6564
6565 !visc n
6566 do jj=1,ndir
6567 call hyp_coeff(ixi^l, ixoo^l, vel(ixi^s,jj), ii, tmp(ixi^s))
6568 nu(ixo^s) = c_hyp(mom_n(jj)) * csound_dim(ixo^s) * dxlevel(ii) * tmp(ixo^s) + &
6569 c_shk(mom_n(jj)) * (dxlevel(ii)**2) *divv(ixo^s)
6570 nu(ixo^s) = nu(ixo^s) * rho(ixo^s)
6571 wnew(ixo^s,mom_n(jj)) = nu(ixo^s)
6572 enddo
6573 !end for dim
6574
6575 end function dump_hyperdiffusivity_coef_dim
6576
6577 function dump_coll_terms(ixI^L,ixO^L, w, x, nwc) result(wnew)
6579 integer, intent(in) :: ixI^L,ixO^L, nwc
6580 double precision, intent(in) :: w(ixI^S, 1:nw)
6581 double precision, intent(in) :: x(ixI^S,1:ndim)
6582 double precision :: wnew(ixO^S, 1:nwc)
6583 double precision :: tmp(ixI^S),tmp2(ixI^S)
6584
6585 call get_alpha_coll(ixi^l, ixo^l, w, x, tmp(ixi^s))
6586 wnew(ixo^s,1)= tmp(ixo^s)
6587 call get_gamma_ion_rec(ixi^l, ixo^l, w, x, tmp(ixi^s), tmp2(ixi^s))
6588 wnew(ixo^s,2)= tmp(ixo^s)
6589 wnew(ixo^s,3)= tmp2(ixo^s)
6590
6591 end function dump_coll_terms
6592
6593 subroutine get_gamma_ion_rec(ixI^L, ixO^L, w, x, gamma_rec, gamma_ion)
6595
6596 integer, intent(in) :: ixi^l, ixo^l
6597 double precision, intent(in) :: w(ixi^s,1:nw)
6598 double precision, intent(in) :: x(ixi^s,1:ndim)
6599 double precision, intent(out) :: gamma_rec(ixi^s),gamma_ion(ixi^s)
6600 ! calculations are done in S.I. units
6601 double precision, parameter :: a = 2.91e-14, & !m3/s
6602 k = 0.39, &
6603 xx = 0.232, &
6604 eion = 13.6 ! eV
6605 double precision, parameter :: echarge=1.6022d-19 !C
6606 double precision :: rho(ixi^s), tmp(ixi^s)
6607
6608 call twofl_get_pthermal_c(w,x,ixi^l,ixo^l,tmp)
6609 call get_rhoc_tot(w,x,ixi^l,ixo^l,rho)
6610 tmp(ixo^s) = tmp(ixo^s)/(rc * rho(ixo^s))
6611
6612 !transform to SI units
6613 tmp(ixo^s) = tmp(ixo^s) * unit_temperature * kb_si/echarge !* BK/ECHARGE means K to eV
6614 !number electrons rho_c = n_e * MH, in normalized units MH=1 and n = rho
6615 rho(ixo^s) = rho(ixo^s) * unit_numberdensity
6616 if(.not. si_unit) then
6617 !1/cm^3 = 1e6/m^3
6618 rho(ixo^s) = rho(ixo^s) * 1d6
6619 endif
6620 gamma_rec(ixo^s) = rho(ixo^s) /sqrt(tmp(ixo^s)) * 2.6e-19
6621 gamma_ion(ixo^s) = ((rho(ixo^s) * a) /(xx + eion/tmp(ixo^s))) * ((eion/tmp(ixo^s))**k) * exp(-eion/tmp(ixo^s))
6622 ! see Voronov table: valid for temp min = 1eV(approx 11605 K), Temp max = 20KeV
6623 !to normalized
6624 gamma_rec(ixo^s) = gamma_rec(ixo^s) * unit_time
6625 gamma_ion(ixo^s) = gamma_ion(ixo^s) * unit_time
6626
6627 if (associated(usr_mask_gamma_ion_rec)) then
6628 call usr_mask_gamma_ion_rec(ixi^l,ixo^l,w,x,gamma_ion, gamma_rec)
6629 end if
6630 end subroutine get_gamma_ion_rec
6631
6632 subroutine get_alpha_coll(ixI^L, ixO^L, w, x, alpha)
6634 integer, intent(in) :: ixi^l, ixo^l
6635 double precision, intent(in) :: w(ixi^s,1:nw)
6636 double precision, intent(in) :: x(ixi^s,1:ndim)
6637 double precision, intent(out) :: alpha(ixi^s)
6639 alpha(ixo^s) = twofl_alpha_coll
6640 else
6641 call get_alpha_coll_plasma(ixi^l, ixo^l, w, x, alpha)
6642 endif
6643 if (associated(usr_mask_alpha)) then
6644 call usr_mask_alpha(ixi^l,ixo^l,w,x,alpha)
6645 end if
6646 end subroutine get_alpha_coll
6647
6648 subroutine get_alpha_coll_plasma(ixI^L, ixO^L, w, x, alpha)
6650 integer, intent(in) :: ixi^l, ixo^l
6651 double precision, intent(in) :: w(ixi^s,1:nw)
6652 double precision, intent(in) :: x(ixi^s,1:ndim)
6653 double precision, intent(out) :: alpha(ixi^s)
6654 double precision :: pe(ixi^s),rho(ixi^s), tmp(ixi^s), tmp2(ixi^s)
6655
6656 double precision :: sigma_in = 1e-19 ! m^2
6657 ! make calculation in SI physical units
6658
6659 call twofl_get_pthermal_c(w,x,ixi^l,ixo^l,pe)
6660 call get_rhoc_tot(w,x,ixi^l,ixo^l,rho)
6661 tmp(ixo^s) = pe(ixo^s)/(rc * rho(ixo^s))
6662 call twofl_get_pthermal_n(w,x,ixi^l,ixo^l,pe)
6663 call get_rhon_tot(w,x,ixi^l,ixo^l,rho)
6664 tmp2(ixo^s) = pe(ixo^s)/(rn * rho(ixo^s))
6665 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
6666 if(.not. si_unit) then
6667 alpha(ixo^s) = alpha(ixo^s) * 1d3 ! this comes from unit_density: g/cm^3 = 1e-3 kg/m^3
6668 endif
6669
6670 end subroutine get_alpha_coll_plasma
6671
6672 subroutine calc_mult_factor1(ixI^L, ixO^L, step_dt, JJ, res)
6673 integer, intent(in) :: ixi^l, ixo^l
6674 double precision, intent(in) :: step_dt
6675 double precision, intent(in) :: jj(ixi^s)
6676 double precision, intent(out) :: res(ixi^s)
6677
6678 res(ixo^s) = step_dt/(1d0 + step_dt * jj(ixo^s))
6679
6680 end subroutine calc_mult_factor1
6681
6682 subroutine calc_mult_factor2(ixI^L, ixO^L, step_dt, JJ, res)
6683 integer, intent(in) :: ixi^l, ixo^l
6684 double precision, intent(in) :: step_dt
6685 double precision, intent(in) :: jj(ixi^s)
6686 double precision, intent(out) :: res(ixi^s)
6687
6688 res(ixo^s) = (1d0 - exp(-step_dt * jj(ixo^s)))/jj(ixo^s)
6689
6690 end subroutine calc_mult_factor2
6691
6692 subroutine advance_implicit_grid(ixI^L, ixO^L, w, wout, x, dtfactor,qdt)
6694 integer, intent(in) :: ixi^l, ixo^l
6695 double precision, intent(in) :: qdt
6696 double precision, intent(in) :: dtfactor
6697 double precision, intent(in) :: w(ixi^s,1:nw)
6698 double precision, intent(in) :: x(ixi^s,1:ndim)
6699 double precision, intent(out) :: wout(ixi^s,1:nw)
6700
6701 integer :: idir
6702 double precision :: tmp(ixi^s),tmp1(ixi^s),tmp2(ixi^s),tmp3(ixi^s),tmp4(ixi^s),tmp5(ixi^s)
6703 double precision :: v_c(ixi^s,ndir), v_n(ixi^s,ndir)
6704 double precision :: rhon(ixi^s), rhoc(ixi^s), alpha(ixi^s)
6705 double precision, allocatable :: gamma_rec(:^d&), gamma_ion(:^D&)
6706
6707 !TODO latest changes sets already wout to w in implicit update (see where psb=psa)
6708 ! commment out setting mag and density when they are not modified here
6709
6710 ! copy vars at the indices which are not updated here: mag. field
6711 wout(ixo^s,mag(:)) = w(ixo^s,mag(:))
6712
6713 call get_rhon_tot(w,x,ixi^l,ixo^l,rhon)
6714 call get_rhoc_tot(w,x,ixi^l,ixo^l,rhoc)
6715 !update density
6716 if(twofl_coll_inc_ionrec) then
6717 allocate(gamma_ion(ixi^s), gamma_rec(ixi^s))
6718 call get_gamma_ion_rec(ixi^l, ixo^l, w, x, gamma_rec, gamma_ion)
6719 tmp2(ixo^s) = gamma_rec(ixo^s) + gamma_ion(ixo^s)
6720 call calc_mult_factor(ixi^l, ixo^l, dtfactor * qdt, tmp2, tmp3)
6721 tmp(ixo^s) = (-gamma_ion(ixo^s) * rhon(ixo^s) + &
6722 gamma_rec(ixo^s) * rhoc(ixo^s))
6723 wout(ixo^s,rho_n_) = w(ixo^s,rho_n_) + tmp(ixo^s) * tmp3(ixo^s)
6724 wout(ixo^s,rho_c_) = w(ixo^s,rho_c_) - tmp(ixo^s) * tmp3(ixo^s)
6725 else
6726 wout(ixo^s,rho_n_) = w(ixo^s,rho_n_)
6727 wout(ixo^s,rho_c_) = w(ixo^s,rho_c_)
6728 endif
6729
6730 call get_alpha_coll(ixi^l, ixo^l, w, x, alpha)
6731
6732 !-J11 + J12 for momentum and kinetic energy
6733 tmp2(ixo^s) = alpha(ixo^s) * (rhon(ixo^s) + rhoc(ixo^s))
6734 if(twofl_coll_inc_ionrec) then
6735 tmp2(ixo^s) = tmp2(ixo^s) + gamma_ion(ixo^s) + gamma_rec(ixo^s)
6736 endif
6737 call calc_mult_factor(ixi^l, ixo^l, dtfactor * qdt, tmp2, tmp3)
6738
6739 ! momentum update
6740 do idir=1,ndir
6741
6742 tmp(ixo^s) = alpha(ixo^s)* (-rhoc(ixo^s) * w(ixo^s,mom_n(idir)) + rhon(ixo^s) * w(ixo^s,mom_c(idir)))
6743 if(twofl_coll_inc_ionrec) then
6744 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))
6745 endif
6746
6747 wout(ixo^s,mom_n(idir)) = w(ixo^s,mom_n(idir)) + tmp(ixo^s) * tmp3(ixo^s)
6748 wout(ixo^s,mom_c(idir)) = w(ixo^s,mom_c(idir)) - tmp(ixo^s) * tmp3(ixo^s)
6749 enddo
6750
6751 ! energy update
6752
6753 ! kinetic energy update
6754 if(.not. phys_internal_e) then
6755 ! E_tot includes kinetic energy
6756 tmp1(ixo^s) = twofl_kin_en_n(w,ixi^l,ixo^l)
6757 tmp2(ixo^s) = twofl_kin_en_c(w,ixi^l,ixo^l)
6758 tmp4(ixo^s) = w(ixo^s,e_n_) - tmp1(ixo^s) !E_tot - E_kin
6759 tmp5(ixo^s) = w(ixo^s,e_c_) - tmp2(ixo^s)
6760 if(phys_total_energy) then
6761 tmp5(ixo^s) = tmp5(ixo^s) - twofl_mag_en(w,ixi^l,ixo^l)
6762 endif
6763
6764 !!implicit update
6765 tmp(ixo^s) = alpha(ixo^s)*(-rhoc(ixo^s) * tmp1(ixo^s) + rhon(ixo^s) * tmp2(ixo^s))
6766 if(twofl_coll_inc_ionrec) then
6767 tmp(ixo^s) = tmp(ixo^s) - gamma_ion(ixo^s) * tmp1(ixo^s) + gamma_rec(ixo^s) * tmp2(ixo^s)
6768 endif
6769
6770 wout(ixo^s,e_n_) = w(ixo^s,e_n_) + tmp(ixo^s) * tmp3(ixo^s)
6771 wout(ixo^s,e_c_) = w(ixo^s,e_c_) - tmp(ixo^s) * tmp3(ixo^s)
6772
6773 else
6774 tmp4(ixo^s) = w(ixo^s,e_n_)
6775 tmp5(ixo^s) = w(ixo^s,e_c_)
6776 ! calculate velocities, using the already updated variables
6777 call twofl_get_v_n(wout,x,ixi^l,ixo^l,v_n)
6778 call twofl_get_v_c(wout,x,ixi^l,ixo^l,v_c)
6779 tmp1(ixo^s) = alpha(ixo^s) * rhoc(ixo^s) * rhon(ixo^s)
6780 tmp2(ixo^s) = tmp1(ixo^s)
6781 if(twofl_coll_inc_ionrec) then
6782 tmp1(ixo^s) = tmp1(ixo^s) + rhoc(ixo^s) * gamma_rec(ixo^s)
6783 tmp2(ixo^s) = tmp2(ixo^s) + rhon(ixo^s) * gamma_ion(ixo^s)
6784 endif
6785
6786 tmp(ixo^s) = 0.5d0 * sum((v_c(ixo^s,1:ndir) - v_n(ixo^s,1:ndir))**2, dim=ndim+1) &
6787 * dtfactor * qdt
6788 wout(ixo^s,e_n_) = w(ixo^s,e_n_) + tmp(ixo^s)*tmp1(ixo^s)
6789 wout(ixo^s,e_c_) = w(ixo^s,e_c_) + tmp(ixo^s)*tmp2(ixo^s)
6790 endif
6791
6792 !update internal energy
6793 if(twofl_coll_inc_te) then
6794 if(has_equi_pe_n0) then
6795 tmp2(ixo^s)= block%equi_vars(ixo^s,equi_pe_n0_,0)*inv_gamma_1
6796 endif
6797 if(has_equi_pe_c0) then
6798 tmp3(ixo^s)=block%equi_vars(ixo^s,equi_pe_c0_,0)*inv_gamma_1
6799 endif
6800 if (twofl_equi_thermal) then
6801 tmp(ixo^s) = alpha(ixo^s) *(-1d0/rn*(rhoc(ixo^s) * tmp4(ixo^s) + &
6802 tmp2(ixo^s)*w(ixo^s,rho_c_)) + 1d0/rc*(rhon(ixo^s) * tmp5(ixo^s) +&
6803 tmp3(ixo^s)*w(ixo^s,rho_n_)))
6804 endif
6805 if(has_equi_pe_n0) then
6806 tmp4(ixo^s) = tmp2(ixo^s) + tmp4(ixo^s)
6807 endif
6808 if(has_equi_pe_c0) then
6809 tmp5(ixo^s) = tmp3(ixo^s) + tmp5(ixo^s)
6810 endif
6811 if (.not. twofl_equi_thermal) then
6812 tmp(ixo^s) = alpha(ixo^s) *(-rhoc(ixo^s)/rn * tmp4(ixo^s) + rhon(ixo^s)/rc * tmp5(ixo^s))
6813 endif
6814 tmp2(ixo^s) = alpha(ixo^s) * (rhon(ixo^s)/rc + rhoc(ixo^s)/rn)
6815 if(twofl_coll_inc_ionrec) then
6816 tmp2(ixo^s) = tmp2(ixo^s) + gamma_rec(ixo^s)/rc + gamma_ion(ixo^s)/rn
6817 tmp(ixo^s) = tmp(ixo^s) - gamma_ion(ixo^s)/rn * tmp4(ixo^s) + gamma_rec(ixo^s)/rc * tmp5(ixo^s)
6818 endif
6819 call calc_mult_factor(ixi^l, ixo^l, dtfactor * qdt, tmp2, tmp3)
6820 wout(ixo^s,e_n_) = wout(ixo^s,e_n_)+tmp(ixo^s)*tmp3(ixo^s)
6821 wout(ixo^s,e_c_) = wout(ixo^s,e_c_)-tmp(ixo^s)*tmp3(ixo^s)
6822 endif
6823 if(twofl_coll_inc_ionrec) then
6824 deallocate(gamma_ion, gamma_rec)
6825 endif
6826 end subroutine advance_implicit_grid
6827
6828 !> Implicit solve of psb=psa+dtfactor*dt*F_im(psb)
6829 subroutine twofl_implicit_coll_terms_update(dtfactor,qdt,qtC,psb,psa)
6832
6833 type(state), target :: psa(max_blocks)
6834 type(state), target :: psb(max_blocks)
6835 double precision, intent(in) :: qdt
6836 double precision, intent(in) :: qtc
6837 double precision, intent(in) :: dtfactor
6838
6839 integer :: iigrid, igrid
6840 !print*, "IMPL call ", it
6841
6842 call getbc(global_time,0.d0,psa,1,nw)
6843 !$OMP PARALLEL DO PRIVATE(igrid)
6844 do iigrid=1,igridstail; igrid=igrids(iigrid);
6845 ^d&dxlevel(^d)=rnode(rpdx^d_,igrid);
6846 block=>psa(igrid)
6847 call advance_implicit_grid(ixg^ll, ixg^ll, psa(igrid)%w, psb(igrid)%w, psa(igrid)%x, dtfactor,qdt)
6848 end do
6849 !$OMP END PARALLEL DO
6850
6851 end subroutine twofl_implicit_coll_terms_update
6852
6853 !> inplace update of psa==>F_im(psa)
6854 subroutine twofl_evaluate_implicit(qtC,psa)
6856 type(state), target :: psa(max_blocks)
6857 double precision, intent(in) :: qtc
6858
6859 integer :: iigrid, igrid, level
6860
6861 !$OMP PARALLEL DO PRIVATE(igrid)
6862 do iigrid=1,igridstail; igrid=igrids(iigrid);
6863 ^d&dxlevel(^d)=rnode(rpdx^d_,igrid);
6864 block=>psa(igrid)
6865 call coll_terms(ixg^ll,ixm^ll,psa(igrid)%w,psa(igrid)%x)
6866 end do
6867 !$OMP END PARALLEL DO
6868
6869 end subroutine twofl_evaluate_implicit
6870
6871 subroutine coll_terms(ixI^L,ixO^L,w,x)
6873 integer, intent(in) :: ixi^l, ixo^l
6874 double precision, intent(inout) :: w(ixi^s, 1:nw)
6875 double precision, intent(in) :: x(ixi^s,1:ndim)
6876
6877 integer :: idir
6878 double precision :: tmp(ixi^s),tmp1(ixi^s),tmp2(ixi^s),tmp3(ixi^s),tmp4(ixi^s),tmp5(ixi^s)
6879 !double precision :: v_c(ixI^S,ndir), v_n(ixI^S,ndir)
6880 double precision, allocatable :: v_c(:^d&,:), v_n(:^D&,:)
6881 double precision, allocatable :: rho_c1(:^d&), rho_n1(:^D&)
6882 double precision :: rhon(ixi^s), rhoc(ixi^s), alpha(ixi^s)
6883 double precision, allocatable :: gamma_rec(:^d&), gamma_ion(:^D&)
6884
6885 ! copy density before overwrite
6886 if(twofl_equi_thermal) then
6887 allocate(rho_n1(ixi^s), rho_c1(ixi^s))
6888 rho_n1(ixo^s) = w(ixo^s,rho_n_)
6889 rho_c1(ixo^s) = w(ixo^s,rho_c_)
6890 endif
6891
6892 ! get total density before overwrite density
6893 call get_rhon_tot(w,x,ixi^l,ixo^l,rhon)
6894 call get_rhoc_tot(w,x,ixi^l,ixo^l,rhoc)
6895 if(phys_internal_e) then
6896 ! get velocity before overwrite momentum
6897 allocate(v_n(ixi^s,ndir), v_c(ixi^s,ndir))
6898 call twofl_get_v_n(w,x,ixi^l,ixo^l,v_n)
6899 call twofl_get_v_c(w,x,ixi^l,ixo^l,v_c)
6900 else
6901 ! get ke before overwrite density and momentum
6902 tmp1(ixo^s) = twofl_kin_en_n(w,ixi^l,ixo^l)
6903 tmp2(ixo^s) = twofl_kin_en_c(w,ixi^l,ixo^l)
6904 endif
6905
6906 !update density
6907 if(twofl_coll_inc_ionrec) then
6908 allocate(gamma_ion(ixi^s), gamma_rec(ixi^s))
6909 call get_gamma_ion_rec(ixi^l, ixo^l, w, x, gamma_rec, gamma_ion)
6910 tmp(ixo^s) = -gamma_ion(ixo^s) * rhon(ixo^s) + &
6911 gamma_rec(ixo^s) * rhoc(ixo^s)
6912 w(ixo^s,rho_n_) = tmp(ixo^s)
6913 w(ixo^s,rho_c_) = -tmp(ixo^s)
6914 else
6915 w(ixo^s,rho_n_) = 0d0
6916 w(ixo^s,rho_c_) = 0d0
6917
6918 endif
6919
6920 call get_alpha_coll(ixi^l, ixo^l, w, x, alpha)
6921
6922 ! momentum update
6923 do idir=1,ndir
6924
6925 tmp(ixo^s) = alpha(ixo^s)* (-rhoc(ixo^s) * w(ixo^s,mom_n(idir)) + rhon(ixo^s) * w(ixo^s,mom_c(idir)))
6926 if(twofl_coll_inc_ionrec) then
6927 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))
6928 endif
6929
6930 w(ixo^s,mom_n(idir)) = tmp(ixo^s)
6931 w(ixo^s,mom_c(idir)) = -tmp(ixo^s)
6932 enddo
6933
6934 ! energy update
6935
6936 ! kinetic energy update
6937 if(.not. phys_internal_e) then
6938 ! E_tot includes kinetic energy
6939 tmp4(ixo^s) = w(ixo^s,e_n_) - tmp1(ixo^s) !E_tot - E_kin
6940 tmp5(ixo^s) = w(ixo^s,e_c_) - tmp2(ixo^s)
6941 if(phys_total_energy) then
6942 tmp5(ixo^s) = tmp5(ixo^s) - twofl_mag_en(w,ixi^l,ixo^l)
6943 endif
6944 ! tmp4 = eint_n, tmp5 = eint_c
6945 ! tmp1 = ke_n, tmp2 = ke_c
6946 tmp(ixo^s) = alpha(ixo^s)*(-rhoc(ixo^s) * tmp1(ixo^s) + rhon(ixo^s) * tmp2(ixo^s))
6947 if(twofl_coll_inc_ionrec) then
6948 tmp(ixo^s) = tmp(ixo^s) - gamma_ion(ixo^s) * tmp1(ixo^s) + gamma_rec(ixo^s) * tmp2(ixo^s)
6949 endif
6950
6951 w(ixo^s,e_n_) = tmp(ixo^s)
6952 w(ixo^s,e_c_) = -tmp(ixo^s)
6953
6954 else
6955 tmp4(ixo^s) = w(ixo^s,e_n_)
6956 tmp5(ixo^s) = w(ixo^s,e_c_)
6957 tmp1(ixo^s) = alpha(ixo^s) * rhoc(ixo^s) * rhon(ixo^s)
6958 tmp2(ixo^s) = tmp1(ixo^s)
6959 if(twofl_coll_inc_ionrec) then
6960 tmp1(ixo^s) = tmp1(ixo^s) + rhoc(ixo^s) * gamma_rec(ixo^s)
6961 tmp2(ixo^s) = tmp2(ixo^s) + rhon(ixo^s) * gamma_ion(ixo^s)
6962 endif
6963
6964 tmp(ixo^s) = 0.5d0 * sum((v_c(ixo^s,1:ndir) - v_n(ixo^s,1:ndir))**2, dim=ndim+1)
6965 w(ixo^s,e_n_) = tmp(ixo^s)*tmp1(ixo^s)
6966 w(ixo^s,e_c_) = tmp(ixo^s)*tmp2(ixo^s)
6967 endif
6968
6969 !update internal energy
6970 if(twofl_coll_inc_te) then
6971
6972 if(has_equi_pe_n0) then
6973 tmp2(ixo^s)= block%equi_vars(ixo^s,equi_pe_n0_,0)*inv_gamma_1
6974 endif
6975 if(has_equi_pe_c0) then
6976 tmp3(ixo^s)=block%equi_vars(ixo^s,equi_pe_c0_,0)*inv_gamma_1
6977 endif
6978 if (twofl_equi_thermal) then
6979 tmp(ixo^s) = alpha(ixo^s) *(-1d0/rn*(rhoc(ixo^s) * tmp4(ixo^s) + &
6980 tmp2(ixo^s)*rho_c1(ixo^s)) + 1d0/rc*(rhon(ixo^s) * tmp5(ixo^s) +&
6981 tmp3(ixo^s)*rho_n1(ixo^s)))
6982 endif
6983 if(has_equi_pe_n0) then
6984 tmp4(ixo^s) = tmp2(ixo^s) + tmp4(ixo^s)
6985 endif
6986 if(has_equi_pe_c0) then
6987 tmp5(ixo^s) = tmp3(ixo^s) + tmp5(ixo^s)
6988 endif
6989 if (.not. twofl_equi_thermal) then
6990 tmp(ixo^s) = alpha(ixo^s) *(-rhoc(ixo^s)/rn * tmp4(ixo^s) + rhon(ixo^s)/rc * tmp5(ixo^s))
6991 endif
6992
6993 if(twofl_coll_inc_ionrec) then
6994 tmp(ixo^s) = tmp(ixo^s) - gamma_ion(ixo^s)/rn * tmp4(ixo^s) + gamma_rec(ixo^s)/rc * tmp5(ixo^s)
6995 endif
6996
6997 w(ixo^s,e_n_) = w(ixo^s,e_n_)+tmp(ixo^s)
6998 w(ixo^s,e_c_) = w(ixo^s,e_c_)-tmp(ixo^s)
6999 endif
7000 if(twofl_coll_inc_ionrec) then
7001 deallocate(gamma_ion, gamma_rec)
7002 endif
7003 if(phys_internal_e) then
7004 deallocate(v_n, v_c)
7005 endif
7006 if(twofl_equi_thermal) then
7007 deallocate(rho_n1, rho_c1)
7008 endif
7009 !set contribution to mag field
7010 w(ixo^s,mag(1:ndir)) = 0d0
7011
7012 end subroutine coll_terms
7013
7014 subroutine twofl_explicit_coll_terms_update(qdt,ixI^L,ixO^L,w,wCT,x)
7016
7017 integer, intent(in) :: ixi^l, ixo^l
7018 double precision, intent(in) :: qdt, x(ixi^s,1:ndim)
7019 double precision, intent(inout) :: w(ixi^s,1:nw)
7020 double precision, intent(in) :: wct(ixi^s,1:nw)
7021
7022 integer :: idir
7023 double precision :: tmp(ixi^s),tmp1(ixi^s),tmp2(ixi^s),tmp3(ixi^s),tmp4(ixi^s),tmp5(ixi^s)
7024 double precision :: v_c(ixi^s,ndir), v_n(ixi^s,ndir)
7025 double precision :: rhon(ixi^s), rhoc(ixi^s), alpha(ixi^s)
7026 double precision, allocatable :: gamma_rec(:^d&), gamma_ion(:^D&)
7027
7028 call get_rhon_tot(wct,x,ixi^l,ixo^l,rhon)
7029 call get_rhoc_tot(wct,x,ixi^l,ixo^l,rhoc)
7030 !update density
7031 if(twofl_coll_inc_ionrec) then
7032 allocate(gamma_ion(ixi^s), gamma_rec(ixi^s))
7033 call get_gamma_ion_rec(ixi^l, ixo^l, wct, x, gamma_rec, gamma_ion)
7034 tmp(ixo^s) = qdt *(-gamma_ion(ixo^s) * rhon(ixo^s) + &
7035 gamma_rec(ixo^s) * rhoc(ixo^s))
7036 w(ixo^s,rho_n_) = w(ixo^s,rho_n_) + tmp(ixo^s)
7037 w(ixo^s,rho_c_) = w(ixo^s,rho_c_) - tmp(ixo^s)
7038 endif
7039
7040 call get_alpha_coll(ixi^l, ixo^l, wct, x, alpha)
7041
7042 ! momentum update
7043 do idir=1,ndir
7044
7045 tmp(ixo^s) = alpha(ixo^s)* (-rhoc(ixo^s) * wct(ixo^s,mom_n(idir)) + rhon(ixo^s) * wct(ixo^s,mom_c(idir)))
7046 if(twofl_coll_inc_ionrec) then
7047 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))
7048 endif
7049 tmp(ixo^s) =tmp(ixo^s) * qdt
7050
7051 w(ixo^s,mom_n(idir)) = w(ixo^s,mom_n(idir)) + tmp(ixo^s)
7052 w(ixo^s,mom_c(idir)) = w(ixo^s,mom_c(idir)) - tmp(ixo^s)
7053 enddo
7054
7055 ! energy update
7056
7057 ! kinetic energy update
7058 if(.not. phys_internal_e) then
7059 ! E_tot includes kinetic energy
7060 tmp1(ixo^s) = twofl_kin_en_n(wct,ixi^l,ixo^l)
7061 tmp2(ixo^s) = twofl_kin_en_c(wct,ixi^l,ixo^l)
7062 tmp4(ixo^s) = wct(ixo^s,e_n_) - tmp1(ixo^s) !E_tot - E_kin
7063 tmp5(ixo^s) = wct(ixo^s,e_c_) - tmp2(ixo^s)
7064 if(phys_total_energy) then
7065 tmp5(ixo^s) = tmp5(ixo^s) - twofl_mag_en(wct,ixi^l,ixo^l)
7066 endif
7067
7068 tmp(ixo^s) = alpha(ixo^s)*(-rhoc(ixo^s) * tmp1(ixo^s) + rhon(ixo^s) * tmp2(ixo^s))
7069 if(twofl_coll_inc_ionrec) then
7070 tmp(ixo^s) = tmp(ixo^s) - gamma_ion(ixo^s) * tmp1(ixo^s) + gamma_rec(ixo^s) * tmp2(ixo^s)
7071 endif
7072 tmp(ixo^s) =tmp(ixo^s) * qdt
7073
7074 w(ixo^s,e_n_) = w(ixo^s,e_n_) + tmp(ixo^s)
7075 w(ixo^s,e_c_) = w(ixo^s,e_c_) - tmp(ixo^s)
7076
7077 else
7078 tmp4(ixo^s) = w(ixo^s,e_n_)
7079 tmp5(ixo^s) = w(ixo^s,e_c_)
7080 call twofl_get_v_n(wct,x,ixi^l,ixo^l,v_n)
7081 call twofl_get_v_c(wct,x,ixi^l,ixo^l,v_c)
7082 tmp1(ixo^s) = alpha(ixo^s) * rhoc(ixo^s) * rhon(ixo^s)
7083 tmp2(ixo^s) = tmp1(ixo^s)
7084 if(twofl_coll_inc_ionrec) then
7085 tmp1(ixo^s) = tmp1(ixo^s) + rhoc(ixo^s) * gamma_rec(ixo^s)
7086 tmp2(ixo^s) = tmp2(ixo^s) + rhon(ixo^s) * gamma_ion(ixo^s)
7087 endif
7088
7089 tmp(ixo^s) = 0.5d0 * sum((v_c(ixo^s,1:ndir) - v_n(ixo^s,1:ndir))**2, dim=ndim+1) * qdt
7090 w(ixo^s,e_n_) = w(ixo^s,e_n_) + tmp(ixo^s)*tmp1(ixo^s)
7091 w(ixo^s,e_c_) = w(ixo^s,e_c_) + tmp(ixo^s)*tmp2(ixo^s)
7092 endif
7093
7094 !update internal energy
7095 if(twofl_coll_inc_te) then
7096 if(has_equi_pe_n0) then
7097 tmp2(ixo^s)= block%equi_vars(ixo^s,equi_pe_n0_,0)*inv_gamma_1
7098 endif
7099 if(has_equi_pe_c0) then
7100 tmp3(ixo^s)=block%equi_vars(ixo^s,equi_pe_c0_,0)*inv_gamma_1
7101 endif
7102 if (twofl_equi_thermal) then
7103 tmp(ixo^s) = alpha(ixo^s) *(-1d0/rn*(rhoc(ixo^s) * tmp4(ixo^s) + &
7104 tmp2(ixo^s)*wct(ixo^s,rho_c_)) + 1d0/rc*(rhon(ixo^s) * tmp5(ixo^s) +&
7105 tmp3(ixo^s)*wct(ixo^s,rho_n_)))
7106 endif
7107 if(has_equi_pe_n0) then
7108 tmp4(ixo^s) = tmp2(ixo^s) + tmp4(ixo^s)
7109 endif
7110 if(has_equi_pe_c0) then
7111 tmp5(ixo^s) = tmp3(ixo^s) + tmp5(ixo^s)
7112 endif
7113 if (.not. twofl_equi_thermal) then
7114 tmp(ixo^s) = alpha(ixo^s) *(-rhoc(ixo^s)/rn * tmp4(ixo^s) + rhon(ixo^s)/rc * tmp5(ixo^s))
7115 endif
7116
7117 if(twofl_coll_inc_ionrec) then
7118 tmp(ixo^s) = tmp(ixo^s) - gamma_ion(ixo^s)/rn * tmp4(ixo^s) + gamma_rec(ixo^s)/rc * tmp5(ixo^s)
7119 endif
7120
7121 tmp(ixo^s) =tmp(ixo^s) * qdt
7122
7123 w(ixo^s,e_n_) = w(ixo^s,e_n_)+tmp(ixo^s)
7124 w(ixo^s,e_c_) = w(ixo^s,e_c_)-tmp(ixo^s)
7125 endif
7126 if(twofl_coll_inc_ionrec) then
7127 deallocate(gamma_ion, gamma_rec)
7128 endif
7129 end subroutine twofl_explicit_coll_terms_update
7130
7131 subroutine rfactor_c(w,x,ixI^L,ixO^L,Rfactor)
7133 integer, intent(in) :: ixi^l, ixo^l
7134 double precision, intent(in) :: w(ixi^s,1:nw)
7135 double precision, intent(in) :: x(ixi^s,1:ndim)
7136 double precision, intent(out):: rfactor(ixi^s)
7137
7138 rfactor(ixo^s)=rc
7139
7140 end subroutine rfactor_c
7141
7142end 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
subroutine, public get_divb(w, ixil, ixol, divb, nth_in)
Calculate div B within ixO.
integer, dimension(:), allocatable, public mag
Indices of the magnetic field.
Module with geometry-related routines (e.g., divergence, curl)
Definition mod_geometry.t:2
subroutine divvector(qvec, ixil, ixol, divq, nth_in)
integer coordinate
Definition mod_geometry.t:7
integer, parameter spherical
integer, parameter cylindrical
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 gradient(q, ixil, ixol, idir, gradq, nth_in)
subroutine gradientf(q, x, ixil, ixol, idir, gradq, nth_in, pm_in)
subroutine gradientl(q, ixil, ixol, idir, gradq)
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, protected twofl_divb_nth
Whether divB is computed with a fourth order approximation.
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|
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