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