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