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