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