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