MPI-AMRVAC 3.1
The MPI - Adaptive Mesh Refinement - Versatile Advection Code (development version)
Loading...
Searching...
No Matches
mod_rmhd_phys.t
Go to the documentation of this file.
1!> Radiation-magneto-hydrodynamics module
3
4#include "amrvac.h"
5
6 use mod_global_parameters, only: std_len, const_c
10 use mod_comm_lib, only: mpistop
12
13 implicit none
14 private
15
16 !> The adiabatic index
17 double precision, public :: rmhd_gamma = 5.d0/3.0d0
18 !> The adiabatic constant
19 double precision, public :: rmhd_adiab = 1.0d0
20 !> The MHD resistivity
21 double precision, public :: rmhd_eta = 0.0d0
22 !> The MHD hyper-resistivity
23 double precision, public :: rmhd_eta_hyper = 0.0d0
24 !> Hall resistivity
25 double precision, public :: rmhd_etah = 0.0d0
26 !> The small_est allowed energy
27 double precision, protected :: small_e
28 !> The smallest allowed radiation energy
29 double precision, public, protected :: small_r_e = 0.d0
30 !> Height of the mask used in the TRAC method
31 double precision, public, protected :: rmhd_trac_mask = 0.d0
32 !> GLM-MHD parameter: ratio of the diffusive and advective time scales for div b
33 !> taking values within [0, 1]
34 double precision, public :: rmhd_glm_alpha = 0.5d0
35 !> The thermal conductivity kappa in hyperbolic thermal conduction
36 double precision, public :: hypertc_kappa
37 !> Coefficient of diffusive divB cleaning
38 double precision :: divbdiff = 0.8d0
39 !> Helium abundance over Hydrogen
40 double precision, public, protected :: he_abundance=0.1d0
41 !> Ionization fraction of H
42 !> H_ion_fr = H+/(H+ + H)
43 double precision, public, protected :: h_ion_fr=1d0
44 !> Ionization fraction of He
45 !> He_ion_fr = (He2+ + He+)/(He2+ + He+ + He)
46 double precision, public, protected :: he_ion_fr=1d0
47 !> Ratio of number He2+ / number He+ + He2+
48 !> He_ion_fr2 = He2+/(He2+ + He+)
49 double precision, public, protected :: he_ion_fr2=1d0
50 ! used for eq of state when it is not defined by units,
51 ! the units do not contain terms related to ionization fraction
52 ! and it is p = RR * rho * T
53 double precision, public, protected :: rr=1d0
54 !> gamma minus one and its inverse
55 double precision :: gamma_1, inv_gamma_1
56 !> inverse of squared speed of light c0 and reduced speed of light c
57 double precision :: inv_squared_c0, inv_squared_c
58 !> equi vars indices in the state%equi_vars array
59 integer, public :: equi_rho0_ = -1
60 integer, public :: equi_pe0_ = -1
61 !> Number of tracer species
62 integer, public, protected :: rmhd_n_tracer = 0
63 !> Index of the density (in the w array)
64 integer, public, protected :: rho_
65 !> Indices of the momentum density
66 integer, allocatable, public, protected :: mom(:)
67 !> Indices of the momentum density for the form of better vectorization
68 integer, public, protected :: ^c&m^C_
69 !> Index of the energy density (-1 if not present)
70 integer, public, protected :: e_
71 !> Index of the radiation energy
72 integer, public, protected :: r_e
73 !> Indices of the magnetic field for the form of better vectorization
74 integer, public, protected :: ^c&b^C_
75 !> Index of the gas pressure (-1 if not present) should equal e_
76 integer, public, protected :: p_
77 !> Index of the heat flux q
78 integer, public, protected :: q_
79 !> Indices of the GLM psi
80 integer, public, protected :: psi_
81 !> Indices of temperature
82 integer, public, protected :: te_
83 !> Index of the cutoff temperature for the TRAC method
84 integer, public, protected :: tcoff_
85 integer, public, protected :: tweight_
86 !> Indices of the tracers
87 integer, allocatable, public, protected :: tracer(:)
88 !> The number of waves
89 integer :: nwwave=8
90 !> Method type in a integer for good performance
91 integer :: type_divb
92 !> To skip * layer of ghost cells during divB=0 fix for boundary
93 integer, public, protected :: boundary_divbfix_skip(2*^nd)=0
94 ! DivB cleaning methods
95 integer, parameter :: divb_none = 0
96 integer, parameter :: divb_multigrid = -1
97 integer, parameter :: divb_glm = 1
98 integer, parameter :: divb_powel = 2
99 integer, parameter :: divb_janhunen = 3
100 integer, parameter :: divb_linde = 4
101 integer, parameter :: divb_lindejanhunen = 5
102 integer, parameter :: divb_lindepowel = 6
103 integer, parameter :: divb_lindeglm = 7
104 integer, parameter :: divb_ct = 8
105 !> Whether an energy equation is used
106 logical, public, protected :: rmhd_energy = .true.
107 !> Whether thermal conduction is used
108 logical, public, protected :: rmhd_thermal_conduction = .false.
109 !> Whether thermal conduction is used
110 logical, public, protected :: rmhd_hyperbolic_thermal_conduction = .false.
111 !> Whether viscosity is added
112 logical, public, protected :: rmhd_viscosity = .false.
113 !> Whether gravity is added
114 logical, public, protected :: rmhd_gravity = .false.
115 !> Whether particles module is added
116 logical, public, protected :: rmhd_particles = .false.
117 !> Whether GLM-MHD is used to control div B
118 logical, public, protected :: rmhd_glm = .false.
119 !> Whether extended GLM-MHD is used with additional sources
120 logical, public, protected :: rmhd_glm_extended = .true.
121 !> Whether TRAC method is used
122 logical, public, protected :: rmhd_trac = .false.
123 !> Which TRAC method is used
124 integer, public, protected :: rmhd_trac_type=1
125 !> Distance between two adjacent traced magnetic field lines (in finest cell size)
126 integer, public, protected :: rmhd_trac_finegrid=4
127 !> Whether divB cleaning sources are added splitting from fluid solver
128 logical, public, protected :: source_split_divb = .false.
129 !> Whether plasma is partially ionized
130 logical, public, protected :: rmhd_partial_ionization = .false.
131 !> Whether CAK radiation line force is activated
132 logical, public, protected :: rmhd_cak_force = .false.
133 !> MHD fourth order
134 logical, public, protected :: rmhd_4th_order = .false.
135 !> whether split off equilibrium density
136 logical, public :: has_equi_rho0 = .false.
137 !> whether split off equilibrium thermal pressure
138 logical, public :: has_equi_pe0 = .false.
139 logical, public :: rmhd_equi_thermal = .false.
140 !> whether dump full variables (when splitting is used) in a separate dat file
141 logical, public, protected :: rmhd_dump_full_vars = .false.
142 !> Whether divB is computed with a fourth order approximation
143 integer, public, protected :: rmhd_divb_nth = 1
144 !> Use a compact way to add resistivity
145 logical :: compactres = .false.
146 !> Add divB wave in Roe solver
147 logical, public :: divbwave = .true.
148 !> clean initial divB
149 logical, public :: clean_initial_divb = .false.
150 !> Formalism to treat radiation
151 character(len=8), public :: rmhd_radiation_formalism = 'fld'
152 !> In the case of no rmhd_energy, how to compute pressure
153 character(len=8), public :: rmhd_pressure = 'Trad'
154 !> Treat radiation fld_Rad_force
155 logical, public, protected :: rmhd_radiation_force = .true.
156 !> Treat radiation-gas energy interaction
157 logical, public, protected :: rmhd_energy_interact = .true.
158 !> Treat radiation energy diffusion
159 logical, public, protected :: rmhd_radiation_diffusion = .true.
160 !> Treat radiation advection
161 logical, public, protected :: rmhd_radiation_advection = .true.
162 !> Do a running mean over the radiation pressure when determining dt
163 logical, protected :: radio_acoustic_filter = .false.
164 integer, protected :: size_ra_filter = 1
165 !> kb/(m_p mu)* 1/a_rad**4,
166 double precision, public :: kbmpmua4
167 !> Use the speed of light to calculate the timestep, usefull for debugging
168 logical :: dt_c = .false.
169 ! remove the below flag and assume default value = .false.
170 ! when eq state properly implemented everywhere
171 ! and not anymore through units
172 logical, public, protected :: eq_state_units = .true.
173 !> To control divB=0 fix for boundary
174 logical, public, protected :: boundary_divbfix(2*^nd)=.true.
175 !> B0 field is force-free
176 logical, public, protected :: b0field_forcefree=.true.
177 !> Whether an total energy equation is used
178 logical :: total_energy = .true.
179 !> Whether an internal or hydrodynamic energy equation is used
180 logical, public :: partial_energy = .false.
181 !> Whether gravity work is included in energy equation
182 logical :: gravity_energy
183 !> gravity work is calculated use density times velocity or conservative momentum
184 logical :: gravity_rhov = .false.
185 !> Method type to clean divergence of B
186 character(len=std_len), public, protected :: typedivbfix = 'linde'
187 !> Method type of constrained transport
188 character(len=std_len), public, protected :: type_ct = 'uct_contact'
189 !> Update all equations due to divB cleaning
190 character(len=std_len) :: typedivbdiff = 'all'
191 !> type of fluid for thermal conduction
192 type(tc_fluid), public, allocatable :: tc_fl
193 !> type of fluid for thermal emission synthesis
194 type(te_fluid), public, allocatable :: te_fl_rmhd
195
196 procedure(sub_convert), pointer :: rmhd_to_primitive => null()
197 procedure(sub_convert), pointer :: rmhd_to_conserved => null()
198 procedure(sub_small_values), pointer :: rmhd_handle_small_values => null()
199 procedure(sub_get_pthermal), pointer :: rmhd_get_pthermal => null()
200 procedure(sub_get_pthermal), pointer :: rmhd_get_rfactor => null()
201 procedure(sub_get_pthermal), pointer :: rmhd_get_temperature=> null()
202 ! Public methods
203 public :: rmhd_phys_init
204 public :: rmhd_get_pthermal
205 public :: rmhd_get_temperature
206 public :: rmhd_get_v
207 public :: rmhd_get_rho
208 public :: rmhd_to_conserved
209 public :: rmhd_to_primitive
210 public :: rmhd_e_to_ei
211 public :: rmhd_ei_to_e
212 public :: rmhd_face_to_center
213 public :: get_divb
214 public :: get_current
215 public :: get_normalized_divb
217 public :: rmhd_mag_en_all
218 {^nooned
220 }
221 public :: rmhd_get_pradiation
223 public :: rmhd_get_tgas
224 public :: rmhd_get_trad
225 public :: rmhd_set_mg_bounds
226
227contains
228
229 !> Read this module"s parameters from a file
230 subroutine rmhd_read_params(files)
232 use mod_particles, only: particles_eta, particles_etah
233 character(len=*), intent(in) :: files(:)
234 integer :: n
235
236 namelist /rmhd_list/ rmhd_energy, rmhd_n_tracer, rmhd_gamma, rmhd_adiab,&
240 typedivbdiff, type_ct, compactres, divbwave, he_abundance,&
243 particles_eta, particles_etah,has_equi_rho0, has_equi_pe0,rmhd_equi_thermal,&
249 rmhd_radiation_advection, radio_acoustic_filter, size_ra_filter, dt_c
250
251 do n = 1, size(files)
252 open(unitpar, file=trim(files(n)), status="old")
253 read(unitpar, rmhd_list, end=111)
254111 close(unitpar)
255 end do
256
257 end subroutine rmhd_read_params
258
259 !> Write this module's parameters to a snapsoht
260 subroutine rmhd_write_info(fh)
262 integer, intent(in) :: fh
263 integer :: er
264 integer, parameter :: n_par = 1
265 double precision :: values(n_par)
266 integer, dimension(MPI_STATUS_SIZE) :: st
267 character(len=name_len) :: names(n_par)
268
269 call mpi_file_write(fh, n_par, 1, mpi_integer, st, er)
270
271 names(1) = "gamma"
272 values(1) = rmhd_gamma
273 call mpi_file_write(fh, values, n_par, mpi_double_precision, st, er)
274 call mpi_file_write(fh, names, n_par * name_len, mpi_character, st, er)
275 end subroutine rmhd_write_info
276
277 subroutine rmhd_phys_init()
281 use mod_gravity, only: gravity_init
282 use mod_particles, only: particles_init, particles_eta, particles_etah
283 use mod_fld
284 use mod_afld
287 use mod_cak_force, only: cak_init
290 {^nooned
292 }
293
294 integer :: itr, idir
295
296 call rmhd_read_params(par_files)
297
298 if(.not.eq_state_units) then
301 if(mype==0) write(*,*) 'WARNING: set rmhd_partial_ionization=F when eq_state_units=F'
302 end if
303 end if
304
307 if(mype==0) write(*,*) 'WARNING: turn off parabolic TC when using hyperbolic TC'
308 end if
309
310 physics_type = "rmhd"
311 phys_energy=rmhd_energy
314 phys_partial_ionization=rmhd_partial_ionization
315
316 phys_gamma = rmhd_gamma
318
319 if(rmhd_energy) then
320 partial_energy=.false.
321 total_energy=.true.
322 else
323 total_energy=.false.
324 end if
325 phys_total_energy=total_energy
326 if(rmhd_energy) then
327 gravity_energy=.true.
328 if(has_equi_rho0) then
329 gravity_rhov=.true.
330 end if
331 else
332 gravity_energy=.false.
333 end if
334
335 {^ifoned
336 if(rmhd_trac .and. rmhd_trac_type .gt. 2) then
338 if(mype==0) write(*,*) 'WARNING: reset rmhd_trac_type=1 for 1D simulation'
339 end if
340 }
341 if(rmhd_trac .and. rmhd_trac_type .le. 4) then
342 rmhd_trac_mask=bigdouble
343 if(mype==0) write(*,*) 'WARNING: set rmhd_trac_mask==bigdouble for global TRAC method'
344 end if
346
347 ! set default gamma for polytropic/isothermal process
349 if(ndim==1) typedivbfix='none'
350 select case (typedivbfix)
351 case ('none')
352 type_divb = divb_none
353 {^nooned
354 case ('multigrid')
355 type_divb = divb_multigrid
356 use_multigrid = .true.
357 mg%operator_type = mg_laplacian
358 phys_global_source_after => rmhd_clean_divb_multigrid
359 }
360 case ('glm')
361 rmhd_glm = .true.
362 need_global_cmax = .true.
363 type_divb = divb_glm
364 case ('powel', 'powell')
365 type_divb = divb_powel
366 case ('janhunen')
367 type_divb = divb_janhunen
368 case ('linde')
369 type_divb = divb_linde
370 case ('lindejanhunen')
371 type_divb = divb_lindejanhunen
372 case ('lindepowel')
373 type_divb = divb_lindepowel
374 case ('lindeglm')
375 rmhd_glm = .true.
376 need_global_cmax = .true.
377 type_divb = divb_lindeglm
378 case ('ct')
379 type_divb = divb_ct
380 stagger_grid = .true.
381 case default
382 call mpistop('Unknown divB fix')
383 end select
384
385 allocate(start_indices(number_species),stop_indices(number_species))
386 ! set the index of the first flux variable for species 1
387 start_indices(1)=1
388 ! Determine flux variables
389 rho_ = var_set_rho()
390
391 allocate(mom(ndir))
392 mom(:) = var_set_momentum(ndir)
393 m^c_=mom(^c);
394
395 ! Set index of energy variable
396 if (rmhd_energy) then
397 nwwave = 8
398 e_ = var_set_energy() ! energy density
399 p_ = e_ ! gas pressure
400 else
401 nwwave = 7
402 e_ = -1
403 p_ = -1
404 end if
405
406 allocate(mag(ndir))
407 mag(:) = var_set_bfield(ndir)
408 b^c_=mag(^c);
409
410 if (rmhd_glm) then
411 psi_ = var_set_fluxvar('psi', 'psi', need_bc=.false.)
412 else
413 psi_ = -1
414 end if
415
416 !> set radiation energy
417 r_e = var_set_radiation_energy()
418
420 ! hyperbolic thermal conduction flux q
421 q_ = var_set_q()
422 need_global_cmax=.true.
423 else
424 q_=-1
425 end if
426
427 allocate(tracer(rmhd_n_tracer))
428 ! Set starting index of tracers
429 do itr = 1, rmhd_n_tracer
430 tracer(itr) = var_set_fluxvar("trc", "trp", itr, need_bc=.false.)
431 end do
432
433 !if(rmhd_hyperbolic_thermal_conduction) then
434 ! ! hyperbolic thermal conduction flux q
435 ! q_ = var_set_auxvar('q','q')
436 ! need_global_cmax=.true.
437 !else
438 ! q_=-1
439 !end if
440
441 ! set temperature as an auxiliary variable to get ionization degree
443 te_ = var_set_auxvar('Te','Te')
444 else
445 te_ = -1
446 end if
447
448 ! set number of variables which need update ghostcells
449 nwgc=nwflux+nwaux
450
451 ! set the index of the last flux variable for species 1
452 stop_indices(1)=nwflux
453
454 ! set cutoff temperature when using the TRAC method, as well as an auxiliary weight
455 tweight_ = -1
456 if(rmhd_trac) then
457 tcoff_ = var_set_wextra()
458 iw_tcoff=tcoff_
459 if(rmhd_trac_type .ge. 3) then
460 tweight_ = var_set_wextra()
461 endif
462 else
463 tcoff_ = -1
464 end if
465
466 ! set indices of equi vars and update number_equi_vars
468 if(has_equi_rho0) then
471 iw_equi_rho = equi_rho0_
472 endif
473 if(has_equi_pe0) then
476 iw_equi_p = equi_pe0_
477 endif
478 ! determine number of stagger variables
479 nws=ndim
480
481 nvector = 2 ! No. vector vars
482 allocate(iw_vector(nvector))
483 iw_vector(1) = mom(1) - 1 ! TODO: why like this?
484 iw_vector(2) = mag(1) - 1 ! TODO: why like this?
485
486 ! Check whether custom flux types have been defined
487 if (.not. allocated(flux_type)) then
488 allocate(flux_type(ndir, nwflux))
489 flux_type = flux_default
490 else if (any(shape(flux_type) /= [ndir, nwflux])) then
491 call mpistop("phys_check error: flux_type has wrong shape")
492 end if
493
494 if(nwflux>mag(ndir)) then
495 ! for flux of tracers, using hll flux
496 flux_type(:,mag(ndir)+1:nwflux)=flux_hll
497 end if
498
499 if(ndim>1) then
500 if(rmhd_glm) then
501 flux_type(:,psi_)=flux_special
502 do idir=1,ndir
503 flux_type(idir,mag(idir))=flux_special
504 end do
505 else
506 do idir=1,ndir
507 flux_type(idir,mag(idir))=flux_tvdlf
508 end do
509 end if
510 end if
511
512 phys_get_rho => rmhd_get_rho
513 phys_get_dt => rmhd_get_dt
514 phys_get_cmax => rmhd_get_cmax_origin
515 phys_get_a2max => rmhd_get_a2max
516 phys_get_tcutoff => rmhd_get_tcutoff
517 phys_get_h_speed => rmhd_get_h_speed
518 if(has_equi_rho0) then
519 phys_get_cbounds => rmhd_get_cbounds_split_rho
520 else
521 phys_get_cbounds => rmhd_get_cbounds
522 end if
523 if(has_equi_rho0) then
524 phys_to_primitive => rmhd_to_primitive_split_rho
525 rmhd_to_primitive => rmhd_to_primitive_split_rho
526 phys_to_conserved => rmhd_to_conserved_split_rho
527 rmhd_to_conserved => rmhd_to_conserved_split_rho
528 else
529 phys_to_primitive => rmhd_to_primitive_origin
530 rmhd_to_primitive => rmhd_to_primitive_origin
531 phys_to_conserved => rmhd_to_conserved_origin
532 rmhd_to_conserved => rmhd_to_conserved_origin
533 end if
534 if(b0field.or.has_equi_rho0.or.has_equi_pe0) then
535 phys_get_flux => rmhd_get_flux_split
536 else
537 phys_get_flux => rmhd_get_flux
538 end if
539 phys_get_v => rmhd_get_v
540 if(b0field.or.has_equi_rho0) then
541 phys_add_source_geom => rmhd_add_source_geom_split
542 else
543 phys_add_source_geom => rmhd_add_source_geom
544 end if
545 phys_add_source => rmhd_add_source
546 phys_check_params => rmhd_check_params
547 phys_write_info => rmhd_write_info
548
549 phys_handle_small_values => rmhd_handle_small_values_origin
550 rmhd_handle_small_values => rmhd_handle_small_values_origin
551 phys_check_w => rmhd_check_w_origin
552
553 phys_set_mg_bounds => rmhd_set_mg_bounds
554 phys_get_trad => rmhd_get_trad
555 phys_get_tgas => rmhd_get_tgas
556
557 phys_get_pthermal => rmhd_get_pthermal_origin
558 rmhd_get_pthermal => rmhd_get_pthermal_origin
559
560 if(number_equi_vars>0) then
561 phys_set_equi_vars => set_equi_vars_grid
562 endif
563
564 if(type_divb==divb_glm) then
565 phys_modify_wlr => rmhd_modify_wlr
566 end if
567
568 ! choose Rfactor in ideal gas law
570 rmhd_get_rfactor=>rfactor_from_temperature_ionization
571 phys_update_temperature => rmhd_update_temperature
572 else if(associated(usr_rfactor)) then
573 rmhd_get_rfactor=>usr_rfactor
574 else
575 rmhd_get_rfactor=>rfactor_from_constant_ionization
576 end if
577
579 rmhd_get_temperature => rmhd_get_temperature_from_te
580 else
581 if(has_equi_pe0 .and. has_equi_rho0) then
582 rmhd_get_temperature => rmhd_get_temperature_from_etot_with_equi
583 else
584 rmhd_get_temperature => rmhd_get_temperature_from_etot
585 end if
586 end if
587
588 ! if using ct stagger grid, boundary divb=0 is not done here
589 if(stagger_grid) then
590 phys_get_ct_velocity => rmhd_get_ct_velocity
591 phys_update_faces => rmhd_update_faces
592 phys_face_to_center => rmhd_face_to_center
593 phys_modify_wlr => rmhd_modify_wlr
594 else if(ndim>1) then
595 phys_boundary_adjust => rmhd_boundary_adjust
596 end if
597
598 {^nooned
599 ! clean initial divb
600 if(clean_initial_divb) phys_clean_divb => rmhd_clean_divb_multigrid
601 }
602
603 ! derive units from basic units
604 call rmhd_physical_units()
605
606 !> Initiate radiation-closure module
607 select case(rmhd_radiation_formalism)
608 case('fld')
610 case('afld')
612 case default
613 call mpistop('Radiation formalism unknown')
614 end select
615
618 end if
619 if(.not. rmhd_energy .and. rmhd_thermal_conduction) then
620 call mpistop("thermal conduction needs rmhd_energy=T")
621 end if
623 call mpistop("hyperbolic thermal conduction needs rmhd_energy=T")
624 end if
625
626 ! initialize thermal conduction module
628 call sts_init()
630
631 allocate(tc_fl)
632 call tc_get_mhd_params(tc_fl,tc_params_read_rmhd)
633 call add_sts_method(rmhd_get_tc_dt_rmhd,rmhd_sts_set_source_tc_rmhd,e_,1,e_,1,.false.)
634 if(has_equi_pe0 .and. has_equi_rho0) then
635 tc_fl%get_temperature_from_conserved => rmhd_get_temperature_from_etot_with_equi
636 else
637 tc_fl%get_temperature_from_conserved => rmhd_get_temperature_from_etot
638 end if
639 if(has_equi_pe0 .and. has_equi_rho0) then
640 tc_fl%get_temperature_from_eint => rmhd_get_temperature_from_eint_with_equi
641 if(rmhd_equi_thermal) then
642 tc_fl%has_equi = .true.
643 tc_fl%get_temperature_equi => rmhd_get_temperature_equi
644 tc_fl%get_rho_equi => rmhd_get_rho_equi
645 else
646 tc_fl%has_equi = .false.
647 end if
648 else
649 tc_fl%get_temperature_from_eint => rmhd_get_temperature_from_eint
650 end if
652 call set_error_handling_to_head(rmhd_tc_handle_small_e)
653 tc_fl%get_rho => rmhd_get_rho
654 tc_fl%e_ = e_
655 tc_fl%Tcoff_ = tcoff_
656 end if
657
658 allocate(te_fl_rmhd)
659 te_fl_rmhd%get_rho=> rmhd_get_rho
660 te_fl_rmhd%get_pthermal=> rmhd_get_pthermal
661 te_fl_rmhd%get_var_Rfactor => rmhd_get_rfactor
662{^ifthreed
663 phys_te_images => rmhd_te_images
664}
665 ! Initialize viscosity module
666 if (rmhd_viscosity) call viscosity_init(phys_wider_stencil)
667
668 ! Initialize gravity module
669 if(rmhd_gravity) then
670 call gravity_init()
671 end if
672
673 ! Initialize particles module
674 if(rmhd_particles) then
675 call particles_init()
676 if (particles_eta < zero) particles_eta = rmhd_eta
677 if (particles_etah < zero) particles_eta = rmhd_etah
678 if(mype==0) then
679 write(*,*) '*****Using particles: with rmhd_eta, rmhd_etah :', rmhd_eta, rmhd_etah
680 write(*,*) '*****Using particles: particles_eta, particles_etah :', particles_eta, particles_etah
681 end if
682 end if
683
684 ! initialize ionization degree table
686
687 ! Initialize CAK radiation force module
689 end subroutine rmhd_phys_init
690
691{^ifthreed
692 subroutine rmhd_te_images
695
696 select case(convert_type)
697 case('EIvtiCCmpi','EIvtuCCmpi')
699 case('ESvtiCCmpi','ESvtuCCmpi')
701 case('SIvtiCCmpi','SIvtuCCmpi')
703 case('WIvtiCCmpi','WIvtuCCmpi')
705 case default
706 call mpistop("Error in synthesize emission: Unknown convert_type")
707 end select
708 end subroutine rmhd_te_images
709}
710
711!!start th cond
712 ! wrappers for STS functions in thermal_conductivity module
713 ! which take as argument the tc_fluid (defined in the physics module)
714 subroutine rmhd_sts_set_source_tc_rmhd(ixI^L,ixO^L,w,x,wres,fix_conserve_at_step,my_dt,igrid,nflux)
718 integer, intent(in) :: ixi^l, ixo^l, igrid, nflux
719 double precision, intent(in) :: x(ixi^s,1:ndim)
720 double precision, intent(inout) :: wres(ixi^s,1:nw), w(ixi^s,1:nw)
721 double precision, intent(in) :: my_dt
722 logical, intent(in) :: fix_conserve_at_step
723 call sts_set_source_tc_mhd(ixi^l,ixo^l,w,x,wres,fix_conserve_at_step,my_dt,igrid,nflux,tc_fl)
724 end subroutine rmhd_sts_set_source_tc_rmhd
725
726 function rmhd_get_tc_dt_rmhd(w,ixI^L,ixO^L,dx^D,x) result(dtnew)
727 !Check diffusion time limit dt < dx_i**2/((gamma-1)*tc_k_para_i/rho)
728 !where tc_k_para_i=tc_k_para*B_i**2/B**2
729 !and T=p/rho
732 integer, intent(in) :: ixi^l, ixo^l
733 double precision, intent(in) :: dx^d, x(ixi^s,1:ndim)
734 double precision, intent(in) :: w(ixi^s,1:nw)
735 double precision :: dtnew
736
737 dtnew=get_tc_dt_mhd(w,ixi^l,ixo^l,dx^d,x,tc_fl)
738 end function rmhd_get_tc_dt_rmhd
739
740 subroutine rmhd_tc_handle_small_e(w, x, ixI^L, ixO^L, step)
742 integer, intent(in) :: ixi^l,ixo^l
743 double precision, intent(inout) :: w(ixi^s,1:nw)
744 double precision, intent(in) :: x(ixi^s,1:ndim)
745 integer, intent(in) :: step
746 character(len=140) :: error_msg
747
748 write(error_msg,"(a,i3)") "Thermal conduction step ", step
749 call rmhd_handle_small_ei(w,x,ixi^l,ixo^l,e_,error_msg)
750 end subroutine rmhd_tc_handle_small_e
751
752 ! fill in tc_fluid fields from namelist
753 subroutine tc_params_read_rmhd(fl)
755 type(tc_fluid), intent(inout) :: fl
756 double precision :: tc_k_para=0d0
757 double precision :: tc_k_perp=0d0
758 integer :: n
759 ! list parameters
760 logical :: tc_perpendicular=.false.
761 logical :: tc_saturate=.false.
762 character(len=std_len) :: tc_slope_limiter="MC"
763
764 namelist /tc_list/ tc_perpendicular, tc_saturate, tc_slope_limiter, tc_k_para, tc_k_perp
765
766 do n = 1, size(par_files)
767 open(unitpar, file=trim(par_files(n)), status="old")
768 read(unitpar, tc_list, end=111)
769111 close(unitpar)
770 end do
771
772 fl%tc_perpendicular = tc_perpendicular
773 fl%tc_saturate = tc_saturate
774 fl%tc_k_para = tc_k_para
775 fl%tc_k_perp = tc_k_perp
776 select case(tc_slope_limiter)
777 case ('no','none')
778 fl%tc_slope_limiter = 0
779 case ('MC')
780 ! montonized central limiter Woodward and Collela limiter (eq.3.51h), a factor of 2 is pulled out
781 fl%tc_slope_limiter = 1
782 case('minmod')
783 ! minmod limiter
784 fl%tc_slope_limiter = 2
785 case ('superbee')
786 ! Roes superbee limiter (eq.3.51i)
787 fl%tc_slope_limiter = 3
788 case ('koren')
789 ! Barry Koren Right variant
790 fl%tc_slope_limiter = 4
791 case default
792 call mpistop("Unknown tc_slope_limiter, choose MC, minmod")
793 end select
794 end subroutine tc_params_read_rmhd
795!!end th cond
796
797 !> sets the equilibrium variables
798 subroutine set_equi_vars_grid_faces(igrid,x,ixI^L,ixO^L)
801 integer, intent(in) :: igrid, ixi^l, ixo^l
802 double precision, intent(in) :: x(ixi^s,1:ndim)
803 double precision :: delx(ixi^s,1:ndim)
804 double precision :: xc(ixi^s,1:ndim),xshift^d
805 integer :: idims, ixc^l, hxo^l, ix, idims2
806
807 if(slab_uniform)then
808 ^d&delx(ixi^s,^d)=rnode(rpdx^d_,igrid)\
809 else
810 ! for all non-cartesian and stretched cartesian coordinates
811 delx(ixi^s,1:ndim)=ps(igrid)%dx(ixi^s,1:ndim)
812 endif
813
814 do idims=1,ndim
815 hxo^l=ixo^l-kr(idims,^d);
816 if(stagger_grid) then
817 ! ct needs all transverse cells
818 ixcmax^d=ixomax^d+nghostcells-nghostcells*kr(idims,^d); ixcmin^d=hxomin^d-nghostcells+nghostcells*kr(idims,^d);
819 else
820 ! ixC is centered index in the idims direction from ixOmin-1/2 to ixOmax+1/2
821 ixcmax^d=ixomax^d; ixcmin^d=hxomin^d;
822 end if
823 ! always xshift=0 or 1/2
824 xshift^d=half*(one-kr(^d,idims));
825 do idims2=1,ndim
826 select case(idims2)
827 {case(^d)
828 do ix = ixc^lim^d
829 ! xshift=half: this is the cell center coordinate
830 ! xshift=0: this is the cell edge i+1/2 coordinate
831 xc(ix^d%ixC^s,^d)=x(ix^d%ixC^s,^d)+(half-xshift^d)*delx(ix^d%ixC^s,^d)
832 end do\}
833 end select
834 end do
835 call usr_set_equi_vars(ixi^l,ixc^l,xc,ps(igrid)%equi_vars(ixi^s,1:number_equi_vars,idims))
836 end do
837 end subroutine set_equi_vars_grid_faces
838
839 !> sets the equilibrium variables
840 subroutine set_equi_vars_grid(igrid)
843 integer, intent(in) :: igrid
844
845 !values at the center
846 call usr_set_equi_vars(ixg^ll,ixg^ll,ps(igrid)%x,ps(igrid)%equi_vars(ixg^t,1:number_equi_vars,0))
847
848 !values at the interfaces
849 call set_equi_vars_grid_faces(igrid,ps(igrid)%x,ixg^ll,ixm^ll)
850 end subroutine set_equi_vars_grid
851
852 ! w, wnew conserved, add splitted variables back to wnew
853 function convert_vars_splitting(ixI^L,ixO^L, w, x, nwc) result(wnew)
855 integer, intent(in) :: ixi^l,ixo^l, nwc
856 double precision, intent(in) :: w(ixi^s, 1:nw)
857 double precision, intent(in) :: x(ixi^s,1:ndim)
858 double precision :: wnew(ixo^s, 1:nwc)
859
860 if(has_equi_rho0) then
861 wnew(ixo^s,rho_)=w(ixo^s,rho_)+block%equi_vars(ixo^s,equi_rho0_,0)
862 else
863 wnew(ixo^s,rho_)=w(ixo^s,rho_)
864 endif
865 wnew(ixo^s,mom(:))=w(ixo^s,mom(:))
866
867 if (b0field) then
868 ! add background magnetic field B0 to B
869 wnew(ixo^s,mag(1:ndir))=w(ixo^s,mag(1:ndir))+block%B0(ixo^s,1:ndir,0)
870 else
871 wnew(ixo^s,mag(1:ndir))=w(ixo^s,mag(1:ndir))
872 end if
873
874 if(rmhd_energy) then
875 wnew(ixo^s,e_)=w(ixo^s,e_)
876 if(has_equi_pe0) then
877 wnew(ixo^s,e_)=wnew(ixo^s,e_)+block%equi_vars(ixo^s,equi_pe0_,0)*inv_gamma_1
878 end if
879 if(b0field .and. total_energy) then
880 wnew(ixo^s,e_)=wnew(ixo^s,e_)+0.5d0*sum(block%B0(ixo^s,:,0)**2,dim=ndim+1) &
881 + sum(w(ixo^s,mag(:))*block%B0(ixo^s,:,0),dim=ndim+1)
882 end if
883 end if
884 end function convert_vars_splitting
885
886 subroutine rmhd_check_params
890
891 ! after user parameter setting
892 gamma_1=rmhd_gamma-1.d0
893 if (.not. rmhd_energy) then
894 if (rmhd_gamma <= 0.0d0) call mpistop ("Error: rmhd_gamma <= 0")
895 if (rmhd_adiab < 0.0d0) call mpistop ("Error: rmhd_adiab < 0")
897 else
898 if (rmhd_gamma <= 0.0d0 .or. rmhd_gamma == 1.0d0) &
899 call mpistop ("Error: rmhd_gamma <= 0 or rmhd_gamma == 1")
900 inv_gamma_1=1.d0/gamma_1
901 small_e = small_pressure * inv_gamma_1
902 end if
903
905
906 if (number_equi_vars > 0 .and. .not. associated(usr_set_equi_vars)) then
907 call mpistop("usr_set_equi_vars has to be implemented in the user file")
908 endif
909 if(convert .or. autoconvert) then
910 if(convert_type .eq. 'dat_generic_mpi') then
911 if(rmhd_dump_full_vars) then
912 if(mype .eq. 0) print*, " add conversion method: split -> full "
913 call add_convert_method(convert_vars_splitting, nw, cons_wnames, "new")
914 endif
915 endif
916 endif
917
919 end subroutine rmhd_check_params
920
921 !> Set the boundaries for the diffusion of E
926 integer :: ib
927
928 ! Set boundary conditions for the multigrid solver
929 do ib = 1, 2*ndim
930 select case (typeboundary(r_e, ib))
931 case (bc_symm)
932 ! d/dx u = 0
933 mg%bc(ib, mg_iphi)%bc_type = mg_bc_neumann
934 mg%bc(ib, mg_iphi)%bc_value = 0.0_dp
935 case (bc_asymm)
936 ! u = 0
937 mg%bc(ib, mg_iphi)%bc_type = mg_bc_dirichlet
938 mg%bc(ib, mg_iphi)%bc_value = 0.0_dp
939 case (bc_cont)
940 ! d/dx u = 0
941 ! mg%bc(iB, mg_iphi)%bc_type = mg_bc_continuous
942 mg%bc(ib, mg_iphi)%bc_type = mg_bc_neumann
943 mg%bc(ib, mg_iphi)%bc_value = 0.0_dp
944 case (bc_periodic)
945 ! Nothing to do here
946 case (bc_noinflow)
947 call usr_special_mg_bc(ib)
948 case (bc_special)
949 call usr_special_mg_bc(ib)
950 case default
951 call mpistop("divE_multigrid warning: unknown b.c. ")
952 end select
953 end do
954 end subroutine rmhd_set_mg_bounds
955
956 subroutine rmhd_physical_units()
958 double precision :: mp,kb,miu0,c_lightspeed
959 double precision :: a,b
960
961 ! Derive scaling units
962 if(si_unit) then
963 mp=mp_si
964 kb=kb_si
965 miu0=miu0_si
966 c_lightspeed=c_si
967 else
968 mp=mp_cgs
969 kb=kb_cgs
970 miu0=4.d0*dpi ! G^2 cm^2 dyne^-1
971 c_lightspeed=const_c
972 end if
973 if(eq_state_units) then
974 a=1d0+4d0*he_abundance
977 else
978 b=2d0+3d0*he_abundance
979 end if
980 rr=1d0
981 else
982 a=1d0
983 b=1d0
984 rr=(1d0+h_ion_fr+he_abundance*(he_ion_fr*(he_ion_fr2+1d0)+1d0))/(1d0+4d0*he_abundance)
985 end if
986 if(unit_density/=1.d0 .or. unit_numberdensity/=1.d0) then
987 if(unit_density/=1.d0) then
989 else if(unit_numberdensity/=1.d0) then
991 end if
992 if(unit_temperature/=1.d0) then
996 if(unit_length/=1.d0) then
998 else if(unit_time/=1.d0) then
1000 end if
1001 else if(unit_magneticfield/=1.d0) then
1005 if(unit_length/=1.d0) then
1007 else if(unit_time/=1.d0) then
1009 end if
1010 else if(unit_pressure/=1.d0) then
1014 if(unit_length/=1.d0) then
1016 else if(unit_time/=1.d0) then
1018 end if
1019 else if(unit_velocity/=1.d0) then
1023 if(unit_length/=1.d0) then
1025 else if(unit_time/=1.d0) then
1027 end if
1028 else if(unit_time/=1.d0) then
1033 end if
1034 else if(unit_temperature/=1.d0) then
1035 ! units of temperature and velocity are dependent
1036 if(unit_magneticfield/=1.d0) then
1041 if(unit_length/=1.d0) then
1043 else if(unit_time/=1.d0) then
1045 end if
1046 else if(unit_pressure/=1.d0) then
1051 if(unit_length/=1.d0) then
1053 else if(unit_time/=1.d0) then
1055 end if
1056 end if
1057 else if(unit_magneticfield/=1.d0) then
1058 ! units of magnetic field and pressure are dependent
1059 if(unit_velocity/=1.d0) then
1064 if(unit_length/=1.d0) then
1066 else if(unit_time/=1.d0) then
1068 end if
1069 else if(unit_time/=0.d0) then
1075 end if
1076 else if(unit_pressure/=1.d0) then
1077 if(unit_velocity/=1.d0) then
1082 if(unit_length/=1.d0) then
1084 else if(unit_time/=1.d0) then
1086 end if
1087 else if(unit_time/=0.d0) then
1093 end if
1094 end if
1095 ! Additional units needed for the particles
1096 c_norm=c_lightspeed/unit_velocity
1098 if (.not. si_unit) unit_charge = unit_charge*const_c
1100
1101 !> Units for radiative flux and opacity
1104 end subroutine rmhd_physical_units
1105
1106 subroutine rmhd_check_w_origin(primitive,ixI^L,ixO^L,w,flag)
1108 logical, intent(in) :: primitive
1109 integer, intent(in) :: ixi^l, ixo^l
1110 double precision, intent(in) :: w(ixi^s,nw)
1111 logical, intent(inout) :: flag(ixi^s,1:nw)
1112 double precision :: tmp
1113 integer :: ix^d
1114
1115 flag=.false.
1116 {do ix^db=ixomin^db,ixomax^db\}
1117 if(has_equi_rho0) then
1118 tmp=w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,0)
1119 else
1120 tmp=w(ix^d,rho_)
1121 end if
1122 if(tmp<small_density) flag(ix^d,rho_) = .true.
1123 if(primitive) then
1124 if(has_equi_pe0) then
1125 if(w(ix^d,p_)+block%equi_vars(ix^d,equi_pe0_,0)<small_pressure) flag(ix^d,e_) = .true.
1126 else
1127 if(w(ix^d,p_)<small_pressure) flag(ix^d,e_) = .true.
1128 end if
1129 else
1130 tmp=w(ix^d,e_)-half*((^c&w(ix^d,m^c_)**2+)/tmp+(^c&w(ix^d,b^c_)**2+))
1131 if(has_equi_pe0) then
1132 if(tmp+block%equi_vars(ix^d,equi_pe0_,0)*inv_gamma_1<small_e) flag(ix^d,e_) = .true.
1133 else
1134 if(tmp<small_e) flag(ix^d,e_) = .true.
1135 end if
1136 end if
1137 if(w(ix^d,r_e)<small_r_e) flag(ix^d,r_e) = .true.
1138 {end do\}
1139 end subroutine rmhd_check_w_origin
1140
1141 !> Transform primitive variables into conservative ones
1142 subroutine rmhd_to_conserved_origin(ixI^L,ixO^L,w,x)
1144 integer, intent(in) :: ixi^l, ixo^l
1145 double precision, intent(inout) :: w(ixi^s, nw)
1146 double precision, intent(in) :: x(ixi^s, 1:ndim)
1147 integer :: ix^d
1148
1149 {do ix^db=ixomin^db,ixomax^db\}
1150 ! Calculate total energy from pressure, kinetic and magnetic energy
1151 w(ix^d,e_)=w(ix^d,p_)*inv_gamma_1&
1152 +half*((^c&w(ix^d,m^c_)**2+)*w(ix^d,rho_)&
1153 +(^c&w(ix^d,b^c_)**2+))
1154 ! Convert velocity to momentum
1155 ^c&w(ix^d,m^c_)=w(ix^d,rho_)*w(ix^d,m^c_)\
1156 {end do\}
1157 end subroutine rmhd_to_conserved_origin
1158
1159 !> Transform primitive variables into conservative ones
1160 subroutine rmhd_to_conserved_split_rho(ixI^L,ixO^L,w,x)
1162 integer, intent(in) :: ixi^l, ixo^l
1163 double precision, intent(inout) :: w(ixi^s, nw)
1164 double precision, intent(in) :: x(ixi^s, 1:ndim)
1165 double precision :: rho
1166 integer :: ix^d
1167
1168 {do ix^db=ixomin^db,ixomax^db\}
1169 rho=w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,b0i)
1170 ! Calculate total energy from pressure, kinetic and magnetic energy
1171 w(ix^d,e_)=w(ix^d,p_)*inv_gamma_1&
1172 +half*((^c&w(ix^d,m^c_)**2+)*rho&
1173 +(^c&w(ix^d,b^c_)**2+))
1174 ! Convert velocity to momentum
1175 ^c&w(ix^d,m^c_)=rho*w(ix^d,m^c_)\
1176 {end do\}
1177 end subroutine rmhd_to_conserved_split_rho
1178
1179 !> Transform conservative variables into primitive ones
1180 subroutine rmhd_to_primitive_origin(ixI^L,ixO^L,w,x)
1182 integer, intent(in) :: ixi^l, ixo^l
1183 double precision, intent(inout) :: w(ixi^s, nw)
1184 double precision, intent(in) :: x(ixi^s, 1:ndim)
1185 double precision :: inv_rho
1186 integer :: ix^d
1187
1188 if (fix_small_values) then
1189 ! fix small values preventing NaN numbers in the following converting
1190 call rmhd_handle_small_values(.false., w, x, ixi^l, ixo^l, 'rmhd_to_primitive_origin')
1191 end if
1192
1193 {do ix^db=ixomin^db,ixomax^db\}
1194 inv_rho = 1.d0/w(ix^d,rho_)
1195 ! Convert momentum to velocity
1196 ^c&w(ix^d,m^c_)=w(ix^d,m^c_)*inv_rho\
1197 ! Calculate pressure = (gamma-1) * (e-ek-eb)
1198 w(ix^d,p_)=gamma_1*(w(ix^d,e_)&
1199 -half*(w(ix^d,rho_)*(^c&w(ix^d,m^c_)**2+)&
1200 +(^c&w(ix^d,b^c_)**2+)))
1201 {end do\}
1202 end subroutine rmhd_to_primitive_origin
1203
1204 !> Transform conservative variables into primitive ones
1205 subroutine rmhd_to_primitive_split_rho(ixI^L,ixO^L,w,x)
1207 integer, intent(in) :: ixi^l, ixo^l
1208 double precision, intent(inout) :: w(ixi^s, nw)
1209 double precision, intent(in) :: x(ixi^s, 1:ndim)
1210 double precision :: inv_rho
1211 integer :: ix^d
1212
1213 if (fix_small_values) then
1214 ! fix small values preventing NaN numbers in the following converting
1215 call rmhd_handle_small_values(.false., w, x, ixi^l, ixo^l, 'rmhd_to_primitive_split_rho')
1216 end if
1217
1218 {do ix^db=ixomin^db,ixomax^db\}
1219 inv_rho=1.d0/(w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,b0i))
1220 ! Convert momentum to velocity
1221 ^c&w(ix^d,m^c_)=w(ix^d,m^c_)*inv_rho\
1222 ! Calculate pressure = (gamma-1) * (e-ek-eb)
1223 w(ix^d,p_)=gamma_1*(w(ix^d,e_)&
1224 -half*((w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,b0i))*&
1225 (^c&w(ix^d,m^c_)**2+)+(^c&w(ix^d,b^c_)**2+)))
1226 {end do\}
1227 end subroutine rmhd_to_primitive_split_rho
1228
1229 !> Transform internal energy to total energy
1230 subroutine rmhd_ei_to_e(ixI^L,ixO^L,w,x)
1232 integer, intent(in) :: ixi^l, ixo^l
1233 double precision, intent(inout) :: w(ixi^s, nw)
1234 double precision, intent(in) :: x(ixi^s, 1:ndim)
1235
1236 integer :: ix^d
1237
1238 if(has_equi_rho0) then
1239 {do ix^db=ixomin^db,ixomax^db\}
1240 ! Calculate e = ei + ek + eb
1241 w(ix^d,e_)=w(ix^d,e_)&
1242 +half*((^c&w(ix^d,m^c_)**2+)/&
1243 (w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,0))&
1244 +(^c&w(ix^d,b^c_)**2+))
1245 {end do\}
1246 else
1247 {do ix^db=ixomin^db,ixomax^db\}
1248 ! Calculate e = ei + ek + eb
1249 w(ix^d,e_)=w(ix^d,e_)&
1250 +half*((^c&w(ix^d,m^c_)**2+)/w(ix^d,rho_)&
1251 +(^c&w(ix^d,b^c_)**2+))
1252 {end do\}
1253 end if
1254 end subroutine rmhd_ei_to_e
1255
1256 !> Transform total energy to internal energy
1257 subroutine rmhd_e_to_ei(ixI^L,ixO^L,w,x)
1259 integer, intent(in) :: ixi^l, ixo^l
1260 double precision, intent(inout) :: w(ixi^s, nw)
1261 double precision, intent(in) :: x(ixi^s, 1:ndim)
1262
1263 integer :: ix^d
1264
1265 if(has_equi_rho0) then
1266 {do ix^db=ixomin^db,ixomax^db\}
1267 ! Calculate ei = e - ek - eb
1268 w(ix^d,e_)=w(ix^d,e_)&
1269 -half*((^c&w(ix^d,m^c_)**2+)/&
1270 (w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,0))&
1271 +(^c&w(ix^d,b^c_)**2+))
1272 {end do\}
1273 else
1274 {do ix^db=ixomin^db,ixomax^db\}
1275 ! Calculate ei = e - ek - eb
1276 w(ix^d,e_)=w(ix^d,e_)&
1277 -half*((^c&w(ix^d,m^c_)**2+)/w(ix^d,rho_)&
1278 +(^c&w(ix^d,b^c_)**2+))
1279 {end do\}
1280 end if
1281
1282 if(fix_small_values) then
1283 call rmhd_handle_small_ei(w,x,ixi^l,ixi^l,e_,'rmhd_e_to_ei')
1284 end if
1285 end subroutine rmhd_e_to_ei
1286
1287 subroutine rmhd_handle_small_values_origin(primitive, w, x, ixI^L, ixO^L, subname)
1290 logical, intent(in) :: primitive
1291 integer, intent(in) :: ixi^l,ixo^l
1292 double precision, intent(inout) :: w(ixi^s,1:nw)
1293 double precision, intent(in) :: x(ixi^s,1:ndim)
1294 character(len=*), intent(in) :: subname
1295 double precision :: rho
1296 integer :: idir, ix^d
1297 logical :: flag(ixi^s,1:nw)
1298
1299 call phys_check_w(primitive, ixi^l, ixi^l, w, flag)
1300 if(any(flag)) then
1301 select case (small_values_method)
1302 case ("replace")
1303 {do ix^db=ixomin^db,ixomax^db\}
1304 if(has_equi_rho0) then
1305 rho=w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,0)
1306 if(flag(ix^d,rho_)) w(ix^d,rho_)=small_density-block%equi_vars(ix^d,equi_rho0_,0)
1307 else
1308 rho=w(ix^d,rho_)
1309 if(flag(ix^d,rho_)) w(ix^d,rho_)=small_density
1310 end if
1311 {
1312 if(small_values_fix_iw(m^c_)) then
1313 if(flag({ix^d},rho_)) w({ix^d},m^c_)=0.0d0
1314 end if
1315 \}
1316 if(primitive) then
1317 if(has_equi_pe0) then
1318 if(flag(ix^d,e_)) w(ix^d,p_)=small_pressure-block%equi_vars(ix^d,equi_pe0_,0)
1319 else
1320 if(flag(ix^d,e_)) w(ix^d,p_)=small_pressure
1321 end if
1322 else
1323 if(has_equi_pe0) then
1324 if(flag(ix^d,e_)) &
1325 w(ix^d,e_)=small_e+half*((^c&w(ix^d,m^c_)**2+)/rho+(^c&w(ix^d,b^c_)**2+))&
1326 -block%equi_vars(ix^d,equi_pe0_,0)*inv_gamma_1
1327 else
1328 if(flag(ix^d,e_)) &
1329 w(ix^d,e_)=small_e+half*((^c&w(ix^d,m^c_)**2+)/rho+(^c&w(ix^d,b^c_)**2+))
1330 end if
1331 end if
1332 if(flag(ix^d,r_e)) w(ix^d,r_e)=small_r_e
1333 {end do\}
1334 case ("average")
1335 ! do averaging of density
1336 call small_values_average(ixi^l, ixo^l, w, x, flag, rho_)
1337 if(primitive)then
1338 call small_values_average(ixi^l, ixo^l, w, x, flag, p_)
1339 else
1340 ! do averaging of internal energy
1341 {do ix^db=iximin^db,iximax^db\}
1342 if(has_equi_rho0) then
1343 rho=w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,0)
1344 else
1345 rho=w(ix^d,rho_)
1346 end if
1347 w(ix^d,e_)=w(ix^d,e_)&
1348 -half*((^c&w(ix^d,m^c_)**2+)/rho+(^c&w(ix^d,b^c_)**2+))
1349 {end do\}
1350 call small_values_average(ixi^l, ixo^l, w, x, flag, e_)
1351 ! convert back
1352 {do ix^db=iximin^db,iximax^db\}
1353 if(has_equi_rho0) then
1354 rho=w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,0)
1355 else
1356 rho=w(ix^d,rho_)
1357 end if
1358 w(ix^d,e_)=w(ix^d,e_)&
1359 +half*((^c&w(ix^d,m^c_)**2+)/rho+(^c&w(ix^d,b^c_)**2+))
1360 {end do\}
1361 end if
1362 call small_values_average(ixi^l, ixo^l, w, x, flag, r_e)
1363 case default
1364 if(.not.primitive) then
1365 !convert w to primitive
1366 ! do averaging of internal energy
1367 {do ix^db=iximin^db,iximax^db\}
1368 if(has_equi_rho0) then
1369 rho=w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,0)
1370 else
1371 rho=w(ix^d,rho_)
1372 end if
1373 ^c&w(ix^d,m^c_)=w(ix^d,m^c_)/rho\
1374 w(ix^d,p_)=gamma_1*(w(ix^d,e_)&
1375 -half*((^c&w(ix^d,m^c_)**2+)/rho+(^c&w(ix^d,b^c_)**2+)))
1376 {end do\}
1377 end if
1378 call small_values_error(w, x, ixi^l, ixo^l, flag, subname)
1379 end select
1380 end if
1381 end subroutine rmhd_handle_small_values_origin
1382
1383 !> Calculate v vector
1384 subroutine rmhd_get_v(w,x,ixI^L,ixO^L,v)
1386 integer, intent(in) :: ixi^l, ixo^l
1387 double precision, intent(in) :: w(ixi^s,nw), x(ixi^s,1:ndim)
1388 double precision, intent(out) :: v(ixi^s,ndir)
1389 double precision :: rho(ixi^s)
1390 integer :: idir
1391
1392 call rmhd_get_rho(w,x,ixi^l,ixo^l,rho)
1393 rho(ixo^s)=1.d0/rho(ixo^s)
1394 ! Convert momentum to velocity
1395 do idir = 1, ndir
1396 v(ixo^s, idir) = w(ixo^s, mom(idir))*rho(ixo^s)
1397 end do
1398 end subroutine rmhd_get_v
1399
1400 !> Calculate cmax_idim=csound+abs(v_idim) within ixO^L
1401 subroutine rmhd_get_cmax_origin(w,x,ixI^L,ixO^L,idim,cmax)
1403 integer, intent(in) :: ixi^l, ixo^l, idim
1404 double precision, intent(in) :: w(ixi^s, nw), x(ixi^s,1:ndim)
1405 double precision, intent(inout) :: cmax(ixi^s)
1406 double precision :: rho, inv_rho, cfast2, avmincs2, b2, kmax
1407 integer :: ix^d
1408
1409 if(b0field) then
1410 {do ix^db=ixomin^db,ixomax^db \}
1411 if(has_equi_rho0) then
1412 rho=(w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,b0i))
1413 else
1414 rho=w(ix^d,rho_)
1415 end if
1416 inv_rho=1.d0/rho
1417 ! sound speed**2
1418 cmax(ix^d)=rmhd_gamma*w(ix^d,p_)*inv_rho
1419 ! store |B|^2 in v
1420 b2=(^c&(w(ix^d,b^c_)+block%B0(ix^d,^c,b0i))**2+)
1421 cfast2=b2*inv_rho+cmax(ix^d)
1422 avmincs2=cfast2**2-4.0d0*cmax(ix^d)*(w(ix^d,mag(idim))+block%B0(ix^d,idim,b0i))**2*inv_rho
1423 if(avmincs2<zero) avmincs2=zero
1424 cmax(ix^d)=sqrt(half*(cfast2+sqrt(avmincs2)))
1425 cmax(ix^d)=abs(w(ix^d,mom(idim)))+cmax(ix^d)
1426 {end do\}
1427 else
1428 {do ix^db=ixomin^db,ixomax^db \}
1429 if(has_equi_rho0) then
1430 rho=(w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,b0i))
1431 else
1432 rho=w(ix^d,rho_)
1433 end if
1434 inv_rho=1.d0/rho
1435 ! sound speed**2
1436 cmax(ix^d)=rmhd_gamma*w(ix^d,p_)*inv_rho
1437 ! store |B|^2 in v
1438 b2=(^c&w(ix^d,b^c_)**2+)
1439 cfast2=b2*inv_rho+cmax(ix^d)
1440 avmincs2=cfast2**2-4.0d0*cmax(ix^d)*w(ix^d,mag(idim))**2*inv_rho
1441 if(avmincs2<zero) avmincs2=zero
1442 cmax(ix^d)=sqrt(half*(cfast2+sqrt(avmincs2)))
1443 cmax(ix^d)=abs(w(ix^d,mom(idim)))+cmax(ix^d)
1444 {end do\}
1445 end if
1446 end subroutine rmhd_get_cmax_origin
1447
1448 subroutine rmhd_get_a2max(w,x,ixI^L,ixO^L,a2max)
1450 integer, intent(in) :: ixi^l, ixo^l
1451 double precision, intent(in) :: w(ixi^s, nw), x(ixi^s,1:ndim)
1452 double precision, intent(inout) :: a2max(ndim)
1453 double precision :: a2(ixi^s,ndim,nw)
1454 integer :: gxo^l,hxo^l,jxo^l,kxo^l,i,j
1455
1456 a2=zero
1457 do i = 1,ndim
1458 !> 4th order
1459 hxo^l=ixo^l-kr(i,^d);
1460 gxo^l=hxo^l-kr(i,^d);
1461 jxo^l=ixo^l+kr(i,^d);
1462 kxo^l=jxo^l+kr(i,^d);
1463 a2(ixo^s,i,1:nw)=abs(-w(kxo^s,1:nw)+16.d0*w(jxo^s,1:nw)&
1464 -30.d0*w(ixo^s,1:nw)+16.d0*w(hxo^s,1:nw)-w(gxo^s,1:nw))
1465 a2max(i)=maxval(a2(ixo^s,i,1:nw))/12.d0/dxlevel(i)**2
1466 end do
1467 end subroutine rmhd_get_a2max
1468
1469 !> get adaptive cutoff temperature for TRAC (Johnston 2019 ApJL, 873, L22)
1470 subroutine rmhd_get_tcutoff(ixI^L,ixO^L,w,x,Tco_local,Tmax_local)
1472 use mod_geometry
1473 integer, intent(in) :: ixi^l,ixo^l
1474 double precision, intent(in) :: x(ixi^s,1:ndim)
1475 double precision, intent(out) :: tco_local,tmax_local
1476 ! in primitive form
1477 double precision, intent(inout) :: w(ixi^s,1:nw)
1478 double precision, parameter :: trac_delta=0.25d0
1479 double precision :: tmp1(ixi^s),te(ixi^s),lts(ixi^s)
1480 double precision, dimension(ixI^S,1:ndir) :: bunitvec
1481 double precision, dimension(ixI^S,1:ndim) :: gradt
1482 double precision :: bdir(ndim)
1483 double precision :: ltrc,ltrp,altr(ixi^s)
1484 integer :: idims,jxo^l,hxo^l,ixa^d,ixb^d,ix^d
1485 integer :: jxp^l,hxp^l,ixp^l,ixq^l
1486 logical :: lrlt(ixi^s)
1487
1489 call rmhd_get_temperature_from_te(w,x,ixi^l,ixi^l,te)
1490 else
1491 call rmhd_get_rfactor(w,x,ixi^l,ixi^l,te)
1492 te(ixi^s)=w(ixi^s,p_)/(te(ixi^s)*w(ixi^s,rho_))
1493 end if
1494 tco_local=zero
1495 tmax_local=maxval(te(ixo^s))
1496
1497 {^ifoned
1498 select case(rmhd_trac_type)
1499 case(0)
1500 !> test case, fixed cutoff temperature
1501 block%wextra(ixi^s,tcoff_)=2.5d5/unit_temperature
1502 case(1)
1503 hxo^l=ixo^l-1;
1504 jxo^l=ixo^l+1;
1505 lts(ixo^s)=0.5d0*abs(te(jxo^s)-te(hxo^s))/te(ixo^s)
1506 lrlt=.false.
1507 where(lts(ixo^s) > trac_delta)
1508 lrlt(ixo^s)=.true.
1509 end where
1510 if(any(lrlt(ixo^s))) then
1511 tco_local=maxval(te(ixo^s), mask=lrlt(ixo^s))
1512 end if
1513 case(2)
1514 !> iijima et al. 2021, LTRAC method
1515 ltrc=1.5d0
1516 ltrp=4.d0
1517 ixp^l=ixo^l^ladd1;
1518 hxo^l=ixo^l-1;
1519 jxo^l=ixo^l+1;
1520 hxp^l=ixp^l-1;
1521 jxp^l=ixp^l+1;
1522 lts(ixp^s)=0.5d0*abs(te(jxp^s)-te(hxp^s))/te(ixp^s)
1523 lts(ixp^s)=max(one, (exp(lts(ixp^s))/ltrc)**ltrp)
1524 lts(ixo^s)=0.25d0*(lts(jxo^s)+two*lts(ixo^s)+lts(hxo^s))
1525 block%wextra(ixo^s,tcoff_)=te(ixo^s)*lts(ixo^s)**0.4d0
1526 case default
1527 call mpistop("rmhd_trac_type not allowed for 1D simulation")
1528 end select
1529 }
1530 {^nooned
1531 select case(rmhd_trac_type)
1532 case(0)
1533 !> test case, fixed cutoff temperature
1534 block%wextra(ixi^s,tcoff_)=2.5d5/unit_temperature
1535 case(1,4,6)
1536 ! temperature gradient at cell centers
1537 do idims=1,ndim
1538 call gradient(te,ixi^l,ixo^l,idims,tmp1)
1539 gradt(ixo^s,idims)=tmp1(ixo^s)
1540 end do
1541 ! B vector
1542 if(b0field) then
1543 bunitvec(ixo^s,:)=w(ixo^s,iw_mag(:))+block%B0(ixo^s,:,0)
1544 else
1545 bunitvec(ixo^s,:)=w(ixo^s,iw_mag(:))
1546 end if
1547 if(rmhd_trac_type .gt. 1) then
1548 ! B direction at cell center
1549 bdir=zero
1550 {do ixa^d=0,1\}
1551 ixb^d=(ixomin^d+ixomax^d-1)/2+ixa^d;
1552 bdir(1:ndim)=bdir(1:ndim)+bunitvec(ixb^d,1:ndim)
1553 {end do\}
1554 if(sum(bdir(:)**2) .gt. zero) then
1555 bdir(1:ndim)=bdir(1:ndim)/dsqrt(sum(bdir(:)**2))
1556 end if
1557 block%special_values(3:ndim+2)=bdir(1:ndim)
1558 end if
1559 tmp1(ixo^s)=dsqrt(sum(bunitvec(ixo^s,:)**2,dim=ndim+1))
1560 where(tmp1(ixo^s)/=0.d0)
1561 tmp1(ixo^s)=1.d0/tmp1(ixo^s)
1562 elsewhere
1563 tmp1(ixo^s)=bigdouble
1564 end where
1565 ! b unit vector: magnetic field direction vector
1566 do idims=1,ndim
1567 bunitvec(ixo^s,idims)=bunitvec(ixo^s,idims)*tmp1(ixo^s)
1568 end do
1569 ! temperature length scale inversed
1570 lts(ixo^s)=abs(sum(gradt(ixo^s,1:ndim)*bunitvec(ixo^s,1:ndim),dim=ndim+1))/te(ixo^s)
1571 ! fraction of cells size to temperature length scale
1572 if(slab_uniform) then
1573 lts(ixo^s)=minval(dxlevel)*lts(ixo^s)
1574 else
1575 lts(ixo^s)=minval(block%ds(ixo^s,:),dim=ndim+1)*lts(ixo^s)
1576 end if
1577 lrlt=.false.
1578 where(lts(ixo^s) > trac_delta)
1579 lrlt(ixo^s)=.true.
1580 end where
1581 if(any(lrlt(ixo^s))) then
1582 block%special_values(1)=maxval(te(ixo^s), mask=lrlt(ixo^s))
1583 else
1584 block%special_values(1)=zero
1585 end if
1586 block%special_values(2)=tmax_local
1587 case(2)
1588 !> iijima et al. 2021, LTRAC method
1589 ltrc=1.5d0
1590 ltrp=4.d0
1591 ixp^l=ixo^l^ladd2;
1592 ! temperature gradient at cell centers
1593 do idims=1,ndim
1594 ixq^l=ixp^l;
1595 hxp^l=ixp^l;
1596 jxp^l=ixp^l;
1597 select case(idims)
1598 {case(^d)
1599 ixqmin^d=ixqmin^d+1
1600 ixqmax^d=ixqmax^d-1
1601 hxpmax^d=ixpmin^d
1602 jxpmin^d=ixpmax^d
1603 \}
1604 end select
1605 call gradient(te,ixi^l,ixq^l,idims,gradt(ixi^s,idims))
1606 call gradientf(te,x,ixi^l,hxp^l,idims,gradt(ixi^s,idims),nghostcells,.true.)
1607 call gradientf(te,x,ixi^l,jxp^l,idims,gradt(ixi^s,idims),nghostcells,.false.)
1608 end do
1609 ! B vector
1610 {do ix^db=ixpmin^db,ixpmax^db\}
1611 if(b0field) then
1612 ^c&bunitvec(ix^d,^c)=w(ix^d,iw_mag(^c))+block%B0(ix^d,^c,0)\
1613 else
1614 ^c&bunitvec(ix^d,^c)=w(ix^d,iw_mag(^c))\
1615 end if
1616 tmp1(ix^d)=1.d0/(dsqrt(^c&bunitvec(ix^d,^c)**2+)+smalldouble)
1617 ! b unit vector: magnetic field direction vector
1618 ^d&bunitvec({ix^d},^d)=bunitvec({ix^d},^d)*tmp1({ix^d})\
1619 ! temperature length scale inversed
1620 lts(ix^d)=abs(^d&gradt({ix^d},^d)*bunitvec({ix^d},^d)+)/te(ix^d)
1621 ! fraction of cells size to temperature length scale
1622 if(slab_uniform) then
1623 lts(ix^d)=min(^d&dxlevel(^d))*lts(ix^d)
1624 else
1625 lts(ix^d)=min(^d&block%ds({ix^d},^d))*lts(ix^d)
1626 end if
1627 lts(ix^d)=max(one,(exp(lts(ix^d))/ltrc)**ltrp)
1628 {end do\}
1629 ! need one ghost layer for thermal conductivity
1630 ixp^l=ixo^l^ladd1;
1631 do idims=1,ndim
1632 hxo^l=ixp^l-kr(idims,^d);
1633 jxo^l=ixp^l+kr(idims,^d);
1634 if(idims==1) then
1635 altr(ixp^s)=0.25d0*(lts(hxo^s)+two*lts(ixp^s)+lts(jxo^s))*bunitvec(ixp^s,idims)**2
1636 else
1637 altr(ixp^s)=altr(ixp^s)+0.25d0*(lts(hxo^s)+two*lts(ixp^s)+lts(jxo^s))*bunitvec(ixp^s,idims)**2
1638 end if
1639 end do
1640 block%wextra(ixp^s,tcoff_)=te(ixp^s)*altr(ixp^s)**0.4d0
1641 case(3,5)
1642 !> do nothing here
1643 case default
1644 call mpistop("unknown rmhd_trac_type")
1645 end select
1646 }
1647 end subroutine rmhd_get_tcutoff
1648
1649 !> get H speed for H-correction to fix the carbuncle problem at grid-aligned shock front
1650 subroutine rmhd_get_h_speed(wprim,x,ixI^L,ixO^L,idim,Hspeed)
1652
1653 integer, intent(in) :: ixi^l, ixo^l, idim
1654 double precision, intent(in) :: wprim(ixi^s, nw)
1655 double precision, intent(in) :: x(ixi^s,1:ndim)
1656 double precision, intent(out) :: hspeed(ixi^s,1:number_species)
1657
1658 double precision :: csound(ixi^s,ndim)
1659 double precision, allocatable :: tmp(:^d&)
1660 integer :: jxc^l, ixc^l, ixa^l, id, ix^d
1661
1662 hspeed=0.d0
1663 ixa^l=ixo^l^ladd1;
1664 allocate(tmp(ixa^s))
1665 do id=1,ndim
1666 call rmhd_get_csound_prim(wprim,x,ixi^l,ixa^l,id,tmp)
1667 csound(ixa^s,id)=tmp(ixa^s)
1668 end do
1669 ixcmax^d=ixomax^d;
1670 ixcmin^d=ixomin^d+kr(idim,^d)-1;
1671 jxcmax^d=ixcmax^d+kr(idim,^d);
1672 jxcmin^d=ixcmin^d+kr(idim,^d);
1673 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))
1674
1675 do id=1,ndim
1676 if(id==idim) cycle
1677 ixamax^d=ixcmax^d+kr(id,^d);
1678 ixamin^d=ixcmin^d+kr(id,^d);
1679 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)))
1680 ixamax^d=ixcmax^d-kr(id,^d);
1681 ixamin^d=ixcmin^d-kr(id,^d);
1682 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)))
1683 end do
1684
1685 do id=1,ndim
1686 if(id==idim) cycle
1687 ixamax^d=jxcmax^d+kr(id,^d);
1688 ixamin^d=jxcmin^d+kr(id,^d);
1689 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)))
1690 ixamax^d=jxcmax^d-kr(id,^d);
1691 ixamin^d=jxcmin^d-kr(id,^d);
1692 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)))
1693 end do
1694 deallocate(tmp)
1695
1696 end subroutine rmhd_get_h_speed
1697
1698 !> Estimating bounds for the minimum and maximum signal velocities without split
1699 subroutine rmhd_get_cbounds(wLC,wRC,wLp,wRp,x,ixI^L,ixO^L,idim,Hspeed,cmax,cmin)
1701 integer, intent(in) :: ixi^l, ixo^l, idim
1702 double precision, intent(in) :: wlc(ixi^s, nw), wrc(ixi^s, nw)
1703 double precision, intent(in) :: wlp(ixi^s, nw), wrp(ixi^s, nw)
1704 double precision, intent(in) :: x(ixi^s,1:ndim)
1705 double precision, intent(inout) :: cmax(ixi^s,1:number_species)
1706 double precision, intent(inout), optional :: cmin(ixi^s,1:number_species)
1707 double precision, intent(in) :: hspeed(ixi^s,1:number_species)
1708
1709 double precision :: wmean(ixi^s,nw), csoundl(ixo^s), csoundr(ixo^s)
1710 double precision :: umean, dmean, tmp1, tmp2, tmp3
1711 integer :: ix^d
1712
1713 select case (boundspeed)
1714 case (1)
1715 ! This implements formula (10.52) from "Riemann Solvers and Numerical
1716 ! Methods for Fluid Dynamics" by Toro.
1717 call rmhd_get_csound_prim(wlp,x,ixi^l,ixo^l,idim,csoundl)
1718 call rmhd_get_csound_prim(wrp,x,ixi^l,ixo^l,idim,csoundr)
1719 if(present(cmin)) then
1720 {do ix^db=ixomin^db,ixomax^db\}
1721 tmp1=sqrt(wlp(ix^d,rho_))
1722 tmp2=sqrt(wrp(ix^d,rho_))
1723 tmp3=1.d0/(tmp1+tmp2)
1724 umean=(wlp(ix^d,mom(idim))*tmp1+wrp(ix^d,mom(idim))*tmp2)*tmp3
1725 dmean=sqrt((tmp1*csoundl(ix^d)**2+tmp2*csoundr(ix^d)**2)*tmp3+&
1726 half*tmp1*tmp2*tmp3**2*(wrp(ix^d,mom(idim))-wlp(ix^d,mom(idim)))**2)
1727 cmin(ix^d,1)=umean-dmean
1728 cmax(ix^d,1)=umean+dmean
1729 {end do\}
1730 if(h_correction) then
1731 {do ix^db=ixomin^db,ixomax^db\}
1732 cmin(ix^d,1)=sign(one,cmin(ix^d,1))*max(abs(cmin(ix^d,1)),hspeed(ix^d,1))
1733 cmax(ix^d,1)=sign(one,cmax(ix^d,1))*max(abs(cmax(ix^d,1)),hspeed(ix^d,1))
1734 {end do\}
1735 end if
1736 else
1737 {do ix^db=ixomin^db,ixomax^db\}
1738 tmp1=sqrt(wlp(ix^d,rho_))
1739 tmp2=sqrt(wrp(ix^d,rho_))
1740 tmp3=1.d0/(tmp1+tmp2)
1741 umean=(wlp(ix^d,mom(idim))*tmp1+wrp(ix^d,mom(idim))*tmp2)*tmp3
1742 dmean=sqrt((tmp1*csoundl(ix^d)**2+tmp2*csoundr(ix^d)**2)*tmp3+&
1743 half*tmp1*tmp2*tmp3**2*(wrp(ix^d,mom(idim))-wlp(ix^d,mom(idim)))**2)
1744 cmax(ix^d,1)=abs(umean)+dmean
1745 {end do\}
1746 end if
1747 case (2)
1748 wmean(ixo^s,1:nwflux)=0.5d0*(wlp(ixo^s,1:nwflux)+wrp(ixo^s,1:nwflux))
1749 call rmhd_get_csound_prim(wmean,x,ixi^l,ixo^l,idim,csoundr)
1750 if(present(cmin)) then
1751 {do ix^db=ixomin^db,ixomax^db\}
1752 cmax(ix^d,1)=max(wmean(ix^d,mom(idim))+csoundr(ix^d),zero)
1753 cmin(ix^d,1)=min(wmean(ix^d,mom(idim))-csoundr(ix^d),zero)
1754 {end do\}
1755 if(h_correction) then
1756 {do ix^db=ixomin^db,ixomax^db\}
1757 cmin(ix^d,1)=sign(one,cmin(ix^d,1))*max(abs(cmin(ix^d,1)),hspeed(ix^d,1))
1758 cmax(ix^d,1)=sign(one,cmax(ix^d,1))*max(abs(cmax(ix^d,1)),hspeed(ix^d,1))
1759 {end do\}
1760 end if
1761 else
1762 cmax(ixo^s,1)=abs(wmean(ixo^s,mom(idim)))+csoundr(ixo^s)
1763 end if
1764 case (3)
1765 ! Miyoshi 2005 JCP 208, 315 equation (67)
1766 call rmhd_get_csound_prim(wlp,x,ixi^l,ixo^l,idim,csoundl)
1767 call rmhd_get_csound_prim(wrp,x,ixi^l,ixo^l,idim,csoundr)
1768 if(present(cmin)) then
1769 {do ix^db=ixomin^db,ixomax^db\}
1770 csoundl(ix^d)=max(csoundl(ix^d),csoundr(ix^d))
1771 cmin(ix^d,1)=min(wlp(ix^d,mom(idim)),wrp(ix^d,mom(idim)))-csoundl(ix^d)
1772 cmax(ix^d,1)=max(wlp(ix^d,mom(idim)),wrp(ix^d,mom(idim)))+csoundl(ix^d)
1773 {end do\}
1774 if(h_correction) then
1775 {do ix^db=ixomin^db,ixomax^db\}
1776 cmin(ix^d,1)=sign(one,cmin(ix^d,1))*max(abs(cmin(ix^d,1)),hspeed(ix^d,1))
1777 cmax(ix^d,1)=sign(one,cmax(ix^d,1))*max(abs(cmax(ix^d,1)),hspeed(ix^d,1))
1778 {end do\}
1779 end if
1780 else
1781 {do ix^db=ixomin^db,ixomax^db\}
1782 csoundl(ix^d)=max(csoundl(ix^d),csoundr(ix^d))
1783 cmax(ix^d,1)=max(wlp(ix^d,mom(idim)),wrp(ix^d,mom(idim)))+csoundl(ix^d)
1784 {end do\}
1785 end if
1786 end select
1787 end subroutine rmhd_get_cbounds
1788
1789 !> Estimating bounds for the minimum and maximum signal velocities with rho split
1790 subroutine rmhd_get_cbounds_split_rho(wLC,wRC,wLp,wRp,x,ixI^L,ixO^L,idim,Hspeed,cmax,cmin)
1792 integer, intent(in) :: ixi^l, ixo^l, idim
1793 double precision, intent(in) :: wlc(ixi^s, nw), wrc(ixi^s, nw)
1794 double precision, intent(in) :: wlp(ixi^s, nw), wrp(ixi^s, nw)
1795 double precision, intent(in) :: x(ixi^s,1:ndim)
1796 double precision, intent(inout) :: cmax(ixi^s,1:number_species)
1797 double precision, intent(inout), optional :: cmin(ixi^s,1:number_species)
1798 double precision, intent(in) :: hspeed(ixi^s,1:number_species)
1799 double precision :: wmean(ixi^s,nw), csoundl(ixo^s), csoundr(ixo^s)
1800 double precision :: umean, dmean, tmp1, tmp2, tmp3
1801 integer :: ix^d
1802
1803 select case (boundspeed)
1804 case (1)
1805 ! This implements formula (10.52) from "Riemann Solvers and Numerical
1806 ! Methods for Fluid Dynamics" by Toro.
1807 call rmhd_get_csound_prim_split(wlp,x,ixi^l,ixo^l,idim,csoundl)
1808 call rmhd_get_csound_prim_split(wrp,x,ixi^l,ixo^l,idim,csoundr)
1809 if(present(cmin)) then
1810 {do ix^db=ixomin^db,ixomax^db\}
1811 tmp1=sqrt(wlp(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,b0i))
1812 tmp2=sqrt(wrp(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,b0i))
1813 tmp3=1.d0/(tmp1+tmp2)
1814 umean=(wlp(ix^d,mom(idim))*tmp1+wrp(ix^d,mom(idim))*tmp2)*tmp3
1815 dmean=sqrt((tmp1*csoundl(ix^d)**2+tmp2*csoundr(ix^d)**2)*tmp3+&
1816 half*tmp1*tmp2*tmp3**2*(wrp(ix^d,mom(idim))-wlp(ix^d,mom(idim)))**2)
1817 cmin(ix^d,1)=umean-dmean
1818 cmax(ix^d,1)=umean+dmean
1819 {end do\}
1820 if(h_correction) then
1821 {do ix^db=ixomin^db,ixomax^db\}
1822 cmin(ix^d,1)=sign(one,cmin(ix^d,1))*max(abs(cmin(ix^d,1)),hspeed(ix^d,1))
1823 cmax(ix^d,1)=sign(one,cmax(ix^d,1))*max(abs(cmax(ix^d,1)),hspeed(ix^d,1))
1824 {end do\}
1825 end if
1826 else
1827 {do ix^db=ixomin^db,ixomax^db\}
1828 tmp1=sqrt(wlp(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,b0i))
1829 tmp2=sqrt(wrp(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,b0i))
1830 tmp3=1.d0/(tmp1+tmp2)
1831 umean=(wlp(ix^d,mom(idim))*tmp1+wrp(ix^d,mom(idim))*tmp2)*tmp3
1832 dmean=sqrt((tmp1*csoundl(ix^d)**2+tmp2*csoundr(ix^d)**2)*tmp3+&
1833 half*tmp1*tmp2*tmp3**2*(wrp(ix^d,mom(idim))-wlp(ix^d,mom(idim)))**2)
1834 cmax(ix^d,1)=abs(umean)+dmean
1835 {end do\}
1836 end if
1837 case (2)
1838 wmean(ixo^s,1:nwflux)=0.5d0*(wlp(ixo^s,1:nwflux)+wrp(ixo^s,1:nwflux))
1839 call rmhd_get_csound_prim_split(wmean,x,ixi^l,ixo^l,idim,csoundr)
1840 if(present(cmin)) then
1841 {do ix^db=ixomin^db,ixomax^db\}
1842 cmax(ix^d,1)=max(wmean(ix^d,mom(idim))+csoundr(ix^d),zero)
1843 cmin(ix^d,1)=min(wmean(ix^d,mom(idim))-csoundr(ix^d),zero)
1844 {end do\}
1845 if(h_correction) then
1846 {do ix^db=ixomin^db,ixomax^db\}
1847 cmin(ix^d,1)=sign(one,cmin(ix^d,1))*max(abs(cmin(ix^d,1)),hspeed(ix^d,1))
1848 cmax(ix^d,1)=sign(one,cmax(ix^d,1))*max(abs(cmax(ix^d,1)),hspeed(ix^d,1))
1849 {end do\}
1850 end if
1851 else
1852 cmax(ixo^s,1)=abs(wmean(ixo^s,mom(idim)))+csoundr(ixo^s)
1853 end if
1854 case (3)
1855 ! Miyoshi 2005 JCP 208, 315 equation (67)
1856 call rmhd_get_csound_prim_split(wlp,x,ixi^l,ixo^l,idim,csoundl)
1857 call rmhd_get_csound_prim_split(wrp,x,ixi^l,ixo^l,idim,csoundr)
1858 if(present(cmin)) then
1859 {do ix^db=ixomin^db,ixomax^db\}
1860 csoundl(ix^d)=max(csoundl(ix^d),csoundr(ix^d))
1861 cmin(ix^d,1)=min(wlp(ix^d,mom(idim)),wrp(ix^d,mom(idim)))-csoundl(ix^d)
1862 cmax(ix^d,1)=max(wlp(ix^d,mom(idim)),wrp(ix^d,mom(idim)))+csoundl(ix^d)
1863 {end do\}
1864 if(h_correction) then
1865 {do ix^db=ixomin^db,ixomax^db\}
1866 cmin(ix^d,1)=sign(one,cmin(ix^d,1))*max(abs(cmin(ix^d,1)),hspeed(ix^d,1))
1867 cmax(ix^d,1)=sign(one,cmax(ix^d,1))*max(abs(cmax(ix^d,1)),hspeed(ix^d,1))
1868 {end do\}
1869 end if
1870 else
1871 {do ix^db=ixomin^db,ixomax^db\}
1872 csoundl(ix^d)=max(csoundl(ix^d),csoundr(ix^d))
1873 cmax(ix^d,1)=max(wlp(ix^d,mom(idim)),wrp(ix^d,mom(idim)))+csoundl(ix^d)
1874 {end do\}
1875 end if
1876 end select
1877 end subroutine rmhd_get_cbounds_split_rho
1878
1879 !> prepare velocities for ct methods
1880 subroutine rmhd_get_ct_velocity(vcts,wLp,wRp,ixI^L,ixO^L,idim,cmax,cmin)
1882 integer, intent(in) :: ixi^l, ixo^l, idim
1883 double precision, intent(in) :: wlp(ixi^s, nw), wrp(ixi^s, nw)
1884 double precision, intent(in) :: cmax(ixi^s)
1885 double precision, intent(in), optional :: cmin(ixi^s)
1886 type(ct_velocity), intent(inout) :: vcts
1887 integer :: idime,idimn
1888
1889 ! calculate velocities related to different UCT schemes
1890 select case(type_ct)
1891 case('average')
1892 case('uct_contact')
1893 if(.not.allocated(vcts%vnorm)) allocate(vcts%vnorm(ixi^s,1:ndim))
1894 ! get average normal velocity at cell faces
1895 vcts%vnorm(ixo^s,idim)=0.5d0*(wlp(ixo^s,mom(idim))+wrp(ixo^s,mom(idim)))
1896 case('uct_hll')
1897 if(.not.allocated(vcts%vbarC)) then
1898 allocate(vcts%vbarC(ixi^s,1:ndir,2),vcts%vbarLC(ixi^s,1:ndir,2),vcts%vbarRC(ixi^s,1:ndir,2))
1899 allocate(vcts%cbarmin(ixi^s,1:ndim),vcts%cbarmax(ixi^s,1:ndim))
1900 end if
1901 ! Store magnitude of characteristics
1902 if(present(cmin)) then
1903 vcts%cbarmin(ixo^s,idim)=max(-cmin(ixo^s),zero)
1904 vcts%cbarmax(ixo^s,idim)=max( cmax(ixo^s),zero)
1905 else
1906 vcts%cbarmax(ixo^s,idim)=max( cmax(ixo^s),zero)
1907 vcts%cbarmin(ixo^s,idim)=vcts%cbarmax(ixo^s,idim)
1908 end if
1909
1910 idimn=mod(idim,ndir)+1 ! 'Next' direction
1911 idime=mod(idim+1,ndir)+1 ! Electric field direction
1912 ! Store velocities
1913 vcts%vbarLC(ixo^s,idim,1)=wlp(ixo^s,mom(idimn))
1914 vcts%vbarRC(ixo^s,idim,1)=wrp(ixo^s,mom(idimn))
1915 vcts%vbarC(ixo^s,idim,1)=(vcts%cbarmax(ixo^s,idim)*vcts%vbarLC(ixo^s,idim,1) &
1916 +vcts%cbarmin(ixo^s,idim)*vcts%vbarRC(ixo^s,idim,1))&
1917 /(vcts%cbarmax(ixo^s,idim)+vcts%cbarmin(ixo^s,idim))
1918 vcts%vbarLC(ixo^s,idim,2)=wlp(ixo^s,mom(idime))
1919 vcts%vbarRC(ixo^s,idim,2)=wrp(ixo^s,mom(idime))
1920 vcts%vbarC(ixo^s,idim,2)=(vcts%cbarmax(ixo^s,idim)*vcts%vbarLC(ixo^s,idim,2) &
1921 +vcts%cbarmin(ixo^s,idim)*vcts%vbarRC(ixo^s,idim,1))&
1922 /(vcts%cbarmax(ixo^s,idim)+vcts%cbarmin(ixo^s,idim))
1923 case default
1924 call mpistop('choose average, uct_contact,or uct_hll for type_ct!')
1925 end select
1926 end subroutine rmhd_get_ct_velocity
1927
1928 !> Calculate fast magnetosonic wave speed
1929 subroutine rmhd_get_csound_prim(w,x,ixI^L,ixO^L,idim,csound)
1931 integer, intent(in) :: ixi^l, ixo^l, idim
1932 double precision, intent(in) :: w(ixi^s, nw), x(ixi^s,1:ndim)
1933 double precision, intent(out):: csound(ixo^s)
1934 double precision :: inv_rho, cfast2, avmincs2, b2, kmax
1935 double precision :: prad_tensor(ixo^s, 1:ndim, 1:ndim)
1936 double precision :: prad_max(ixo^s)
1937 integer :: ix^d
1938
1939 call rmhd_get_pradiation(w, x, ixi^l, ixo^l, prad_tensor, nghostcells-1)
1940 !> filter cmax
1941 if(radio_acoustic_filter) then
1942 call rmhd_radio_acoustic_filter(x, ixi^l, ixo^l, prad_max)
1943 endif
1944 ! store |B|^2 in v
1945 if(b0field) then
1946 {do ix^db=ixomin^db,ixomax^db \}
1947 inv_rho=1.d0/w(ix^d,rho_)
1948 prad_max(ix^d) = maxval(prad_tensor(ix^d,:,:))
1949 if(rmhd_energy) then
1950 csound(ix^d)=max(rmhd_gamma,4.d0/3.d0)*(w(ix^d,p_)+prad_max(ix^d))*inv_rho
1951 else
1952 csound(ix^d)=rmhd_gamma*rmhd_adiab*w(ix^d,rho_)**gamma_1
1953 end if
1954 b2=(^c&(w(ix^d,b^c_)+block%B0(ix^d,^c,b0i))**2+)
1955 cfast2=b2*inv_rho+csound(ix^d)
1956 avmincs2=cfast2**2-4.0d0*csound(ix^d)*(w(ix^d,mag(idim))+&
1957 block%B0(ix^d,idim,b0i))**2*inv_rho
1958 if(avmincs2<zero) avmincs2=zero
1959 csound(ix^d)=sqrt(half*(cfast2+sqrt(avmincs2)))
1960 {end do\}
1961 else
1962 {do ix^db=ixomin^db,ixomax^db \}
1963 inv_rho=1.d0/w(ix^d,rho_)
1964 prad_max(ix^d)=maxval(prad_tensor(ix^d,:,:))
1965 if(rmhd_energy) then
1966 csound(ix^d)=max(rmhd_gamma,4.d0/3.d0)*(w(ix^d,p_)+prad_max(ix^d))*inv_rho
1967 else
1968 csound(ix^d)=rmhd_gamma*rmhd_adiab*w(ix^d,rho_)**gamma_1
1969 end if
1970 b2=(^c&w(ix^d,b^c_)**2+)
1971 cfast2=b2*inv_rho+csound(ix^d)
1972 avmincs2=cfast2**2-4.0d0*csound(ix^d)*w(ix^d,mag(idim))**2*inv_rho
1973 if(avmincs2<zero) avmincs2=zero
1974 csound(ix^d)=sqrt(half*(cfast2+sqrt(avmincs2)))
1975 {end do\}
1976 end if
1977 end subroutine rmhd_get_csound_prim
1978
1979 !> Calculate fast magnetosonic wave speed
1980 subroutine rmhd_get_csound_prim_split(w,x,ixI^L,ixO^L,idim,csound)
1982 integer, intent(in) :: ixi^l, ixo^l, idim
1983 double precision, intent(in) :: w(ixi^s, nw), x(ixi^s,1:ndim)
1984 double precision, intent(out):: csound(ixo^s)
1985 double precision :: rho, inv_rho, cfast2, avmincs2, b2, kmax
1986 double precision :: prad_tensor(ixo^s, 1:ndim, 1:ndim)
1987 double precision :: prad_max(ixo^s)
1988 integer :: ix^d
1989
1990 call rmhd_get_pradiation(w, x, ixi^l, ixo^l, prad_tensor, nghostcells-1)
1991 !> filter cmax
1992 if (radio_acoustic_filter) then
1993 call rmhd_radio_acoustic_filter(x, ixi^l, ixo^l, prad_max)
1994 endif
1995
1996 ! store |B|^2 in v
1997 if(b0field) then
1998 {do ix^db=ixomin^db,ixomax^db \}
1999 rho=(w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,b0i))
2000 inv_rho=1.d0/rho
2001 prad_max(ix^d) = maxval(prad_tensor(ix^d,:,:))
2002 if(has_equi_pe0) then
2003 csound(ix^d)=max(rmhd_gamma,4.d0/3.d0)*(w(ix^d,p_)+block%equi_vars(ix^d,equi_pe0_,b0i)+prad_max(ix^d))*inv_rho
2004 end if
2005 b2=(^c&(w(ix^d,b^c_)+block%B0(ix^d,^c,b0i))**2+)
2006 cfast2=b2*inv_rho+csound(ix^d)
2007 avmincs2=cfast2**2-4.0d0*csound(ix^d)*(w(ix^d,mag(idim))+&
2008 block%B0(ix^d,idim,b0i))**2*inv_rho
2009 if(avmincs2<zero) avmincs2=zero
2010 csound(ix^d)=sqrt(half*(cfast2+sqrt(avmincs2)))
2011 {end do\}
2012 else
2013 {do ix^db=ixomin^db,ixomax^db \}
2014 rho=(w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,b0i))
2015 inv_rho=1.d0/rho
2016 prad_max(ix^d) = maxval(prad_tensor(ix^d,:,:))
2017 if(has_equi_pe0) then
2018 csound(ix^d)=max(rmhd_gamma,4.d0/3.d0)*(w(ix^d,p_)+block%equi_vars(ix^d,equi_pe0_,b0i)+prad_max(ix^d))*inv_rho
2019 end if
2020 b2=(^c&w(ix^d,b^c_)**2+)
2021 cfast2=b2*inv_rho+csound(ix^d)
2022 avmincs2=cfast2**2-4.0d0*csound(ix^d)*w(ix^d,mag(idim))**2*inv_rho
2023 if(avmincs2<zero) avmincs2=zero
2024 csound(ix^d)=sqrt(half*(cfast2+sqrt(avmincs2)))
2025 {end do\}
2026 end if
2027 end subroutine rmhd_get_csound_prim_split
2028
2029 !> Calculate thermal pressure=(gamma-1)*(e-0.5*m**2/rho-b**2/2) within ixO^L
2030 subroutine rmhd_get_pthermal_origin(w,x,ixI^L,ixO^L,pth)
2033
2034 integer, intent(in) :: ixi^l, ixo^l
2035 double precision, intent(in) :: w(ixi^s,nw)
2036 double precision, intent(in) :: x(ixi^s,1:ndim)
2037 double precision, intent(out):: pth(ixi^s)
2038
2039 integer :: iw, ix^d
2040
2041 {do ix^db=ixomin^db,ixomax^db\}
2042 if(has_equi_rho0) then
2043 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))&
2044 +(^c&w(ix^d,b^c_)**2+)))+block%equi_vars(ix^d,equi_pe0_,0)
2045 else
2046 pth(ix^d)=gamma_1*(w(ix^d,e_)-half*((^c&w(ix^d,m^c_)**2+)/w(ix^d,rho_)&
2047 +(^c&w(ix^d,b^c_)**2+)))
2048 end if
2049 if(fix_small_values.and.pth(ix^d)<small_pressure) pth(ix^d)=small_pressure
2050 {end do\}
2051
2052 if(check_small_values.and..not.fix_small_values) then
2053 {do ix^db=ixomin^db,ixomax^db\}
2054 if(pth(ix^d)<small_pressure) then
2055 write(*,*) "Error: small value of gas pressure",pth(ix^d),&
2056 " encountered when call rmhd_get_pthermal"
2057 write(*,*) "Iteration: ", it, " Time: ", global_time
2058 write(*,*) "Location: ", x(ix^d,:)
2059 write(*,*) "Cell number: ", ix^d
2060 do iw=1,nw
2061 write(*,*) trim(cons_wnames(iw)),": ",w(ix^d,iw)
2062 end do
2063 ! use erroneous arithmetic operation to crash the run
2064 if(trace_small_values) write(*,*) sqrt(pth(ix^d)-bigdouble)
2065 write(*,*) "Saving status at the previous time step"
2066 crash=.true.
2067 end if
2068 {end do\}
2069 end if
2070 end subroutine rmhd_get_pthermal_origin
2071
2072 !> copy temperature from stored Te variable
2073 subroutine rmhd_get_temperature_from_te(w, x, ixI^L, ixO^L, res)
2075 integer, intent(in) :: ixi^l, ixo^l
2076 double precision, intent(in) :: w(ixi^s, 1:nw)
2077 double precision, intent(in) :: x(ixi^s, 1:ndim)
2078 double precision, intent(out):: res(ixi^s)
2079 res(ixo^s) = w(ixo^s, te_)
2080 end subroutine rmhd_get_temperature_from_te
2081
2082 !> Calculate temperature=p/rho when in e_ the internal energy is stored
2083 subroutine rmhd_get_temperature_from_eint(w, x, ixI^L, ixO^L, res)
2085 integer, intent(in) :: ixi^l, ixo^l
2086 double precision, intent(in) :: w(ixi^s, 1:nw)
2087 double precision, intent(in) :: x(ixi^s, 1:ndim)
2088 double precision, intent(out):: res(ixi^s)
2089 double precision :: r(ixi^s)
2090
2091 call rmhd_get_rfactor(w,x,ixi^l,ixo^l,r)
2092 res(ixo^s) = gamma_1 * w(ixo^s, e_)/(w(ixo^s,rho_)*r(ixo^s))
2093 end subroutine rmhd_get_temperature_from_eint
2094
2095 !> Calculate temperature=p/rho when in e_ the total energy is stored
2096 subroutine rmhd_get_temperature_from_etot(w, x, ixI^L, ixO^L, res)
2098 integer, intent(in) :: ixi^l, ixo^l
2099 double precision, intent(in) :: w(ixi^s, 1:nw)
2100 double precision, intent(in) :: x(ixi^s, 1:ndim)
2101 double precision, intent(out):: res(ixi^s)
2102 double precision :: r(ixi^s)
2103
2104 call rmhd_get_rfactor(w,x,ixi^l,ixo^l,r)
2105 call rmhd_get_pthermal(w,x,ixi^l,ixo^l,res)
2106 res(ixo^s)=res(ixo^s)/(r(ixo^s)*w(ixo^s,rho_))
2107 end subroutine rmhd_get_temperature_from_etot
2108
2109 subroutine rmhd_get_temperature_from_etot_with_equi(w, x, ixI^L, ixO^L, res)
2111 integer, intent(in) :: ixi^l, ixo^l
2112 double precision, intent(in) :: w(ixi^s, 1:nw)
2113 double precision, intent(in) :: x(ixi^s, 1:ndim)
2114 double precision, intent(out):: res(ixi^s)
2115 double precision :: r(ixi^s)
2116
2117 call rmhd_get_rfactor(w,x,ixi^l,ixo^l,r)
2118 call rmhd_get_pthermal(w,x,ixi^l,ixo^l,res)
2119 res(ixo^s)=res(ixo^s)/(r(ixo^s)*(w(ixo^s,rho_)+block%equi_vars(ixo^s,equi_rho0_,b0i)))
2120 end subroutine rmhd_get_temperature_from_etot_with_equi
2121
2122 subroutine rmhd_get_temperature_from_eint_with_equi(w, x, ixI^L, ixO^L, res)
2124 integer, intent(in) :: ixi^l, ixo^l
2125 double precision, intent(in) :: w(ixi^s, 1:nw)
2126 double precision, intent(in) :: x(ixi^s, 1:ndim)
2127 double precision, intent(out):: res(ixi^s)
2128 double precision :: r(ixi^s)
2129
2130 call rmhd_get_rfactor(w,x,ixi^l,ixo^l,r)
2131 res(ixo^s) = (gamma_1 * w(ixo^s, e_) + block%equi_vars(ixo^s,equi_pe0_,b0i)) /&
2132 ((w(ixo^s,rho_) +block%equi_vars(ixo^s,equi_rho0_,b0i))*r(ixo^s))
2133 end subroutine rmhd_get_temperature_from_eint_with_equi
2134
2135 subroutine rmhd_get_temperature_equi(w,x, ixI^L, ixO^L, res)
2137 integer, intent(in) :: ixi^l, ixo^l
2138 double precision, intent(in) :: w(ixi^s, 1:nw)
2139 double precision, intent(in) :: x(ixi^s, 1:ndim)
2140 double precision, intent(out):: res(ixi^s)
2141 double precision :: r(ixi^s)
2142
2143 call rmhd_get_rfactor(w,x,ixi^l,ixo^l,r)
2144 res(ixo^s)= block%equi_vars(ixo^s,equi_pe0_,b0i)/(block%equi_vars(ixo^s,equi_rho0_,b0i)*r(ixo^s))
2145 end subroutine rmhd_get_temperature_equi
2146
2147 subroutine rmhd_get_rho_equi(w, x, ixI^L, ixO^L, res)
2149 integer, intent(in) :: ixi^l, ixo^l
2150 double precision, intent(in) :: w(ixi^s, 1:nw)
2151 double precision, intent(in) :: x(ixi^s, 1:ndim)
2152 double precision, intent(out):: res(ixi^s)
2153 res(ixo^s) = block%equi_vars(ixo^s,equi_rho0_,b0i)
2154 end subroutine rmhd_get_rho_equi
2155
2156 subroutine rmhd_get_pe_equi(w,x, ixI^L, ixO^L, res)
2158 integer, intent(in) :: ixi^l, ixo^l
2159 double precision, intent(in) :: w(ixi^s, 1:nw)
2160 double precision, intent(in) :: x(ixi^s, 1:ndim)
2161 double precision, intent(out):: res(ixi^s)
2162 res(ixo^s) = block%equi_vars(ixo^s,equi_pe0_,b0i)
2163 end subroutine rmhd_get_pe_equi
2164
2165 !> Calculate total pressure within ixO^L including magnetic pressure
2166 subroutine rmhd_get_p_total(w,x,ixI^L,ixO^L,p)
2168 integer, intent(in) :: ixi^l, ixo^l
2169 double precision, intent(in) :: w(ixi^s,nw)
2170 double precision, intent(in) :: x(ixi^s,1:ndim)
2171 double precision, intent(out) :: p(ixi^s)
2172
2173 call rmhd_get_pthermal(w,x,ixi^l,ixo^l,p)
2174 p(ixo^s) = p(ixo^s) + 0.5d0 * sum(w(ixo^s, mag(:))**2, dim=ndim+1)
2175 end subroutine rmhd_get_p_total
2176
2177 !> Calculate radiation pressure within ixO^L
2178 subroutine rmhd_get_pradiation(w, x, ixI^L, ixO^L, prad, nth)
2180 use mod_fld
2181 use mod_afld
2182 integer, intent(in) :: ixi^l, ixo^l, nth
2183 double precision, intent(in) :: w(ixi^s, 1:nw)
2184 double precision, intent(in) :: x(ixi^s, 1:ndim)
2185 double precision, intent(out):: prad(ixo^s, 1:ndim, 1:ndim)
2186
2187 select case (rmhd_radiation_formalism)
2188 case('fld')
2189 call fld_get_radpress(w, x, ixi^l, ixo^l, prad, nth)
2190 case('afld')
2191 call afld_get_radpress(w, x, ixi^l, ixo^l, prad, nth)
2192 case default
2193 call mpistop('Radiation formalism unknown')
2194 end select
2195 end subroutine rmhd_get_pradiation
2196
2197 !> Calculates the sum of the gas pressure and the max Prad tensor element
2198 subroutine rmhd_get_pthermal_plus_pradiation(w, x, ixI^L, ixO^L, pth_plus_prad)
2200 integer, intent(in) :: ixi^l, ixo^l
2201 double precision, intent(in) :: w(ixi^s, 1:nw)
2202 double precision, intent(in) :: x(ixi^s, 1:ndim)
2203 double precision :: pth(ixi^s)
2204 double precision :: prad_tensor(ixo^s, 1:ndim, 1:ndim)
2205 double precision :: prad_max(ixo^s)
2206 double precision, intent(out) :: pth_plus_prad(ixi^s)
2207 integer :: ix^d
2208
2209 call rmhd_get_pthermal(w, x, ixi^l, ixo^l, pth)
2210 call rmhd_get_pradiation(w, x, ixi^l, ixo^l, prad_tensor, nghostcells)
2211 {do ix^d = ixomin^d,ixomax^d\}
2212 prad_max(ix^d) = maxval(prad_tensor(ix^d,:,:))
2213 {enddo\}
2214 !> filter cmax
2215 if (radio_acoustic_filter) then
2216 call rmhd_radio_acoustic_filter(x, ixi^l, ixo^l, prad_max)
2217 endif
2218 pth_plus_prad(ixo^s) = pth(ixo^s) + prad_max(ixo^s)
2220
2221 !> Filter peaks in cmax due to radiation energy density, used for debugging
2222 subroutine rmhd_radio_acoustic_filter(x, ixI^L, ixO^L, prad_max)
2224 integer, intent(in) :: ixi^l, ixo^l
2225 double precision, intent(in) :: x(ixi^s, 1:ndim)
2226 double precision, intent(inout) :: prad_max(ixo^s)
2227 double precision :: tmp_prad(ixi^s)
2228 integer :: ix^d, filter, idim
2229
2230 if (size_ra_filter .lt. 1) call mpistop("ra filter of size < 1 makes no sense")
2231 if (size_ra_filter .gt. nghostcells) call mpistop("ra filter of size < nghostcells makes no sense")
2232
2233 tmp_prad(ixi^s) = zero
2234 tmp_prad(ixo^s) = prad_max(ixo^s)
2235 do filter = 1,size_ra_filter
2236 do idim = 1,ndim
2237 ! {do ix^D = ixOmin^D+filter,ixOmax^D-filter\}
2238 {do ix^d = ixomin^d,ixomax^d\}
2239 prad_max(ix^d) = min(tmp_prad(ix^d),tmp_prad(ix^d+filter*kr(idim,^d)))
2240 prad_max(ix^d) = min(tmp_prad(ix^d),tmp_prad(ix^d-filter*kr(idim,^d)))
2241 {enddo\}
2242 enddo
2243 enddo
2244 end subroutine rmhd_radio_acoustic_filter
2245
2246 !> Calculates gas temperature
2247 subroutine rmhd_get_tgas(w, x, ixI^L, ixO^L, tgas)
2249 integer, intent(in) :: ixi^l, ixo^l
2250 double precision, intent(in) :: w(ixi^s, 1:nw)
2251 double precision, intent(in) :: x(ixi^s, 1:ndim)
2252 double precision :: pth(ixi^s)
2253 double precision, intent(out):: tgas(ixi^s)
2254
2255 call rmhd_get_pthermal(w, x, ixi^l, ixo^l, pth)
2256 tgas(ixi^s) = pth(ixi^s)/w(ixi^s,rho_)
2257 end subroutine rmhd_get_tgas
2258
2259 !> Calculates radiation temperature
2260 subroutine rmhd_get_trad(w, x, ixI^L, ixO^L, trad)
2262 use mod_constants
2263
2264 integer, intent(in) :: ixi^l, ixo^l
2265 double precision, intent(in) :: w(ixi^s, 1:nw)
2266 double precision, intent(in) :: x(ixi^s, 1:ndim)
2267 double precision, intent(out):: trad(ixi^s)
2268
2269 trad(ixi^s) = (w(ixi^s,r_e)*unit_pressure&
2270 /const_rad_a)**(1.d0/4.d0)/unit_temperature
2271 end subroutine rmhd_get_trad
2272
2273 !> Calculate fluxes within ixO^L without any splitting
2274 subroutine rmhd_get_flux(wC,w,x,ixI^L,ixO^L,idim,f)
2276 use mod_geometry
2277
2278 integer, intent(in) :: ixi^l, ixo^l, idim
2279 ! conservative w
2280 double precision, intent(in) :: wc(ixi^s,nw)
2281 ! primitive w
2282 double precision, intent(in) :: w(ixi^s,nw)
2283 double precision, intent(in) :: x(ixi^s,1:ndim)
2284 double precision,intent(out) :: f(ixi^s,nwflux)
2285 double precision :: vhall(ixi^s,1:ndir)
2286 double precision :: ptotal
2287 integer :: iw, ix^d
2288
2289 {do ix^db=ixomin^db,ixomax^db\}
2290 ! Get flux of density
2291 f(ix^d,rho_)=w(ix^d,mom(idim))*w(ix^d,rho_)
2292 ! f_i[m_k]=v_i*m_k-b_k*b_i
2293 ^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_)\
2294 ptotal=w(ix^d,p_)+half*(^c&w(ix^d,b^c_)**2+)
2295 ! normal one includes total pressure
2296 f(ix^d,mom(idim))=f(ix^d,mom(idim))+ptotal
2297 ! Get flux of total energy
2298 ! f_i[e]=v_i*e+v_i*ptotal-b_i*(b_k*v_k)
2299 f(ix^d,e_)=w(ix^d,mom(idim))*(wc(ix^d,e_)+ptotal)&
2300 -w(ix^d,mag(idim))*(^c&w(ix^d,b^c_)*w(ix^d,m^c_)+)
2301 ! f_i[b_k]=v_i*b_k-v_k*b_i
2302 ^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_)\
2303 {end do\}
2304 if(rmhd_glm) then
2305 {do ix^db=ixomin^db,ixomax^db\}
2306 f(ix^d,mag(idim))=w(ix^d,psi_)
2307 !f_i[psi]=Ch^2*b_{i} Eq. 24e and Eq. 38c Dedner et al 2002 JCP, 175, 645
2308 f(ix^d,psi_)=cmax_global**2*w(ix^d,mag(idim))
2309 {end do\}
2310 end if
2312 {do ix^db=ixomin^db,ixomax^db\}
2313 f(ix^d,r_e)=w(ix^d,mom(idim))*wc(ix^d,r_e)
2314 {end do\}
2315 else
2316 f(ixo^s,r_e)=zero
2317 endif
2318 ! Get flux of tracer
2319 do iw=1,rmhd_n_tracer
2320 {do ix^db=ixomin^db,ixomax^db\}
2321 f(ix^d,tracer(iw))=w(ix^d,mom(idim))*w(ix^d,tracer(iw))
2322 {end do\}
2323 end do
2325 {do ix^db=ixomin^db,ixomax^db\}
2326 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)
2327 f(ix^d,q_)=zero
2328 {end do\}
2329 end if
2330 end subroutine rmhd_get_flux
2331
2332 !> Calculate fluxes within ixO^L with possible splitting
2333 subroutine rmhd_get_flux_split(wC,w,x,ixI^L,ixO^L,idim,f)
2335 use mod_geometry
2336 integer, intent(in) :: ixi^l, ixo^l, idim
2337 ! conservative w
2338 double precision, intent(in) :: wc(ixi^s,nw)
2339 ! primitive w
2340 double precision, intent(in) :: w(ixi^s,nw)
2341 double precision, intent(in) :: x(ixi^s,1:ndim)
2342 double precision,intent(out) :: f(ixi^s,nwflux)
2343 double precision :: vhall(ixi^s,1:ndir)
2344 double precision :: ptotal, btotal(ixo^s,1:ndir)
2345 integer :: iw, ix^d
2346
2347 {do ix^db=ixomin^db,ixomax^db\}
2348 ! Get flux of density
2349 if(has_equi_rho0) then
2350 f(ix^d,rho_)=w(ix^d,mom(idim))*(w(ix^d,rho_)+block%equi_vars(ix^d,equi_rho0_,b0i))
2351 else
2352 f(ix^d,rho_)=w(ix^d,mom(idim))*w(ix^d,rho_)
2353 endif
2354 if(rmhd_energy) then
2355 ptotal=w(ix^d,p_)+half*(^c&w(ix^d,b^c_)**2+)
2356 else
2357 ptotal=rmhd_adiab*w(ix^d,rho_)**rmhd_gamma+half*(^c&w(ix^d,b^c_)**2+)
2358 if(has_equi_pe0) then
2359 ptotal=ptotal-block%equi_vars(ix^d,equi_pe0_,b0i)
2360 end if
2361 end if
2362 if(b0field) then
2363 ^c&btotal(ix^d,^c)=w(ix^d,b^c_)+block%B0(ix^d,^c,idim)\
2364 ptotal=ptotal+(^c&w(ix^d,b^c_)*block%B0(ix^d,^c,idim)+)
2365 ! Get flux of momentum and magnetic field
2366 ! f_i[m_k]=v_i*m_k-b_k*b_i
2367 ^c&f(ix^d,m^c_)=wc(ix^d,mom(idim))*w(ix^d,m^c_)-&
2368 btotal(ix^d,idim)*w(ix^d,b^c_)-w(ix^d,mag(idim))*block%B0(ix^d,^c,idim)\
2369 f(ix^d,mom(idim))=f(ix^d,mom(idim))+ptotal
2370 else
2371 ^c&btotal(ix^d,^c)=w(ix^d,b^c_)\
2372 ! Get flux of momentum and magnetic field
2373 ! f_i[m_k]=v_i*m_k-b_k*b_i
2374 ^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_)\
2375 f(ix^d,mom(idim))=f(ix^d,mom(idim))+ptotal
2376 end if
2377 ! f_i[b_k]=v_i*b_k-v_k*b_i
2378 ^c&f(ix^d,b^c_)=w(ix^d,mom(idim))*btotal(ix^d,^c)-btotal(ix^d,idim)*w(ix^d,m^c_)\
2379 ! Get flux of energy
2380 ! f_i[e]=v_i*e+v_i*ptotal-b_i*(b_k*v_k)
2381 if(rmhd_energy) then
2382 f(ix^d,e_)=w(ix^d,mom(idim))*(wc(ix^d,e_)+ptotal)&
2383 -btotal(ix^d,idim)*(^c&w(ix^d,b^c_)*w(ix^d,m^c_)+)
2384 end if
2385 {end do\}
2386 if(rmhd_glm) then
2387 {do ix^db=ixomin^db,ixomax^db\}
2388 f(ix^d,mag(idim))=w(ix^d,psi_)
2389 !f_i[psi]=Ch^2*b_{i} Eq. 24e and Eq. 38c Dedner et al 2002 JCP, 175, 645
2390 f(ix^d,psi_) = cmax_global**2*w(ix^d,mag(idim))
2391 {end do\}
2392 end if
2394 {do ix^db=ixomin^db,ixomax^db\}
2395 f(ix^d,r_e)=w(ix^d,mom(idim))*wc(ix^d,r_e)
2396 {end do\}
2397 else
2398 f(ixo^s,r_e)=zero
2399 endif
2400 ! Get flux of tracer
2401 do iw=1,rmhd_n_tracer
2402 {do ix^db=ixomin^db,ixomax^db\}
2403 f(ix^d,tracer(iw))=w(ix^d,mom(idim))*w(ix^d,tracer(iw))
2404 {end do\}
2405 end do
2407 {do ix^db=ixomin^db,ixomax^db\}
2408 f(ix^d,e_)=f(ix^d,e_)+w(ix^d,q_)*btotal(ix^d,idim)/(dsqrt(^c&btotal(ix^d,^c)**2+)+smalldouble)
2409 f(ix^d,q_)=zero
2410 {end do\}
2411 end if
2412 end subroutine rmhd_get_flux_split
2413
2414 !> use cell-center flux to get cell-face flux
2415 !> and get the source term as the divergence of the flux
2416 subroutine get_flux_on_cell_face(ixI^L,ixO^L,ff,src)
2418
2419 integer, intent(in) :: ixi^l, ixo^l
2420 double precision, dimension(:^D&,:), intent(inout) :: ff
2421 double precision, intent(out) :: src(ixi^s)
2422
2423 double precision :: ffc(ixi^s,1:ndim)
2424 double precision :: dxinv(ndim)
2425 integer :: idims, ix^d, ixa^l, ixb^l, ixc^l
2426
2427 ixa^l=ixo^l^ladd1;
2428 dxinv=1.d0/dxlevel
2429 ! cell corner flux in ffc
2430 ffc=0.d0
2431 ixcmax^d=ixomax^d; ixcmin^d=ixomin^d-1;
2432 {do ix^db=0,1\}
2433 ixbmin^d=ixcmin^d+ix^d;
2434 ixbmax^d=ixcmax^d+ix^d;
2435 ffc(ixc^s,1:ndim)=ffc(ixc^s,1:ndim)+ff(ixb^s,1:ndim)
2436 {end do\}
2437 ffc(ixc^s,1:ndim)=0.5d0**ndim*ffc(ixc^s,1:ndim)
2438 ! flux at cell face
2439 ff(ixi^s,1:ndim)=0.d0
2440 do idims=1,ndim
2441 ixb^l=ixo^l-kr(idims,^d);
2442 ixcmax^d=ixomax^d; ixcmin^d=ixbmin^d;
2443 {do ix^db=0,1 \}
2444 if({ ix^d==0 .and. ^d==idims | .or.}) then
2445 ixbmin^d=ixcmin^d-ix^d;
2446 ixbmax^d=ixcmax^d-ix^d;
2447 ff(ixc^s,idims)=ff(ixc^s,idims)+ffc(ixb^s,idims)
2448 end if
2449 {end do\}
2450 ff(ixc^s,idims)=ff(ixc^s,idims)*0.5d0**(ndim-1)
2451 end do
2452 src=0.d0
2453 if(slab_uniform) then
2454 do idims=1,ndim
2455 ff(ixa^s,idims)=dxinv(idims)*ff(ixa^s,idims)
2456 ixb^l=ixo^l-kr(idims,^d);
2457 src(ixo^s)=src(ixo^s)+ff(ixo^s,idims)-ff(ixb^s,idims)
2458 end do
2459 else
2460 do idims=1,ndim
2461 ff(ixa^s,idims)=ff(ixa^s,idims)*block%surfaceC(ixa^s,idims)
2462 ixb^l=ixo^l-kr(idims,^d);
2463 src(ixo^s)=src(ixo^s)+ff(ixo^s,idims)-ff(ixb^s,idims)
2464 end do
2465 src(ixo^s)=src(ixo^s)/block%dvolume(ixo^s)
2466 end if
2467 end subroutine get_flux_on_cell_face
2468
2469 !> w[iws]=w[iws]+qdt*S[iws,wCT] where S is the source based on wCT within ixO
2470 subroutine rmhd_add_source(qdt,dtfactor,ixI^L,ixO^L,wCT,wCTprim,w,x,qsourcesplit,active)
2474 use mod_cak_force, only: cak_add_source
2475
2476 integer, intent(in) :: ixi^l, ixo^l
2477 double precision, intent(in) :: qdt,dtfactor
2478 double precision, intent(in) :: wct(ixi^s,1:nw),wctprim(ixi^s,1:nw), x(ixi^s,1:ndim)
2479 double precision, intent(inout) :: w(ixi^s,1:nw)
2480 logical, intent(in) :: qsourcesplit
2481 logical, intent(inout) :: active
2482
2483 ! TODO local_timestep support is only added for splitting
2484 ! but not for other nonideal terms such gravity, RC, viscosity,..
2485 ! it will also only work for divbfix 'linde', which does not require
2486 ! modification as it does not use dt in the update
2487 if (.not. qsourcesplit) then
2488 if(has_equi_pe0) then
2489 active = .true.
2490 call add_pe0_divv(qdt,dtfactor,ixi^l,ixo^l,wctprim,w,x)
2491 end if
2493 call add_hypertc_source(qdt,ixi^l,ixo^l,wct,w,x,wctprim)
2494 end if
2495 ! Source for B0 splitting
2496 if (b0field) then
2497 active = .true.
2498 call add_source_b0split(qdt,dtfactor,ixi^l,ixo^l,wctprim,w,x)
2499 end if
2500 ! Sources for resistivity in eqs. for e, B1, B2 and B3
2501 if (abs(rmhd_eta)>smalldouble)then
2502 active = .true.
2503 call add_source_res2(qdt,ixi^l,ixo^l,wct,w,x)
2504 end if
2505 if (rmhd_eta_hyper>0.d0)then
2506 active = .true.
2507 call add_source_hyperres(qdt,ixi^l,ixo^l,wct,w,x)
2508 end if
2509 end if
2510 {^nooned
2511 if(source_split_divb .eqv. qsourcesplit) then
2512 ! Sources related to div B
2513 select case (type_divb)
2514 case (divb_ct)
2515 continue ! Do nothing
2516 case (divb_linde)
2517 active = .true.
2518 call add_source_linde(qdt,ixi^l,ixo^l,wct,w,x)
2519 case (divb_glm)
2520 active = .true.
2521 call add_source_glm(qdt,ixi^l,ixo^l,wct,w,x)
2522 case (divb_powel)
2523 active = .true.
2524 call add_source_powel(qdt,ixi^l,ixo^l,wctprim,w,x)
2525 case (divb_janhunen)
2526 active = .true.
2527 call add_source_janhunen(qdt,ixi^l,ixo^l,wctprim,w,x)
2528 case (divb_lindejanhunen)
2529 active = .true.
2530 call add_source_linde(qdt,ixi^l,ixo^l,wct,w,x)
2531 call add_source_janhunen(qdt,ixi^l,ixo^l,wctprim,w,x)
2532 case (divb_lindepowel)
2533 active = .true.
2534 call add_source_linde(qdt,ixi^l,ixo^l,wct,w,x)
2535 call add_source_powel(qdt,ixi^l,ixo^l,wctprim,w,x)
2536 case (divb_lindeglm)
2537 active = .true.
2538 call add_source_linde(qdt,ixi^l,ixo^l,wct,w,x)
2539 call add_source_glm(qdt,ixi^l,ixo^l,wct,w,x)
2540 case (divb_multigrid)
2541 continue ! Do nothing
2542 case (divb_none)
2543 ! Do nothing
2544 case default
2545 call mpistop('Unknown divB fix')
2546 end select
2547 end if
2548 }
2549 if(rmhd_viscosity) then
2550 call viscosity_add_source(qdt,ixi^l,ixo^l,wct,&
2551 w,x,rmhd_energy,qsourcesplit,active)
2552 end if
2553 if(rmhd_gravity) then
2554 call gravity_add_source(qdt,ixi^l,ixo^l,wct,wctprim,&
2555 w,x,gravity_energy,gravity_rhov,qsourcesplit,active)
2556 end if
2557 if (rmhd_cak_force) then
2558 call cak_add_source(qdt,ixi^l,ixo^l,wct,w,x,rmhd_energy,qsourcesplit,active)
2559 end if
2560 !> This is where the radiation force and heating/cooling are added
2561 call rmhd_add_radiation_source(qdt,ixi^l,ixo^l,wct,w,x,qsourcesplit,active)
2562 ! update temperature from new pressure, density, and old ionization degree
2564 if(.not.qsourcesplit) then
2565 active = .true.
2566 call rmhd_update_temperature(ixi^l,ixo^l,wct,w,x)
2567 end if
2568 end if
2569 end subroutine rmhd_add_source
2570
2571 subroutine rmhd_add_radiation_source(qdt,ixI^L,ixO^L,wCT,w,x,qsourcesplit,active)
2572 use mod_constants
2574 use mod_usr_methods
2575 use mod_fld
2576 use mod_afld
2577 integer, intent(in) :: ixi^l, ixo^l
2578 double precision, intent(in) :: qdt, x(ixi^s,1:ndim)
2579 double precision, intent(in) :: wct(ixi^s,1:nw)
2580 double precision, intent(inout) :: w(ixi^s,1:nw)
2581 logical, intent(in) :: qsourcesplit
2582 logical, intent(inout) :: active
2583 double precision :: cmax(ixi^s)
2584
2585 select case(rmhd_radiation_formalism)
2586 case('fld')
2587 if(fld_diff_scheme .eq. 'mg') call fld_get_diffcoef_central(w, wct, x, ixi^l, ixo^l)
2588 !> radiation force
2589 if(rmhd_radiation_force) call get_fld_rad_force(qdt,ixi^l,ixo^l,wct,w,x,rmhd_energy,qsourcesplit,active)
2590 call rmhd_handle_small_values(.true., w, x, ixi^l, ixo^l, 'fld_e_interact')
2591 case('afld')
2592 if(fld_diff_scheme .eq. 'mg') call afld_get_diffcoef_central(w, wct, x, ixi^l, ixo^l)
2593 !> radiation force
2594 if(rmhd_radiation_force) call get_afld_rad_force(qdt,ixi^l,ixo^l,wct,w,x,rmhd_energy,qsourcesplit,active)
2595 call rmhd_handle_small_values(.true., w, x, ixi^l, ixo^l, 'fld_e_interact')
2596 !> photon tiring, heating and cooling
2597 if(rmhd_energy) then
2598 if (rmhd_energy_interact) call get_afld_energy_interact(qdt,ixi^l,ixo^l,wct,w,x,rmhd_energy,qsourcesplit,active)
2599 endif
2600 case default
2601 call mpistop('Radiation formalism unknown')
2602 end select
2603 end subroutine rmhd_add_radiation_source
2604
2605 subroutine add_pe0_divv(qdt,dtfactor,ixI^L,ixO^L,wCT,w,x)
2607 use mod_geometry
2608 integer, intent(in) :: ixi^l, ixo^l
2609 double precision, intent(in) :: qdt,dtfactor
2610 double precision, intent(in) :: wct(ixi^s,1:nw), x(ixi^s,1:ndim)
2611 double precision, intent(inout) :: w(ixi^s,1:nw)
2612 double precision :: divv(ixi^s)
2613
2614 if(slab_uniform) then
2615 if(nghostcells .gt. 2) then
2616 call divvector(wct(ixi^s,mom(1:ndir)),ixi^l,ixo^l,divv,3)
2617 else
2618 call divvector(wct(ixi^s,mom(1:ndir)),ixi^l,ixo^l,divv,2)
2619 end if
2620 else
2621 call divvector(wct(ixi^s,mom(1:ndir)),ixi^l,ixo^l,divv)
2622 end if
2623 if(local_timestep) then
2624 w(ixo^s,e_)=w(ixo^s,e_)-dtfactor*block%dt(ixo^s)*block%equi_vars(ixo^s,equi_pe0_,0)*divv(ixo^s)
2625 else
2626 w(ixo^s,e_)=w(ixo^s,e_)-qdt*block%equi_vars(ixo^s,equi_pe0_,0)*divv(ixo^s)
2627 end if
2628 end subroutine add_pe0_divv
2629
2630 subroutine get_tau(ixI^L,ixO^L,w,Te,tau,sigT5)
2632 integer, intent(in) :: ixi^l, ixo^l
2633 double precision, dimension(ixI^S,1:nw), intent(in) :: w
2634 double precision, dimension(ixI^S), intent(in) :: te
2635 double precision, dimension(ixI^S), intent(out) :: tau,sigt5
2636 double precision :: dxmin,taumin
2637 double precision, dimension(ixI^S) :: sigt7,eint
2638 integer :: ix^d
2639
2640 taumin=4.d0
2641 !> w supposed to be wCTprim here
2642 if(rmhd_trac) then
2643 where(te(ixo^s) .lt. block%wextra(ixo^s,tcoff_))
2644 sigt5(ixo^s)=hypertc_kappa*sqrt(block%wextra(ixo^s,tcoff_)**5)
2645 sigt7(ixo^s)=sigt5(ixo^s)*block%wextra(ixo^s,tcoff_)
2646 else where
2647 sigt5(ixo^s)=hypertc_kappa*sqrt(te(ixo^s)**5)
2648 sigt7(ixo^s)=sigt5(ixo^s)*te(ixo^s)
2649 end where
2650 else
2651 sigt5(ixo^s)=hypertc_kappa*sqrt(te(ixo^s)**5)
2652 sigt7(ixo^s)=sigt5(ixo^s)*te(ixo^s)
2653 end if
2654 eint(ixo^s)=w(ixo^s,p_)/(rmhd_gamma-one)
2655 tau(ixo^s)=max(taumin*dt,sigt7(ixo^s)/eint(ixo^s)/cmax_global**2)
2656 end subroutine get_tau
2657
2658 subroutine add_hypertc_source(qdt,ixI^L,ixO^L,wCT,w,x,wCTprim)
2660 integer, intent(in) :: ixi^l,ixo^l
2661 double precision, intent(in) :: qdt
2662 double precision, dimension(ixI^S,1:ndim), intent(in) :: x
2663 double precision, dimension(ixI^S,1:nw), intent(in) :: wct,wctprim
2664 double precision, dimension(ixI^S,1:nw), intent(inout) :: w
2665 double precision :: invdx
2666 double precision, dimension(ixI^S) :: te,tau,sigt,htc_qsrc,tface,r
2667 double precision, dimension(ixI^S) :: htc_esrc,bsum,bunit
2668 double precision, dimension(ixI^S,1:ndim) :: btot
2669 integer :: idims
2670 integer :: hxc^l,hxo^l,ixc^l,jxc^l,jxo^l,kxc^l
2671
2672 call rmhd_get_rfactor(wctprim,x,ixi^l,ixi^l,r)
2673 !Te(ixI^S)=wCTprim(ixI^S,p_)/wCT(ixI^S,rho_)
2674 te(ixi^s)=wctprim(ixi^s,p_)/(r(ixi^s)*w(ixi^s,rho_))
2675 call get_tau(ixi^l,ixo^l,wctprim,te,tau,sigt)
2676 htc_qsrc=zero
2677 do idims=1,ndim
2678 if(b0field) then
2679 btot(ixo^s,idims)=wct(ixo^s,mag(idims))+block%B0(ixo^s,idims,0)
2680 else
2681 btot(ixo^s,idims)=wct(ixo^s,mag(idims))
2682 endif
2683 enddo
2684 bsum(ixo^s)=sqrt(sum(btot(ixo^s,:)**2,dim=ndim+1))+smalldouble
2685 do idims=1,ndim
2686 invdx=1.d0/dxlevel(idims)
2687 ixc^l=ixo^l;
2688 ixcmin^d=ixomin^d-kr(idims,^d);ixcmax^d=ixomax^d;
2689 jxc^l=ixc^l+kr(idims,^d);
2690 kxc^l=jxc^l+kr(idims,^d);
2691 hxc^l=ixc^l-kr(idims,^d);
2692 hxo^l=ixo^l-kr(idims,^d);
2693 tface(ixc^s)=(7.d0*(te(ixc^s)+te(jxc^s))-(te(hxc^s)+te(kxc^s)))/12.d0
2694 bunit(ixo^s)=btot(ixo^s,idims)/bsum(ixo^s)
2695 htc_qsrc(ixo^s)=htc_qsrc(ixo^s)+sigt(ixo^s)*bunit(ixo^s)*(tface(ixo^s)-tface(hxo^s))*invdx
2696 end do
2697 htc_qsrc(ixo^s)=(htc_qsrc(ixo^s)+wct(ixo^s,q_))/tau(ixo^s)
2698 w(ixo^s,q_)=w(ixo^s,q_)-qdt*htc_qsrc(ixo^s)
2699 end subroutine add_hypertc_source
2700
2701 !> Compute the Lorentz force (JxB)
2702 subroutine get_lorentz_force(ixI^L,ixO^L,w,JxB)
2704 integer, intent(in) :: ixi^l, ixo^l
2705 double precision, intent(in) :: w(ixi^s,1:nw)
2706 double precision, intent(inout) :: jxb(ixi^s,3)
2707 double precision :: a(ixi^s,3), b(ixi^s,3)
2708 ! For ndir=2 only 3rd component of J can exist, ndir=1 is impossible for MHD
2709 double precision :: current(ixi^s,7-2*ndir:3)
2710 integer :: idir, idirmin
2711
2712 b=0.0d0
2713 if(b0field) then
2714 do idir = 1, ndir
2715 b(ixo^s, idir) = w(ixo^s,mag(idir))+block%B0(ixo^s,idir,0)
2716 end do
2717 else
2718 do idir = 1, ndir
2719 b(ixo^s, idir) = w(ixo^s,mag(idir))
2720 end do
2721 end if
2722 ! store J current in a
2723 call get_current(w,ixi^l,ixo^l,idirmin,current)
2724 a=0.0d0
2725 do idir=7-2*ndir,3
2726 a(ixo^s,idir)=current(ixo^s,idir)
2727 end do
2728 call cross_product(ixi^l,ixo^l,a,b,jxb)
2729 end subroutine get_lorentz_force
2730
2731 !> Compute 1/(1+v_A^2/c^2) for semirelativistic MHD, where v_A is the Alfven
2732 !> velocity
2733 subroutine rmhd_gamma2_alfven(ixI^L, ixO^L, w, gamma_A2)
2735 integer, intent(in) :: ixi^l, ixo^l
2736 double precision, intent(in) :: w(ixi^s, nw)
2737 double precision, intent(out) :: gamma_a2(ixo^s)
2738 double precision :: rho(ixi^s)
2739
2740 ! rmhd_get_rho cannot be used as x is not a param
2741 if(has_equi_rho0) then
2742 rho(ixo^s) = w(ixo^s,rho_) + block%equi_vars(ixo^s,equi_rho0_,b0i)
2743 else
2744 rho(ixo^s) = w(ixo^s,rho_)
2745 endif
2746 ! Compute the inverse of 1 + B^2/(rho * c^2)
2747 gamma_a2(ixo^s) = 1.0d0/(1.0d0+rmhd_mag_en_all(w, ixi^l, ixo^l)/rho(ixo^s)*inv_squared_c)
2748 end subroutine rmhd_gamma2_alfven
2749
2750 !> Compute 1/sqrt(1+v_A^2/c^2) for semirelativisitic MHD, where v_A is the
2751 !> Alfven velocity
2752 function rmhd_gamma_alfven(w, ixI^L, ixO^L) result(gamma_A)
2754 integer, intent(in) :: ixi^l, ixo^l
2755 double precision, intent(in) :: w(ixi^s, nw)
2756 double precision :: gamma_a(ixo^s)
2757
2758 call rmhd_gamma2_alfven(ixi^l, ixo^l, w, gamma_a)
2759 gamma_a = sqrt(gamma_a)
2760 end function rmhd_gamma_alfven
2761
2762 subroutine rmhd_get_rho(w,x,ixI^L,ixO^L,rho)
2764 integer, intent(in) :: ixi^l, ixo^l
2765 double precision, intent(in) :: w(ixi^s,1:nw),x(ixi^s,1:ndim)
2766 double precision, intent(out) :: rho(ixi^s)
2767
2768 if(has_equi_rho0) then
2769 rho(ixo^s) = w(ixo^s,rho_) + block%equi_vars(ixo^s,equi_rho0_,b0i)
2770 else
2771 rho(ixo^s) = w(ixo^s,rho_)
2772 endif
2773 end subroutine rmhd_get_rho
2774
2775 !> handle small or negative internal energy
2776 subroutine rmhd_handle_small_ei(w, x, ixI^L, ixO^L, ie, subname)
2779 integer, intent(in) :: ixi^l,ixo^l, ie
2780 double precision, intent(inout) :: w(ixi^s,1:nw)
2781 double precision, intent(in) :: x(ixi^s,1:ndim)
2782 character(len=*), intent(in) :: subname
2783 double precision :: rho(ixi^s)
2784 integer :: idir
2785 logical :: flag(ixi^s,1:nw)
2786
2787 flag=.false.
2788 if(has_equi_pe0) then
2789 where(w(ixo^s,ie)+block%equi_vars(ixo^s,equi_pe0_,0)*inv_gamma_1<small_e)&
2790 flag(ixo^s,ie)=.true.
2791 else
2792 where(w(ixo^s,ie)<small_e) flag(ixo^s,ie)=.true.
2793 endif
2794 if(any(flag(ixo^s,ie))) then
2795 select case (small_values_method)
2796 case ("replace")
2797 if(has_equi_pe0) then
2798 where(flag(ixo^s,ie)) w(ixo^s,ie)=small_e - &
2799 block%equi_vars(ixo^s,equi_pe0_,0)*inv_gamma_1
2800 else
2801 where(flag(ixo^s,ie)) w(ixo^s,ie)=small_e
2802 endif
2803 case ("average")
2804 call small_values_average(ixi^l, ixo^l, w, x, flag, ie)
2805 case default
2806 ! small values error shows primitive variables
2807 w(ixo^s,e_)=w(ixo^s,e_)*gamma_1
2808 call rmhd_get_rho(w,x,ixi^l,ixo^l,rho)
2809 do idir = 1, ndir
2810 w(ixo^s, mom(idir)) = w(ixo^s, mom(idir))/rho(ixo^s)
2811 end do
2812 call small_values_error(w, x, ixi^l, ixo^l, flag, subname)
2813 end select
2814 end if
2815 end subroutine rmhd_handle_small_ei
2816
2817 subroutine rmhd_update_temperature(ixI^L,ixO^L,wCT,w,x)
2820
2821 integer, intent(in) :: ixi^l, ixo^l
2822 double precision, intent(in) :: wct(ixi^s,1:nw), x(ixi^s,1:ndim)
2823 double precision, intent(inout) :: w(ixi^s,1:nw)
2824
2825 double precision :: iz_h(ixo^s),iz_he(ixo^s), pth(ixi^s)
2826
2827 call ionization_degree_from_temperature(ixi^l,ixo^l,wct(ixi^s,te_),iz_h,iz_he)
2828
2829 call rmhd_get_pthermal(w,x,ixi^l,ixo^l,pth)
2830
2831 w(ixo^s,te_)=(2.d0+3.d0*he_abundance)*pth(ixo^s)/(w(ixo^s,rho_)*(1.d0+iz_h(ixo^s)+&
2832 he_abundance*(iz_he(ixo^s)*(iz_he(ixo^s)+1.d0)+1.d0)))
2833 end subroutine rmhd_update_temperature
2834
2835 !> Source terms after split off time-independent magnetic field
2836 subroutine add_source_b0split(qdt,dtfactor,ixI^L,ixO^L,wCT,w,x)
2838 integer, intent(in) :: ixi^l, ixo^l
2839 double precision, intent(in) :: qdt, dtfactor,wct(ixi^s,1:nw), x(ixi^s,1:ndim)
2840 double precision, intent(inout) :: w(ixi^s,1:nw)
2841 double precision :: a(ixi^s,3), b(ixi^s,3), axb(ixi^s,3)
2842 integer :: idir
2843
2844 a=0.d0
2845 b=0.d0
2846 ! for force-free field J0xB0 =0
2847 if(.not.b0field_forcefree) then
2848 ! store B0 magnetic field in b
2849 b(ixo^s,1:ndir)=block%B0(ixo^s,1:ndir,0)
2850 ! store J0 current in a
2851 do idir=7-2*ndir,3
2852 a(ixo^s,idir)=block%J0(ixo^s,idir)
2853 end do
2854 call cross_product(ixi^l,ixo^l,a,b,axb)
2855 if(local_timestep) then
2856 do idir=1,3
2857 axb(ixo^s,idir)=axb(ixo^s,idir)*block%dt(ixo^s)*dtfactor
2858 enddo
2859 else
2860 axb(ixo^s,:)=axb(ixo^s,:)*qdt
2861 endif
2862 ! add J0xB0 source term in momentum equations
2863 w(ixo^s,mom(1:ndir))=w(ixo^s,mom(1:ndir))+axb(ixo^s,1:ndir)
2864 end if
2865 if(total_energy) then
2866 a=0.d0
2867 ! for free-free field -(vxB0) dot J0 =0
2868 b(ixo^s,:)=wct(ixo^s,mag(:))
2869 ! store full magnetic field B0+B1 in b
2870 if(.not.b0field_forcefree) b(ixo^s,:)=b(ixo^s,:)+block%B0(ixo^s,:,0)
2871 ! store velocity in a
2872 a(ixi^s,1:ndir)=wct(ixi^s,mom(1:ndir))
2873 ! -E = a x b
2874 call cross_product(ixi^l,ixo^l,a,b,axb)
2875 if(local_timestep) then
2876 do idir=1,3
2877 axb(ixo^s,idir)=axb(ixo^s,idir)*block%dt(ixo^s)*dtfactor
2878 enddo
2879 else
2880 axb(ixo^s,:)=axb(ixo^s,:)*qdt
2881 endif
2882 ! add -(vxB) dot J0 source term in energy equation
2883 do idir=7-2*ndir,3
2884 w(ixo^s,e_)=w(ixo^s,e_)-axb(ixo^s,idir)*block%J0(ixo^s,idir)
2885 end do
2886 end if
2887 if (fix_small_values) call rmhd_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_B0')
2888 end subroutine add_source_b0split
2889
2890 !> Add resistive source to w within ixO Uses 3 point stencil (1 neighbour) in
2891 !> each direction, non-conservative. If the fourthorder precompiler flag is
2892 !> set, uses fourth order central difference for the laplacian. Then the
2893 !> stencil is 5 (2 neighbours).
2894 subroutine add_source_res1(qdt,ixI^L,ixO^L,wCT,w,x)
2896 use mod_usr_methods
2897 use mod_geometry
2898 integer, intent(in) :: ixi^l, ixo^l
2899 double precision, intent(in) :: qdt
2900 double precision, intent(in) :: wct(ixi^s,1:nw), x(ixi^s,1:ndim)
2901 double precision, intent(inout) :: w(ixi^s,1:nw)
2902 integer :: ixa^l,idir,jdir,kdir,idirmin,idim,jxo^l,hxo^l,ix
2903 integer :: lxo^l, kxo^l
2904 double precision :: tmp(ixi^s),tmp2(ixi^s)
2905 ! For ndir=2 only 3rd component of J can exist, ndir=1 is impossible for MHD
2906 double precision :: current(ixi^s,7-2*ndir:3),eta(ixi^s)
2907 double precision :: gradeta(ixi^s,1:ndim), bf(ixi^s,1:ndir)
2908
2909 ! Calculating resistive sources involve one extra layer
2910 if (rmhd_4th_order) then
2911 ixa^l=ixo^l^ladd2;
2912 else
2913 ixa^l=ixo^l^ladd1;
2914 end if
2915 if (iximin^d>ixamin^d.or.iximax^d<ixamax^d|.or.) &
2916 call mpistop("Error in add_source_res1: Non-conforming input limits")
2917 ! Calculate current density and idirmin
2918 call get_current(wct,ixi^l,ixo^l,idirmin,current)
2919 if (rmhd_eta>zero)then
2920 eta(ixa^s)=rmhd_eta
2921 gradeta(ixo^s,1:ndim)=zero
2922 else
2923 call usr_special_resistivity(wct,ixi^l,ixa^l,idirmin,x,current,eta)
2924 ! assumes that eta is not function of current?
2925 do idim=1,ndim
2926 call gradient(eta,ixi^l,ixo^l,idim,tmp)
2927 gradeta(ixo^s,idim)=tmp(ixo^s)
2928 end do
2929 end if
2930 if(b0field) then
2931 bf(ixi^s,1:ndir)=wct(ixi^s,mag(1:ndir))+block%B0(ixi^s,1:ndir,0)
2932 else
2933 bf(ixi^s,1:ndir)=wct(ixi^s,mag(1:ndir))
2934 end if
2935 do idir=1,ndir
2936 ! Put B_idir into tmp2 and eta*Laplace B_idir into tmp
2937 if (rmhd_4th_order) then
2938 tmp(ixo^s)=zero
2939 tmp2(ixi^s)=bf(ixi^s,idir)
2940 do idim=1,ndim
2941 lxo^l=ixo^l+2*kr(idim,^d);
2942 jxo^l=ixo^l+kr(idim,^d);
2943 hxo^l=ixo^l-kr(idim,^d);
2944 kxo^l=ixo^l-2*kr(idim,^d);
2945 tmp(ixo^s)=tmp(ixo^s)+&
2946 (-tmp2(lxo^s)+16.0d0*tmp2(jxo^s)-30.0d0*tmp2(ixo^s)+16.0d0*tmp2(hxo^s)-tmp2(kxo^s)) &
2947 /(12.0d0 * dxlevel(idim)**2)
2948 end do
2949 else
2950 tmp(ixo^s)=zero
2951 tmp2(ixi^s)=bf(ixi^s,idir)
2952 do idim=1,ndim
2953 jxo^l=ixo^l+kr(idim,^d);
2954 hxo^l=ixo^l-kr(idim,^d);
2955 tmp(ixo^s)=tmp(ixo^s)+&
2956 (tmp2(jxo^s)-2.0d0*tmp2(ixo^s)+tmp2(hxo^s))/dxlevel(idim)**2
2957 end do
2958 end if
2959 ! Multiply by eta
2960 tmp(ixo^s)=tmp(ixo^s)*eta(ixo^s)
2961 ! Subtract grad(eta) x J = eps_ijk d_j eta J_k if eta is non-constant
2962 if (rmhd_eta<zero)then
2963 do jdir=1,ndim; do kdir=idirmin,3
2964 if (lvc(idir,jdir,kdir)/=0)then
2965 if (lvc(idir,jdir,kdir)==1)then
2966 tmp(ixo^s)=tmp(ixo^s)-gradeta(ixo^s,jdir)*current(ixo^s,kdir)
2967 else
2968 tmp(ixo^s)=tmp(ixo^s)+gradeta(ixo^s,jdir)*current(ixo^s,kdir)
2969 end if
2970 end if
2971 end do; end do
2972 end if
2973 ! Add sources related to eta*laplB-grad(eta) x J to B and e
2974 w(ixo^s,mag(idir))=w(ixo^s,mag(idir))+qdt*tmp(ixo^s)
2975 if(total_energy) then
2976 w(ixo^s,e_)=w(ixo^s,e_)+qdt*tmp(ixo^s)*bf(ixo^s,idir)
2977 end if
2978 end do ! idir
2979 if(rmhd_energy) then
2980 ! de/dt+=eta*J**2
2981 w(ixo^s,e_)=w(ixo^s,e_)+qdt*eta(ixo^s)*sum(current(ixo^s,:)**2,dim=ndim+1)
2982 end if
2983 if (fix_small_values) call rmhd_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_res1')
2984 end subroutine add_source_res1
2985
2986 !> Add resistive source to w within ixO
2987 !> Uses 5 point stencil (2 neighbours) in each direction, conservative
2988 subroutine add_source_res2(qdt,ixI^L,ixO^L,wCT,w,x)
2990 use mod_usr_methods
2991 use mod_geometry
2992 integer, intent(in) :: ixi^l, ixo^l
2993 double precision, intent(in) :: qdt
2994 double precision, intent(in) :: wct(ixi^s,1:nw), x(ixi^s,1:ndim)
2995 double precision, intent(inout) :: w(ixi^s,1:nw)
2996 ! For ndir=2 only 3rd component of J can exist, ndir=1 is impossible for MHD
2997 double precision :: current(ixi^s,7-2*ndir:3),eta(ixi^s),curlj(ixi^s,1:3)
2998 double precision :: tmpvec(ixi^s,1:3),tmp(ixo^s)
2999 integer :: ixa^l,idir,idirmin,idirmin1
3000
3001 ixa^l=ixo^l^ladd2;
3002 if (iximin^d>ixamin^d.or.iximax^d<ixamax^d|.or.) &
3003 call mpistop("Error in add_source_res2: Non-conforming input limits")
3004 ixa^l=ixo^l^ladd1;
3005 ! Calculate current density within ixL: J=curl B, thus J_i=eps_ijk*d_j B_k
3006 ! Determine exact value of idirmin while doing the loop.
3007 call get_current(wct,ixi^l,ixa^l,idirmin,current)
3008 tmpvec=zero
3009 if(rmhd_eta>zero)then
3010 do idir=idirmin,3
3011 tmpvec(ixa^s,idir)=current(ixa^s,idir)*rmhd_eta
3012 end do
3013 else
3014 call usr_special_resistivity(wct,ixi^l,ixa^l,idirmin,x,current,eta)
3015 do idir=idirmin,3
3016 tmpvec(ixa^s,idir)=current(ixa^s,idir)*eta(ixa^s)
3017 end do
3018 end if
3019 ! dB/dt= -curl(J*eta), thus B_i=B_i-eps_ijk d_j Jeta_k
3020 call curlvector(tmpvec,ixi^l,ixo^l,curlj,idirmin1,1,3)
3021 if(stagger_grid) then
3022 if(ndim==2.and.ndir==3) then
3023 ! if 2.5D
3024 w(ixo^s,mag(ndir)) = w(ixo^s,mag(ndir))-qdt*curlj(ixo^s,ndir)
3025 end if
3026 else
3027 w(ixo^s,mag(1:ndir)) = w(ixo^s,mag(1:ndir))-qdt*curlj(ixo^s,1:ndir)
3028 end if
3029 if(rmhd_energy) then
3030 if(rmhd_eta>zero)then
3031 tmp(ixo^s)=qdt*rmhd_eta*sum(current(ixo^s,:)**2,dim=ndim+1)
3032 else
3033 tmp(ixo^s)=qdt*eta(ixo^s)*sum(current(ixo^s,:)**2,dim=ndim+1)
3034 end if
3035 if(total_energy) then
3036 ! de/dt= +div(B x Jeta) = eta J^2 - B dot curl(eta J)
3037 ! de1/dt= eta J^2 - B1 dot curl(eta J)
3038 w(ixo^s,e_)=w(ixo^s,e_)+tmp(ixo^s)-&
3039 qdt*sum(wct(ixo^s,mag(1:ndir))*curlj(ixo^s,1:ndir),dim=ndim+1)
3040 else
3041 ! add eta*J**2 source term in the internal energy equation
3042 w(ixo^s,e_)=w(ixo^s,e_)+tmp(ixo^s)
3043 end if
3044 end if
3045 if (fix_small_values) call rmhd_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_res2')
3046 end subroutine add_source_res2
3047
3048 !> Add Hyper-resistive source to w within ixO
3049 !> Uses 9 point stencil (4 neighbours) in each direction.
3050 subroutine add_source_hyperres(qdt,ixI^L,ixO^L,wCT,w,x)
3052 use mod_geometry
3053 integer, intent(in) :: ixi^l, ixo^l
3054 double precision, intent(in) :: qdt
3055 double precision, intent(in) :: wct(ixi^s,1:nw), x(ixi^s,1:ndim)
3056 double precision, intent(inout) :: w(ixi^s,1:nw)
3057 !.. local ..
3058 double precision :: current(ixi^s,7-2*ndir:3)
3059 double precision :: tmpvec(ixi^s,1:3),tmpvec2(ixi^s,1:3),tmp(ixi^s),ehyper(ixi^s,1:3)
3060 integer :: ixa^l,idir,jdir,kdir,idirmin,idirmin1
3061
3062 ixa^l=ixo^l^ladd3;
3063 if (iximin^d>ixamin^d.or.iximax^d<ixamax^d|.or.) &
3064 call mpistop("Error in add_source_hyperres: Non-conforming input limits")
3065 call get_current(wct,ixi^l,ixa^l,idirmin,current)
3066 tmpvec(ixa^s,1:ndir)=zero
3067 do jdir=idirmin,3
3068 tmpvec(ixa^s,jdir)=current(ixa^s,jdir)
3069 end do
3070 ixa^l=ixo^l^ladd2;
3071 call curlvector(tmpvec,ixi^l,ixa^l,tmpvec2,idirmin1,1,3)
3072 ixa^l=ixo^l^ladd1;
3073 tmpvec(ixa^s,1:ndir)=zero
3074 call curlvector(tmpvec2,ixi^l,ixa^l,tmpvec,idirmin1,1,3)
3075 ehyper(ixa^s,1:ndir) = - tmpvec(ixa^s,1:ndir)*rmhd_eta_hyper
3076 ixa^l=ixo^l;
3077 tmpvec2(ixa^s,1:ndir)=zero
3078 call curlvector(ehyper,ixi^l,ixa^l,tmpvec2,idirmin1,1,3)
3079 do idir=1,ndir
3080 w(ixo^s,mag(idir)) = w(ixo^s,mag(idir))-tmpvec2(ixo^s,idir)*qdt
3081 end do
3082 if(total_energy) then
3083 ! de/dt= +div(B x Ehyper)
3084 ixa^l=ixo^l^ladd1;
3085 tmpvec2(ixa^s,1:ndir)=zero
3086 do idir=1,ndir; do jdir=1,ndir; do kdir=idirmin,3
3087 tmpvec2(ixa^s,idir) = tmpvec(ixa^s,idir)&
3088 + lvc(idir,jdir,kdir)*wct(ixa^s,mag(jdir))*ehyper(ixa^s,kdir)
3089 end do; end do; end do
3090 tmp(ixo^s)=zero
3091 call divvector(tmpvec2,ixi^l,ixo^l,tmp)
3092 w(ixo^s,e_)=w(ixo^s,e_)+tmp(ixo^s)*qdt
3093 end if
3094 if (fix_small_values) call rmhd_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_hyperres')
3095 end subroutine add_source_hyperres
3096
3097 subroutine add_source_glm(qdt,ixI^L,ixO^L,wCT,w,x)
3098 ! Add divB related sources to w within ixO
3099 ! corresponding to Dedner JCP 2002, 175, 645 _equation 24_
3100 ! giving the EGLM-MHD scheme or GLM-MHD scheme
3102 use mod_geometry
3103 integer, intent(in) :: ixi^l, ixo^l
3104 double precision, intent(in) :: qdt, wct(ixi^s,1:nw), x(ixi^s,1:ndim)
3105 double precision, intent(inout) :: w(ixi^s,1:nw)
3106 double precision:: divb(ixi^s), gradpsi(ixi^s), ba(ixo^s,1:ndir)
3107 integer :: idir
3108
3109 ! dPsi/dt = - Ch^2/Cp^2 Psi
3110 if (rmhd_glm_alpha < zero) then
3111 w(ixo^s,psi_) = abs(rmhd_glm_alpha)*wct(ixo^s,psi_)
3112 else
3113 ! implicit update of Psi variable
3114 ! equation (27) in Mignone 2010 J. Com. Phys. 229, 2117
3115 if(slab_uniform) then
3116 w(ixo^s,psi_) = dexp(-qdt*cmax_global*rmhd_glm_alpha/minval(dxlevel(:)))*w(ixo^s,psi_)
3117 else
3118 w(ixo^s,psi_) = dexp(-qdt*cmax_global*rmhd_glm_alpha/minval(block%ds(ixo^s,:),dim=ndim+1))*w(ixo^s,psi_)
3119 end if
3120 end if
3121 if(rmhd_glm_extended) then
3122 if(b0field) then
3123 ba(ixo^s,1:ndir)=wct(ixo^s,mag(1:ndir))+block%B0(ixo^s,1:ndir,0)
3124 else
3125 ba(ixo^s,1:ndir)=wct(ixo^s,mag(1:ndir))
3126 end if
3127 ! gradient of Psi
3128 if(total_energy) then
3129 do idir=1,ndim
3130 select case(typegrad)
3131 case("central")
3132 call gradient(wct(ixi^s,psi_),ixi^l,ixo^l,idir,gradpsi)
3133 case("limited")
3134 call gradientl(wct(ixi^s,psi_),ixi^l,ixo^l,idir,gradpsi)
3135 end select
3136 ! e = e -qdt (b . grad(Psi))
3137 w(ixo^s,e_) = w(ixo^s,e_)-qdt*ba(ixo^s,idir)*gradpsi(ixo^s)
3138 end do
3139 end if
3140 ! We calculate now div B
3141 call get_divb(wct,ixi^l,ixo^l,divb,rmhd_divb_nth)
3142 ! m = m - qdt b div b
3143 do idir=1,ndir
3144 w(ixo^s,mom(idir))=w(ixo^s,mom(idir))-qdt*ba(ixo^s,idir)*divb(ixo^s)
3145 end do
3146 end if
3147 if (fix_small_values) call rmhd_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_glm')
3148 end subroutine add_source_glm
3149
3150 !> Add divB related sources to w within ixO corresponding to Powel
3151 subroutine add_source_powel(qdt,ixI^L,ixO^L,wCT,w,x)
3153 integer, intent(in) :: ixi^l, ixo^l
3154 double precision, intent(in) :: qdt, wct(ixi^s,1:nw), x(ixi^s,1:ndim)
3155 double precision, intent(inout) :: w(ixi^s,1:nw)
3156 double precision :: divb(ixi^s), ba(1:ndir)
3157 integer :: idir, ix^d
3158
3159 ! calculate div B
3160 call get_divb(wct,ixi^l,ixo^l,divb,rmhd_divb_nth)
3161 if(b0field) then
3162 {do ix^db=ixomin^db,ixomax^db\}
3163 ! b = b - qdt v * div b
3164 ^c&w(ix^d,b^c_)=w(ix^d,b^c_)-qdt*wct(ix^d,m^c_)*divb(ix^d)\
3165 ! m = m - qdt b div b
3166 ^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)\
3167 if (total_energy) then
3168 ! e = e - qdt (v . b) * div b
3169 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)
3170 end if
3171 {end do\}
3172 else
3173 {do ix^db=ixomin^db,ixomax^db\}
3174 ! b = b - qdt v * div b
3175 ^c&w(ix^d,b^c_)=w(ix^d,b^c_)-qdt*wct(ix^d,m^c_)*divb(ix^d)\
3176 ! m = m - qdt b div b
3177 ^c&w(ix^d,m^c_)=w(ix^d,m^c_)-qdt*wct(ix^d,b^c_)*divb(ix^d)\
3178 if (total_energy) then
3179 ! e = e - qdt (v . b) * div b
3180 w(ix^d,e_)=w(ix^d,e_)-qdt*(^c&wct(ix^d,m^c_)*wct(ix^d,b^c_)+)*divb(ix^d)
3181 end if
3182 {end do\}
3183 end if
3184 if (fix_small_values) call rmhd_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_powel')
3185 end subroutine add_source_powel
3186
3187 subroutine add_source_janhunen(qdt,ixI^L,ixO^L,wCT,w,x)
3188 ! Add divB related sources to w within ixO
3189 ! corresponding to Janhunen, just the term in the induction equation.
3191 integer, intent(in) :: ixi^l, ixo^l
3192 double precision, intent(in) :: qdt, wct(ixi^s,1:nw), x(ixi^s,1:ndim)
3193 double precision, intent(inout) :: w(ixi^s,1:nw)
3194 double precision :: divb(ixi^s)
3195 integer :: idir, ix^d
3196
3197 ! calculate div B
3198 call get_divb(wct,ixi^l,ixo^l,divb,rmhd_divb_nth)
3199 {do ix^db=ixomin^db,ixomax^db\}
3200 ! b = b - qdt v * div b
3201 ^c&w(ix^d,b^c_)=w(ix^d,b^c_)-qdt*wct(ix^d,m^c_)*divb(ix^d)\
3202 {end do\}
3203 if (fix_small_values) call rmhd_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_janhunen')
3204 end subroutine add_source_janhunen
3205
3206 subroutine add_source_linde(qdt,ixI^L,ixO^L,wCT,w,x)
3207 ! Add Linde's divB related sources to wnew within ixO
3209 use mod_geometry
3210 integer, intent(in) :: ixi^l, ixo^l
3211 double precision, intent(in) :: qdt, wct(ixi^s,1:nw), x(ixi^s,1:ndim)
3212 double precision, intent(inout) :: w(ixi^s,1:nw)
3213 double precision :: divb(ixi^s),graddivb(ixi^s)
3214 integer :: idim, idir, ixp^l, i^d, iside
3215 logical, dimension(-1:1^D&) :: leveljump
3216
3217 ! Calculate div B
3218 ixp^l=ixo^l^ladd1;
3219 call get_divb(wct,ixi^l,ixp^l,divb,rmhd_divb_nth)
3220 ! for AMR stability, retreat one cell layer from the boarders of level jump
3221 {do i^db=-1,1\}
3222 if(i^d==0|.and.) cycle
3223 if(neighbor_type(i^d,block%igrid)==2 .or. neighbor_type(i^d,block%igrid)==4) then
3224 leveljump(i^d)=.true.
3225 else
3226 leveljump(i^d)=.false.
3227 end if
3228 {end do\}
3229 ixp^l=ixo^l;
3230 do idim=1,ndim
3231 select case(idim)
3232 {case(^d)
3233 do iside=1,2
3234 i^dd=kr(^dd,^d)*(2*iside-3);
3235 if (leveljump(i^dd)) then
3236 if (iside==1) then
3237 ixpmin^d=ixomin^d-i^d
3238 else
3239 ixpmax^d=ixomax^d-i^d
3240 end if
3241 end if
3242 end do
3243 \}
3244 end select
3245 end do
3246 ! Add Linde's diffusive terms
3247 do idim=1,ndim
3248 ! Calculate grad_idim(divb)
3249 select case(typegrad)
3250 case("central")
3251 call gradient(divb,ixi^l,ixp^l,idim,graddivb)
3252 case("limited")
3253 call gradientl(divb,ixi^l,ixp^l,idim,graddivb)
3254 end select
3255 ! Multiply by Linde's eta*dt = divbdiff*(c_max*dx)*dt = divbdiff*dx**2
3256 if (slab_uniform) then
3257 graddivb(ixp^s)=graddivb(ixp^s)*divbdiff/(^d&1.0d0/dxlevel(^d)**2+)
3258 else
3259 graddivb(ixp^s)=graddivb(ixp^s)*divbdiff &
3260 /(^d&1.0d0/block%ds(ixp^s,^d)**2+)
3261 end if
3262 w(ixp^s,mag(idim))=w(ixp^s,mag(idim))+graddivb(ixp^s)
3263
3264 if (typedivbdiff=='all' .and. total_energy) then
3265 ! e += B_idim*eta*grad_idim(divb)
3266 w(ixp^s,e_)=w(ixp^s,e_)+wct(ixp^s,mag(idim))*graddivb(ixp^s)
3267 end if
3268 end do
3269 if (fix_small_values) call rmhd_handle_small_values(.false.,w,x,ixi^l,ixo^l,'add_source_linde')
3270 end subroutine add_source_linde
3271
3272 !> get dimensionless div B = |divB| * volume / area / |B|
3273 subroutine get_normalized_divb(w,ixI^L,ixO^L,divb)
3275 integer, intent(in) :: ixi^l, ixo^l
3276 double precision, intent(in) :: w(ixi^s,1:nw)
3277 double precision :: divb(ixi^s), dsurface(ixi^s)
3278 double precision :: invb(ixo^s)
3279 integer :: ixa^l,idims
3280
3281 call get_divb(w,ixi^l,ixo^l,divb)
3282 invb(ixo^s)=sqrt(rmhd_mag_en_all(w,ixi^l,ixo^l))
3283 where(invb(ixo^s)/=0.d0)
3284 invb(ixo^s)=1.d0/invb(ixo^s)
3285 end where
3286 if(slab_uniform) then
3287 divb(ixo^s)=0.5d0*abs(divb(ixo^s))*invb(ixo^s)/sum(1.d0/dxlevel(:))
3288 else
3289 ixamin^d=ixomin^d-1;
3290 ixamax^d=ixomax^d-1;
3291 dsurface(ixo^s)= sum(block%surfaceC(ixo^s,:),dim=ndim+1)
3292 do idims=1,ndim
3293 ixa^l=ixo^l-kr(idims,^d);
3294 dsurface(ixo^s)=dsurface(ixo^s)+block%surfaceC(ixa^s,idims)
3295 end do
3296 divb(ixo^s)=abs(divb(ixo^s))*invb(ixo^s)*&
3297 block%dvolume(ixo^s)/dsurface(ixo^s)
3298 end if
3299 end subroutine get_normalized_divb
3300
3301 !> Calculate idirmin and the idirmin:3 components of the common current array
3302 !> make sure that dxlevel(^D) is set correctly.
3303 subroutine get_current(w,ixI^L,ixO^L,idirmin,current)
3305 use mod_geometry
3306 integer, intent(in) :: ixo^l, ixi^l
3307 double precision, intent(in) :: w(ixi^s,1:nw)
3308 integer, intent(out) :: idirmin
3309 ! For ndir=2 only 3rd component of J can exist, ndir=1 is impossible for MHD
3310 double precision :: current(ixi^s,7-2*ndir:3)
3311 integer :: idir, idirmin0
3312
3313 idirmin0 = 7-2*ndir
3314 call curlvector(w(ixi^s,mag(1:ndir)),ixi^l,ixo^l,current,idirmin,idirmin0,ndir)
3315 if(b0field) current(ixo^s,idirmin0:3)=current(ixo^s,idirmin0:3)+&
3316 block%J0(ixo^s,idirmin0:3)
3317 end subroutine get_current
3318
3319 !> If resistivity is not zero, check diffusion time limit for dt
3320 subroutine rmhd_get_dt(w,ixI^L,ixO^L,dtnew,dx^D,x)
3322 use mod_usr_methods
3324 use mod_gravity, only: gravity_get_dt
3325 use mod_cak_force, only: cak_get_dt
3326 use mod_fld, only: fld_radforce_get_dt
3328 integer, intent(in) :: ixi^l, ixo^l
3329 double precision, intent(inout) :: dtnew
3330 double precision, intent(in) :: dx^d
3331 double precision, intent(in) :: w(ixi^s,1:nw)
3332 double precision, intent(in) :: x(ixi^s,1:ndim)
3333 double precision :: dxarr(ndim)
3334 double precision :: current(ixi^s,7-2*ndir:3),eta(ixi^s)
3335 integer :: idirmin,idim
3336
3337 dtnew = bigdouble
3338
3339 if (.not. dt_c) then
3340 ^d&dxarr(^d)=dx^d;
3341 if (rmhd_eta>zero)then
3342 dtnew=dtdiffpar*minval(dxarr(1:ndim))**2/rmhd_eta
3343 else if (rmhd_eta<zero)then
3344 call get_current(w,ixi^l,ixo^l,idirmin,current)
3345 call usr_special_resistivity(w,ixi^l,ixo^l,idirmin,x,current,eta)
3346 dtnew=bigdouble
3347 do idim=1,ndim
3348 if(slab_uniform) then
3349 dtnew=min(dtnew,&
3350 dtdiffpar/(smalldouble+maxval(eta(ixo^s)/dxarr(idim)**2)))
3351 else
3352 dtnew=min(dtnew,&
3353 dtdiffpar/(smalldouble+maxval(eta(ixo^s)/block%ds(ixo^s,idim)**2)))
3354 end if
3355 end do
3356 end if
3357 if(rmhd_eta_hyper>zero) then
3358 if(slab_uniform) then
3359 dtnew=min(dtdiffpar*minval(dxarr(1:ndim))**4/rmhd_eta_hyper,dtnew)
3360 else
3361 dtnew=min(dtdiffpar*minval(block%ds(ixo^s,1:ndim))**4/rmhd_eta_hyper,dtnew)
3362 end if
3363 end if
3364 if(rmhd_radiation_force) then
3365 select case(rmhd_radiation_formalism)
3366 case('fld')
3367 call fld_radforce_get_dt(w,ixi^l,ixo^l,dtnew,dx^d,x)
3368 case('afld')
3369 call afld_radforce_get_dt(w,ixi^l,ixo^l,dtnew,dx^d,x)
3370 case default
3371 call mpistop('Radiation formalism unknown')
3372 end select
3373 endif
3374 if(rmhd_viscosity) then
3375 call viscosity_get_dt(w,ixi^l,ixo^l,dtnew,dx^d,x)
3376 end if
3377 if(rmhd_gravity) then
3378 call gravity_get_dt(w,ixi^l,ixo^l,dtnew,dx^d,x)
3379 end if
3380 if (rmhd_cak_force) then
3381 call cak_get_dt(w,ixi^l,ixo^l,dtnew,dx^d,x)
3382 end if
3383 else
3384 {^ifoned dtnew = dx1*unit_velocity/const_c}
3385 {^nooned dtnew = min(dx^d*unit_velocity/const_c)}
3386 endif
3387 end subroutine rmhd_get_dt
3388
3389 ! Add geometrical source terms to w
3390 subroutine rmhd_add_source_geom(qdt,dtfactor,ixI^L,ixO^L,wCT,wprim,w,x)
3392 use mod_geometry
3393 integer, intent(in) :: ixi^l, ixo^l
3394 double precision, intent(in) :: qdt, dtfactor,x(ixi^s,1:ndim)
3395 double precision, intent(inout) :: wct(ixi^s,1:nw),wprim(ixi^s,1:nw),w(ixi^s,1:nw)
3396 double precision :: tmp,tmp1,invr,cot
3397 integer :: ix^d
3398 integer :: mr_,mphi_ ! Polar var. names
3399 integer :: br_,bphi_
3400
3401 mr_=mom(1); mphi_=mom(1)-1+phi_ ! Polar var. names
3402 br_=mag(1); bphi_=mag(1)-1+phi_
3403 select case (coordinate)
3404 case (cylindrical)
3405 {do ix^db=ixomin^db,ixomax^db\}
3406 ! include dt in invr, invr is always used with qdt
3407 if(local_timestep) then
3408 invr=block%dt(ix^d) * dtfactor/x(ix^d,1)
3409 else
3410 invr=qdt/x(ix^d,1)
3411 end if
3412 if(rmhd_energy) then
3413 tmp=wprim(ix^d,p_)+half*(^c&wprim(ix^d,b^c_)**2+)
3414 else
3415 tmp=rmhd_adiab*wprim(ix^d,rho_)**rmhd_gamma+half*(^c&wprim(ix^d,b^c_)**2+)
3416 end if
3417 if(phi_>0) then
3418 w(ix^d,mr_)=w(ix^d,mr_)+invr*(tmp-&
3419 wprim(ix^d,bphi_)**2+wprim(ix^d,mphi_)*wct(ix^d,mphi_))
3420 w(ix^d,mphi_)=w(ix^d,mphi_)+invr*(&
3421 -wct(ix^d,mphi_)*wprim(ix^d,mr_) &
3422 +wprim(ix^d,bphi_)*wprim(ix^d,br_))
3423 if(.not.stagger_grid) then
3424 w(ix^d,bphi_)=w(ix^d,bphi_)+invr*&
3425 (wprim(ix^d,bphi_)*wprim(ix^d,mr_) &
3426 -wprim(ix^d,br_)*wprim(ix^d,mphi_))
3427 end if
3428 else
3429 w(ix^d,mr_)=w(ix^d,mr_)+invr*tmp
3430 end if
3431 if(rmhd_glm) w(ix^d,br_)=w(ix^d,br_)+wprim(ix^d,psi_)*invr
3432 {end do\}
3433 case (spherical)
3434 {do ix^db=ixomin^db,ixomax^db\}
3435 ! include dt in invr, invr is always used with qdt
3436 if(local_timestep) then
3437 invr=block%dt(ix^d) * dtfactor/x(ix^d,1)
3438 else
3439 invr=qdt/x(ix^d,1)
3440 end if
3441 if(rmhd_energy) then
3442 tmp1=wprim(ix^d,p_)+half*(^c&wprim(ix^d,b^c_)**2+)
3443 else
3444 tmp1=rmhd_adiab*wprim(ix^d,rho_)**rmhd_gamma+half*(^c&wprim(ix^d,b^c_)**2+)
3445 end if
3446 ! m1
3447 {^ifonec
3448 w(ix^d,mom(1))=w(ix^d,mom(1))+two*tmp1*invr
3449 }
3450 {^noonec
3451 w(ix^d,mom(1))=w(ix^d,mom(1))+invr*&
3452 (two*tmp1+(^ce&wprim(ix^d,m^ce_)*wct(ix^d,m^ce_)-wprim(ix^d,b^ce_)**2+))
3453 }
3454 ! b1
3455 if(rmhd_glm) then
3456 w(ix^d,mag(1))=w(ix^d,mag(1))+invr*2.0d0*wprim(ix^d,psi_)
3457 end if
3458 {^ifoned
3459 cot=0.d0
3460 }
3461 {^nooned
3462 cot=1.d0/tan(x(ix^d,2))
3463 }
3464 {^iftwoc
3465 ! m2
3466 w(ix^d,mom(2))=w(ix^d,mom(2))+invr*(tmp1*cot-wprim(ix^d,m1_)*wct(ix^d,m2_)&
3467 +wprim(ix^d,b1_)*wprim(ix^d,b2_))
3468 ! b2
3469 if(.not.stagger_grid) then
3470 tmp=wprim(ix^d,m1_)*wprim(ix^d,b2_)-wprim(ix^d,m2_)*wprim(ix^d,b1_)
3471 if(rmhd_glm) then
3472 tmp=tmp+wprim(ix^d,psi_)*cot
3473 end if
3474 w(ix^d,mag(2))=w(ix^d,mag(2))+tmp*invr
3475 end if
3476 }
3477 {^ifthreec
3478 ! m2
3479 w(ix^d,mom(2))=w(ix^d,mom(2))+invr*(tmp1*cot-wprim(ix^d,m1_)*wct(ix^d,m2_)&
3480 +wprim(ix^d,b1_)*wprim(ix^d,b2_)&
3481 +(wprim(ix^d,m3_)*wct(ix^d,m3_)-wprim(ix^d,b3_)**2)*cot)
3482 ! b2
3483 if(.not.stagger_grid) then
3484 tmp=wprim(ix^d,m1_)*wprim(ix^d,b2_)-wprim(ix^d,m2_)*wprim(ix^d,b1_)
3485 if(rmhd_glm) then
3486 tmp=tmp+wprim(ix^d,psi_)*cot
3487 end if
3488 w(ix^d,mag(2))=w(ix^d,mag(2))+tmp*invr
3489 end if
3490 ! m3
3491 w(ix^d,mom(3))=w(ix^d,mom(3))-invr*&
3492 (wprim(ix^d,m3_)*wct(ix^d,m1_) &
3493 -wprim(ix^d,b3_)*wprim(ix^d,b1_) &
3494 +(wprim(ix^d,m2_)*wct(ix^d,m3_) &
3495 -wprim(ix^d,b2_)*wprim(ix^d,b3_))*cot)
3496 ! b3
3497 if(.not.stagger_grid) then
3498 w(ix^d,mag(3))=w(ix^d,mag(3))+invr*&
3499 (wprim(ix^d,m1_)*wprim(ix^d,b3_) &
3500 -wprim(ix^d,m3_)*wprim(ix^d,b1_) &
3501 -(wprim(ix^d,m3_)*wprim(ix^d,b2_) &
3502 -wprim(ix^d,m2_)*wprim(ix^d,b3_))*cot)
3503 end if
3504 }
3505 {end do\}
3506 end select
3507 end subroutine rmhd_add_source_geom
3508
3509 ! Add geometrical source terms to w
3510 subroutine rmhd_add_source_geom_split(qdt,dtfactor, ixI^L,ixO^L,wCT,wprim,w,x)
3512 use mod_geometry
3513 integer, intent(in) :: ixi^l, ixo^l
3514 double precision, intent(in) :: qdt, dtfactor, x(ixi^s,1:ndim)
3515 double precision, intent(inout) :: wct(ixi^s,1:nw), wprim(ixi^s,1:nw),w(ixi^s,1:nw)
3516 double precision :: tmp(ixi^s),tmp1(ixi^s),tmp2(ixi^s),invrho(ixo^s),invr(ixo^s)
3517 integer :: iw,idir, h1x^l{^nooned, h2x^l}
3518 integer :: mr_,mphi_ ! Polar var. names
3519 integer :: br_,bphi_
3520
3521 mr_=mom(1); mphi_=mom(1)-1+phi_ ! Polar var. names
3522 br_=mag(1); bphi_=mag(1)-1+phi_
3523 if(has_equi_rho0) then
3524 invrho(ixo^s) = 1d0/(wct(ixo^s,rho_) + block%equi_vars(ixo^s,equi_rho0_,b0i))
3525 else
3526 invrho(ixo^s) = 1d0/wct(ixo^s,rho_)
3527 end if
3528 ! include dt in invr, invr is always used with qdt
3529 if(local_timestep) then
3530 invr(ixo^s) = block%dt(ixo^s) * dtfactor/x(ixo^s,1)
3531 else
3532 invr(ixo^s) = qdt/x(ixo^s,1)
3533 end if
3534
3535 select case (coordinate)
3536 case (cylindrical)
3537 call rmhd_get_p_total(wct,x,ixi^l,ixo^l,tmp)
3538 if(phi_>0) then
3539 w(ixo^s,mr_)=w(ixo^s,mr_)+invr(ixo^s)*(tmp(ixo^s)-&
3540 wct(ixo^s,bphi_)**2+wct(ixo^s,mphi_)**2*invrho(ixo^s))
3541 w(ixo^s,mphi_)=w(ixo^s,mphi_)+qdt*invr(ixo^s)*(&
3542 -wct(ixo^s,mphi_)*wct(ixo^s,mr_)*invrho(ixo^s) &
3543 +wct(ixo^s,bphi_)*wct(ixo^s,br_))
3544 if(.not.stagger_grid) then
3545 w(ixo^s,bphi_)=w(ixo^s,bphi_)+invr(ixo^s)*&
3546 (wct(ixo^s,bphi_)*wct(ixo^s,mr_) &
3547 -wct(ixo^s,br_)*wct(ixo^s,mphi_)) &
3548 *invrho(ixo^s)
3549 end if
3550 else
3551 w(ixo^s,mr_)=w(ixo^s,mr_)+invr(ixo^s)*tmp(ixo^s)
3552 end if
3553 if(rmhd_glm) w(ixo^s,br_)=w(ixo^s,br_)+wct(ixo^s,psi_)*invr(ixo^s)
3554 case (spherical)
3555 h1x^l=ixo^l-kr(1,^d); {^nooned h2x^l=ixo^l-kr(2,^d);}
3556 call rmhd_get_p_total(wct,x,ixi^l,ixo^l,tmp1)
3557 tmp(ixo^s)=tmp1(ixo^s)
3558 if(b0field) then
3559 tmp2(ixo^s)=sum(block%B0(ixo^s,:,0)*wct(ixo^s,mag(:)),dim=ndim+1)
3560 tmp(ixo^s)=tmp(ixo^s)+tmp2(ixo^s)
3561 end if
3562 ! m1
3563 tmp(ixo^s)=tmp(ixo^s)*x(ixo^s,1) &
3564 *(block%surfaceC(ixo^s,1)-block%surfaceC(h1x^s,1))/block%dvolume(ixo^s)
3565 if(ndir>1) then
3566 do idir=2,ndir
3567 tmp(ixo^s)=tmp(ixo^s)+wct(ixo^s,mom(idir))**2*invrho(ixo^s)-wct(ixo^s,mag(idir))**2
3568 if(b0field) tmp(ixo^s)=tmp(ixo^s)-2.0d0*block%B0(ixo^s,idir,0)*wct(ixo^s,mag(idir))
3569 end do
3570 end if
3571 w(ixo^s,mom(1))=w(ixo^s,mom(1))+tmp(ixo^s)*invr(ixo^s)
3572 ! b1
3573 if(rmhd_glm) then
3574 w(ixo^s,mag(1))=w(ixo^s,mag(1))+invr(ixo^s)*2.0d0*wct(ixo^s,psi_)
3575 end if
3576 {^nooned
3577 ! m2
3578 tmp(ixo^s)=tmp1(ixo^s)
3579 if(b0field) then
3580 tmp(ixo^s)=tmp(ixo^s)+tmp2(ixo^s)
3581 end if
3582 if(local_timestep) then
3583 tmp1(ixo^s) = block%dt(ixo^s) * tmp(ixo^s)
3584 else
3585 tmp1(ixo^s) = qdt * tmp(ixo^s)
3586 endif
3587 ! This will make hydrostatic p=const an exact solution
3588 w(ixo^s,mom(2))=w(ixo^s,mom(2))+tmp1(ixo^s) &
3589 *(block%surfaceC(ixo^s,2)-block%surfaceC(h2x^s,2)) &
3590 /block%dvolume(ixo^s)
3591 tmp(ixo^s)=-(wct(ixo^s,mom(1))*wct(ixo^s,mom(2))*invrho(ixo^s) &
3592 -wct(ixo^s,mag(1))*wct(ixo^s,mag(2)))
3593 if (b0field) then
3594 tmp(ixo^s)=tmp(ixo^s)+block%B0(ixo^s,1,0)*wct(ixo^s,mag(2)) &
3595 +wct(ixo^s,mag(1))*block%B0(ixo^s,2,0)
3596 end if
3597 if(ndir==3) then
3598 tmp(ixo^s)=tmp(ixo^s)+(wct(ixo^s,mom(3))**2*invrho(ixo^s) &
3599 -wct(ixo^s,mag(3))**2)*dcos(x(ixo^s,2))/dsin(x(ixo^s,2))
3600 if (b0field) then
3601 tmp(ixo^s)=tmp(ixo^s)-2.0d0*block%B0(ixo^s,3,0)*wct(ixo^s,mag(3))&
3602 *dcos(x(ixo^s,2))/dsin(x(ixo^s,2))
3603 end if
3604 end if
3605 w(ixo^s,mom(2))=w(ixo^s,mom(2))+tmp(ixo^s)*invr(ixo^s)
3606 ! b2
3607 if(.not.stagger_grid) then
3608 tmp(ixo^s)=(wct(ixo^s,mom(1))*wct(ixo^s,mag(2)) &
3609 -wct(ixo^s,mom(2))*wct(ixo^s,mag(1)))*invrho(ixo^s)
3610 if(b0field) then
3611 tmp(ixo^s)=tmp(ixo^s)+(wct(ixo^s,mom(1))*block%B0(ixo^s,2,0) &
3612 -wct(ixo^s,mom(2))*block%B0(ixo^s,1,0))*invrho(ixo^s)
3613 end if
3614 if(rmhd_glm) then
3615 tmp(ixo^s)=tmp(ixo^s) &
3616 + dcos(x(ixo^s,2))/dsin(x(ixo^s,2))*wct(ixo^s,psi_)
3617 end if
3618 w(ixo^s,mag(2))=w(ixo^s,mag(2))+tmp(ixo^s)*invr(ixo^s)
3619 end if
3620 }
3621 if(ndir==3) then
3622 ! m3
3623 tmp(ixo^s)=-(wct(ixo^s,mom(3))*wct(ixo^s,mom(1))*invrho(ixo^s) &
3624 -wct(ixo^s,mag(3))*wct(ixo^s,mag(1))) {^nooned &
3625 -(wct(ixo^s,mom(2))*wct(ixo^s,mom(3))*invrho(ixo^s) &
3626 -wct(ixo^s,mag(2))*wct(ixo^s,mag(3))) &
3627 *dcos(x(ixo^s,2))/dsin(x(ixo^s,2)) }
3628 if (b0field) then
3629 tmp(ixo^s)=tmp(ixo^s)+block%B0(ixo^s,1,0)*wct(ixo^s,mag(3)) &
3630 +wct(ixo^s,mag(1))*block%B0(ixo^s,3,0) {^nooned &
3631 +(block%B0(ixo^s,2,0)*wct(ixo^s,mag(3)) &
3632 +wct(ixo^s,mag(2))*block%B0(ixo^s,3,0)) &
3633 *dcos(x(ixo^s,2))/dsin(x(ixo^s,2)) }
3634 end if
3635 w(ixo^s,mom(3))=w(ixo^s,mom(3))+tmp(ixo^s)*invr(ixo^s)
3636 ! b3
3637 if(.not.stagger_grid) then
3638 tmp(ixo^s)=(wct(ixo^s,mom(1))*wct(ixo^s,mag(3)) &
3639 -wct(ixo^s,mom(3))*wct(ixo^s,mag(1)))*invrho(ixo^s) {^nooned &
3640 -(wct(ixo^s,mom(3))*wct(ixo^s,mag(2)) &
3641 -wct(ixo^s,mom(2))*wct(ixo^s,mag(3)))*dcos(x(ixo^s,2)) &
3642 *invrho(ixo^s)/dsin(x(ixo^s,2)) }
3643 if (b0field) then
3644 tmp(ixo^s)=tmp(ixo^s)+(wct(ixo^s,mom(1))*block%B0(ixo^s,3,0) &
3645 -wct(ixo^s,mom(3))*block%B0(ixo^s,1,0))*invrho(ixo^s){^nooned &
3646 -(wct(ixo^s,mom(3))*block%B0(ixo^s,2,0) &
3647 -wct(ixo^s,mom(2))*block%B0(ixo^s,3,0))*dcos(x(ixo^s,2)) &
3648 *invrho(ixo^s)/dsin(x(ixo^s,2)) }
3649 end if
3650 w(ixo^s,mag(3))=w(ixo^s,mag(3))+tmp(ixo^s)*invr(ixo^s)
3651 end if
3652 end if
3653 end select
3654 end subroutine rmhd_add_source_geom_split
3655
3656 !> Compute 2 times total magnetic energy
3657 function rmhd_mag_en_all(w, ixI^L, ixO^L) result(mge)
3659 integer, intent(in) :: ixi^l, ixo^l
3660 double precision, intent(in) :: w(ixi^s, nw)
3661 double precision :: mge(ixo^s)
3662
3663 if (b0field) then
3664 mge = sum((w(ixo^s, mag(:))+block%B0(ixo^s,:,b0i))**2, dim=ndim+1)
3665 else
3666 mge = sum(w(ixo^s, mag(:))**2, dim=ndim+1)
3667 end if
3668 end function rmhd_mag_en_all
3669
3670 subroutine rmhd_modify_wlr(ixI^L,ixO^L,qt,wLC,wRC,wLp,wRp,s,idir)
3672 use mod_usr_methods
3673 integer, intent(in) :: ixi^l, ixo^l, idir
3674 double precision, intent(in) :: qt
3675 double precision, intent(inout) :: wlc(ixi^s,1:nw), wrc(ixi^s,1:nw)
3676 double precision, intent(inout) :: wlp(ixi^s,1:nw), wrp(ixi^s,1:nw)
3677 type(state) :: s
3678 double precision :: db(ixo^s), dpsi(ixo^s)
3679 integer :: ix^d
3680
3681 if(stagger_grid) then
3682 {do ix^db=ixomin^db,ixomax^db\}
3683 wlc(ix^d,mag(idir))=s%ws(ix^d,idir)
3684 wrc(ix^d,mag(idir))=s%ws(ix^d,idir)
3685 wlp(ix^d,mag(idir))=s%ws(ix^d,idir)
3686 wrp(ix^d,mag(idir))=s%ws(ix^d,idir)
3687 {end do\}
3688 else
3689 ! Solve the Riemann problem for the linear 2x2 system for normal
3690 ! B-field and GLM_Psi according to Dedner 2002:
3691 ! This implements eq. (42) in Dedner et al. 2002 JcP 175
3692 ! Gives the Riemann solution on the interface
3693 ! for the normal B component and Psi in the GLM-MHD system.
3694 ! 23/04/2013 Oliver Porth
3695 {do ix^db=ixomin^db,ixomax^db\}
3696 db(ix^d)=wrp(ix^d,mag(idir))-wlp(ix^d,mag(idir))
3697 dpsi(ix^d)=wrp(ix^d,psi_)-wlp(ix^d,psi_)
3698 wlp(ix^d,mag(idir))=half*(wrp(ix^d,mag(idir))+wlp(ix^d,mag(idir))-dpsi(ix^d)/cmax_global)
3699 wlp(ix^d,psi_)=half*(wrp(ix^d,psi_)+wlp(ix^d,psi_)-db(ix^d)*cmax_global)
3700 wrp(ix^d,mag(idir))=wlp(ix^d,mag(idir))
3701 wrp(ix^d,psi_)=wlp(ix^d,psi_)
3702 if(total_energy) then
3703 wrc(ix^d,e_)=wrc(ix^d,e_)-half*wrc(ix^d,mag(idir))**2
3704 wlc(ix^d,e_)=wlc(ix^d,e_)-half*wlc(ix^d,mag(idir))**2
3705 end if
3706 wrc(ix^d,mag(idir))=wlp(ix^d,mag(idir))
3707 wrc(ix^d,psi_)=wlp(ix^d,psi_)
3708 wlc(ix^d,mag(idir))=wlp(ix^d,mag(idir))
3709 wlc(ix^d,psi_)=wlp(ix^d,psi_)
3710 ! modify total energy according to the change of magnetic field
3711 if(total_energy) then
3712 wrc(ix^d,e_)=wrc(ix^d,e_)+half*wrc(ix^d,mag(idir))**2
3713 wlc(ix^d,e_)=wlc(ix^d,e_)+half*wlc(ix^d,mag(idir))**2
3714 end if
3715 {end do\}
3716 end if
3717 if(associated(usr_set_wlr)) call usr_set_wlr(ixi^l,ixo^l,qt,wlc,wrc,wlp,wrp,s,idir)
3718 end subroutine rmhd_modify_wlr
3719
3720 subroutine rmhd_boundary_adjust(igrid,psb)
3722 integer, intent(in) :: igrid
3723 type(state), target :: psb(max_blocks)
3724 integer :: ib, idims, iside, ixo^l, i^d
3725
3726 block=>ps(igrid)
3727 ^d&dxlevel(^d)=rnode(rpdx^d_,igrid);
3728 do idims=1,ndim
3729 ! to avoid using as yet unknown corner info in more than 1D, we
3730 ! fill only interior mesh ranges of the ghost cell ranges at first,
3731 ! and progressively enlarge the ranges to include corners later
3732 do iside=1,2
3733 i^d=kr(^d,idims)*(2*iside-3);
3734 if (neighbor_type(i^d,igrid)/=1) cycle
3735 ib=(idims-1)*2+iside
3736 if(.not.boundary_divbfix(ib)) cycle
3737 if(any(typeboundary(:,ib)==bc_special)) then
3738 ! MF nonlinear force-free B field extrapolation and data driven
3739 ! require normal B of the first ghost cell layer to be untouched by
3740 ! fixdivB=0 process, set boundary_divbfix_skip(iB)=1 in par file
3741 select case (idims)
3742 {case (^d)
3743 if (iside==2) then
3744 ! maximal boundary
3745 ixomin^dd=ixghi^d+1-nghostcells+boundary_divbfix_skip(2*^d)^d%ixOmin^dd=ixglo^dd;
3746 ixomax^dd=ixghi^dd;
3747 else
3748 ! minimal boundary
3749 ixomin^dd=ixglo^dd;
3750 ixomax^dd=ixglo^d-1+nghostcells-boundary_divbfix_skip(2*^d-1)^d%ixOmax^dd=ixghi^dd;
3751 end if \}
3752 end select
3753 call fixdivb_boundary(ixg^ll,ixo^l,psb(igrid)%w,psb(igrid)%x,ib)
3754 end if
3755 end do
3756 end do
3757 end subroutine rmhd_boundary_adjust
3758
3759 subroutine fixdivb_boundary(ixG^L,ixO^L,w,x,iB)
3761 integer, intent(in) :: ixg^l,ixo^l,ib
3762 double precision, intent(inout) :: w(ixg^s,1:nw)
3763 double precision, intent(in) :: x(ixg^s,1:ndim)
3764 double precision :: dx1x2,dx1x3,dx2x1,dx2x3,dx3x1,dx3x2
3765 integer :: ix^d,ixf^l
3766
3767 select case(ib)
3768 case(1)
3769 ! 2nd order CD for divB=0 to set normal B component better
3770 if(total_energy) call rmhd_to_primitive(ixg^l,ixo^l,w,x)
3771 {^iftwod
3772 ixfmin1=ixomin1+1
3773 ixfmax1=ixomax1+1
3774 ixfmin2=ixomin2+1
3775 ixfmax2=ixomax2-1
3776 if(slab_uniform) then
3777 dx1x2=dxlevel(1)/dxlevel(2)
3778 do ix1=ixfmax1,ixfmin1,-1
3779 w(ix1-1,ixfmin2:ixfmax2,mag(1))=w(ix1+1,ixfmin2:ixfmax2,mag(1)) &
3780 +dx1x2*(w(ix1,ixfmin2+1:ixfmax2+1,mag(2))-&
3781 w(ix1,ixfmin2-1:ixfmax2-1,mag(2)))
3782 enddo
3783 else
3784 do ix1=ixfmax1,ixfmin1,-1
3785 w(ix1-1,ixfmin2:ixfmax2,mag(1))=( (w(ix1+1,ixfmin2:ixfmax2,mag(1))+&
3786 w(ix1,ixfmin2:ixfmax2,mag(1)))*block%surfaceC(ix1,ixfmin2:ixfmax2,1)&
3787 +(w(ix1,ixfmin2+1:ixfmax2+1,mag(2))+w(ix1,ixfmin2:ixfmax2,mag(2)))*&
3788 block%surfaceC(ix1,ixfmin2:ixfmax2,2)&
3789 -(w(ix1,ixfmin2:ixfmax2,mag(2))+w(ix1,ixfmin2-1:ixfmax2-1,mag(2)))*&
3790 block%surfaceC(ix1,ixfmin2-1:ixfmax2-1,2) )&
3791 /block%surfaceC(ix1-1,ixfmin2:ixfmax2,1)-w(ix1,ixfmin2:ixfmax2,mag(1))
3792 end do
3793 end if
3794 }
3795 {^ifthreed
3796 ixfmin1=ixomin1+1
3797 ixfmax1=ixomax1+1
3798 ixfmin2=ixomin2+1
3799 ixfmax2=ixomax2-1
3800 ixfmin3=ixomin3+1
3801 ixfmax3=ixomax3-1
3802 if(slab_uniform) then
3803 dx1x2=dxlevel(1)/dxlevel(2)
3804 dx1x3=dxlevel(1)/dxlevel(3)
3805 do ix1=ixfmax1,ixfmin1,-1
3806 w(ix1-1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))=&
3807 w(ix1+1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1)) &
3808 +dx1x2*(w(ix1,ixfmin2+1:ixfmax2+1,ixfmin3:ixfmax3,mag(2))-&
3809 w(ix1,ixfmin2-1:ixfmax2-1,ixfmin3:ixfmax3,mag(2))) &
3810 +dx1x3*(w(ix1,ixfmin2:ixfmax2,ixfmin3+1:ixfmax3+1,mag(3))-&
3811 w(ix1,ixfmin2:ixfmax2,ixfmin3-1:ixfmax3-1,mag(3)))
3812 end do
3813 else
3814 do ix1=ixfmax1,ixfmin1,-1
3815 w(ix1-1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))=&
3816 ( (w(ix1+1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))+&
3817 w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1)))*&
3818 block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,1)&
3819 +(w(ix1,ixfmin2+1:ixfmax2+1,ixfmin3:ixfmax3,mag(2))+&
3820 w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(2)))*&
3821 block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,2)&
3822 -(w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(2))+&
3823 w(ix1,ixfmin2-1:ixfmax2-1,ixfmin3:ixfmax3,mag(2)))*&
3824 block%surfaceC(ix1,ixfmin2-1:ixfmax2-1,ixfmin3:ixfmax3,2)&
3825 +(w(ix1,ixfmin2:ixfmax2,ixfmin3+1:ixfmax3+1,mag(3))+&
3826 w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(3)))*&
3827 block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,3)&
3828 -(w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(3))+&
3829 w(ix1,ixfmin2:ixfmax2,ixfmin3-1:ixfmax3-1,mag(3)))*&
3830 block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3-1:ixfmax3-1,3) )&
3831 /block%surfaceC(ix1-1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,1)-&
3832 w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))
3833 end do
3834 end if
3835 }
3836 if(total_energy) call rmhd_to_conserved(ixg^l,ixo^l,w,x)
3837 case(2)
3838 if(total_energy) call rmhd_to_primitive(ixg^l,ixo^l,w,x)
3839 {^iftwod
3840 ixfmin1=ixomin1-1
3841 ixfmax1=ixomax1-1
3842 ixfmin2=ixomin2+1
3843 ixfmax2=ixomax2-1
3844 if(slab_uniform) then
3845 dx1x2=dxlevel(1)/dxlevel(2)
3846 do ix1=ixfmin1,ixfmax1
3847 w(ix1+1,ixfmin2:ixfmax2,mag(1))=w(ix1-1,ixfmin2:ixfmax2,mag(1)) &
3848 -dx1x2*(w(ix1,ixfmin2+1:ixfmax2+1,mag(2))-&
3849 w(ix1,ixfmin2-1:ixfmax2-1,mag(2)))
3850 enddo
3851 else
3852 do ix1=ixfmin1,ixfmax1
3853 w(ix1+1,ixfmin2:ixfmax2,mag(1))=( (w(ix1-1,ixfmin2:ixfmax2,mag(1))+&
3854 w(ix1,ixfmin2:ixfmax2,mag(1)))*block%surfaceC(ix1-1,ixfmin2:ixfmax2,1)&
3855 -(w(ix1,ixfmin2+1:ixfmax2+1,mag(2))+w(ix1,ixfmin2:ixfmax2,mag(2)))*&
3856 block%surfaceC(ix1,ixfmin2:ixfmax2,2)&
3857 +(w(ix1,ixfmin2:ixfmax2,mag(2))+w(ix1,ixfmin2-1:ixfmax2-1,mag(2)))*&
3858 block%surfaceC(ix1,ixfmin2-1:ixfmax2-1,2) )&
3859 /block%surfaceC(ix1,ixfmin2:ixfmax2,1)-w(ix1,ixfmin2:ixfmax2,mag(1))
3860 end do
3861 end if
3862 }
3863 {^ifthreed
3864 ixfmin1=ixomin1-1
3865 ixfmax1=ixomax1-1
3866 ixfmin2=ixomin2+1
3867 ixfmax2=ixomax2-1
3868 ixfmin3=ixomin3+1
3869 ixfmax3=ixomax3-1
3870 if(slab_uniform) then
3871 dx1x2=dxlevel(1)/dxlevel(2)
3872 dx1x3=dxlevel(1)/dxlevel(3)
3873 do ix1=ixfmin1,ixfmax1
3874 w(ix1+1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))=&
3875 w(ix1-1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1)) &
3876 -dx1x2*(w(ix1,ixfmin2+1:ixfmax2+1,ixfmin3:ixfmax3,mag(2))-&
3877 w(ix1,ixfmin2-1:ixfmax2-1,ixfmin3:ixfmax3,mag(2))) &
3878 -dx1x3*(w(ix1,ixfmin2:ixfmax2,ixfmin3+1:ixfmax3+1,mag(3))-&
3879 w(ix1,ixfmin2:ixfmax2,ixfmin3-1:ixfmax3-1,mag(3)))
3880 end do
3881 else
3882 do ix1=ixfmin1,ixfmax1
3883 w(ix1+1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))=&
3884 ( (w(ix1-1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))+&
3885 w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1)))*&
3886 block%surfaceC(ix1-1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,1)&
3887 -(w(ix1,ixfmin2+1:ixfmax2+1,ixfmin3:ixfmax3,mag(2))+&
3888 w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(2)))*&
3889 block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,2)&
3890 +(w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(2))+&
3891 w(ix1,ixfmin2-1:ixfmax2-1,ixfmin3:ixfmax3,mag(2)))*&
3892 block%surfaceC(ix1,ixfmin2-1:ixfmax2-1,ixfmin3:ixfmax3,2)&
3893 -(w(ix1,ixfmin2:ixfmax2,ixfmin3+1:ixfmax3+1,mag(3))+&
3894 w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(3)))*&
3895 block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,3)&
3896 +(w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(3))+&
3897 w(ix1,ixfmin2:ixfmax2,ixfmin3-1:ixfmax3-1,mag(3)))*&
3898 block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3-1:ixfmax3-1,3) )&
3899 /block%surfaceC(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,1)-&
3900 w(ix1,ixfmin2:ixfmax2,ixfmin3:ixfmax3,mag(1))
3901 end do
3902 end if
3903 }
3904 if(total_energy) call rmhd_to_conserved(ixg^l,ixo^l,w,x)
3905 case(3)
3906 if(total_energy) call rmhd_to_primitive(ixg^l,ixo^l,w,x)
3907 {^iftwod
3908 ixfmin1=ixomin1+1
3909 ixfmax1=ixomax1-1
3910 ixfmin2=ixomin2+1
3911 ixfmax2=ixomax2+1
3912 if(slab_uniform) then
3913 dx2x1=dxlevel(2)/dxlevel(1)
3914 do ix2=ixfmax2,ixfmin2,-1
3915 w(ixfmin1:ixfmax1,ix2-1,mag(2))=w(ixfmin1:ixfmax1,ix2+1,mag(2)) &
3916 +dx2x1*(w(ixfmin1+1:ixfmax1+1,ix2,mag(1))-&
3917 w(ixfmin1-1:ixfmax1-1,ix2,mag(1)))
3918 enddo
3919 else
3920 do ix2=ixfmax2,ixfmin2,-1
3921 w(ixfmin1:ixfmax1,ix2-1,mag(2))=( (w(ixfmin1:ixfmax1,ix2+1,mag(2))+&
3922 w(ixfmin1:ixfmax1,ix2,mag(2)))*block%surfaceC(ixfmin1:ixfmax1,ix2,2)&
3923 +(w(ixfmin1+1:ixfmax1+1,ix2,mag(1))+w(ixfmin1:ixfmax1,ix2,mag(1)))*&
3924 block%surfaceC(ixfmin1:ixfmax1,ix2,1)&
3925 -(w(ixfmin1:ixfmax1,ix2,mag(1))+w(ixfmin1-1:ixfmax1-1,ix2,mag(1)))*&
3926 block%surfaceC(ixfmin1-1:ixfmax1-1,ix2,1) )&
3927 /block%surfaceC(ixfmin1:ixfmax1,ix2-1,2)-w(ixfmin1:ixfmax1,ix2,mag(2))
3928 end do
3929 end if
3930 }
3931 {^ifthreed
3932 ixfmin1=ixomin1+1
3933 ixfmax1=ixomax1-1
3934 ixfmin3=ixomin3+1
3935 ixfmax3=ixomax3-1
3936 ixfmin2=ixomin2+1
3937 ixfmax2=ixomax2+1
3938 if(slab_uniform) then
3939 dx2x1=dxlevel(2)/dxlevel(1)
3940 dx2x3=dxlevel(2)/dxlevel(3)
3941 do ix2=ixfmax2,ixfmin2,-1
3942 w(ixfmin1:ixfmax1,ix2-1,ixfmin3:ixfmax3,mag(2))=w(ixfmin1:ixfmax1,&
3943 ix2+1,ixfmin3:ixfmax3,mag(2)) &
3944 +dx2x1*(w(ixfmin1+1:ixfmax1+1,ix2,ixfmin3:ixfmax3,mag(1))-&
3945 w(ixfmin1-1:ixfmax1-1,ix2,ixfmin3:ixfmax3,mag(1))) &
3946 +dx2x3*(w(ixfmin1:ixfmax1,ix2,ixfmin3+1:ixfmax3+1,mag(3))-&
3947 w(ixfmin1:ixfmax1,ix2,ixfmin3-1:ixfmax3-1,mag(3)))
3948 end do
3949 else
3950 do ix2=ixfmax2,ixfmin2,-1
3951 w(ixfmin1:ixfmax1,ix2-1,ixfmin3:ixfmax3,mag(2))=&
3952 ( (w(ixfmin1:ixfmax1,ix2+1,ixfmin3:ixfmax3,mag(2))+&
3953 w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(2)))*&
3954 block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,2)&
3955 +(w(ixfmin1+1:ixfmax1+1,ix2,ixfmin3:ixfmax3,mag(1))+&
3956 w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(1)))*&
3957 block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,1)&
3958 -(w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(1))+&
3959 w(ixfmin1-1:ixfmax1-1,ix2,ixfmin3:ixfmax3,mag(1)))*&
3960 block%surfaceC(ixfmin1-1:ixfmax1-1,ix2,ixfmin3:ixfmax3,1)&
3961 +(w(ixfmin1:ixfmax1,ix2,ixfmin3+1:ixfmax3+1,mag(3))+&
3962 w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(3)))*&
3963 block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,3)&
3964 -(w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(3))+&
3965 w(ixfmin1:ixfmax1,ix2,ixfmin3-1:ixfmax3-1,mag(3)))*&
3966 block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3-1:ixfmax3-1,3) )&
3967 /block%surfaceC(ixfmin1:ixfmax1,ix2-1,ixfmin3:ixfmax3,2)-&
3968 w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(2))
3969 end do
3970 end if
3971 }
3972 if(total_energy) call rmhd_to_conserved(ixg^l,ixo^l,w,x)
3973 case(4)
3974 if(total_energy) call rmhd_to_primitive(ixg^l,ixo^l,w,x)
3975 {^iftwod
3976 ixfmin1=ixomin1+1
3977 ixfmax1=ixomax1-1
3978 ixfmin2=ixomin2-1
3979 ixfmax2=ixomax2-1
3980 if(slab_uniform) then
3981 dx2x1=dxlevel(2)/dxlevel(1)
3982 do ix2=ixfmin2,ixfmax2
3983 w(ixfmin1:ixfmax1,ix2+1,mag(2))=w(ixfmin1:ixfmax1,ix2-1,mag(2)) &
3984 -dx2x1*(w(ixfmin1+1:ixfmax1+1,ix2,mag(1))-&
3985 w(ixfmin1-1:ixfmax1-1,ix2,mag(1)))
3986 end do
3987 else
3988 do ix2=ixfmin2,ixfmax2
3989 w(ixfmin1:ixfmax1,ix2+1,mag(2))=( (w(ixfmin1:ixfmax1,ix2-1,mag(2))+&
3990 w(ixfmin1:ixfmax1,ix2,mag(2)))*block%surfaceC(ixfmin1:ixfmax1,ix2-1,2)&
3991 -(w(ixfmin1+1:ixfmax1+1,ix2,mag(1))+w(ixfmin1:ixfmax1,ix2,mag(1)))*&
3992 block%surfaceC(ixfmin1:ixfmax1,ix2,1)&
3993 +(w(ixfmin1:ixfmax1,ix2,mag(1))+w(ixfmin1-1:ixfmax1-1,ix2,mag(1)))*&
3994 block%surfaceC(ixfmin1-1:ixfmax1-1,ix2,1) )&
3995 /block%surfaceC(ixfmin1:ixfmax1,ix2,2)-w(ixfmin1:ixfmax1,ix2,mag(2))
3996 end do
3997 end if
3998 }
3999 {^ifthreed
4000 ixfmin1=ixomin1+1
4001 ixfmax1=ixomax1-1
4002 ixfmin3=ixomin3+1
4003 ixfmax3=ixomax3-1
4004 ixfmin2=ixomin2-1
4005 ixfmax2=ixomax2-1
4006 if(slab_uniform) then
4007 dx2x1=dxlevel(2)/dxlevel(1)
4008 dx2x3=dxlevel(2)/dxlevel(3)
4009 do ix2=ixfmin2,ixfmax2
4010 w(ixfmin1:ixfmax1,ix2+1,ixfmin3:ixfmax3,mag(2))=w(ixfmin1:ixfmax1,&
4011 ix2-1,ixfmin3:ixfmax3,mag(2)) &
4012 -dx2x1*(w(ixfmin1+1:ixfmax1+1,ix2,ixfmin3:ixfmax3,mag(1))-&
4013 w(ixfmin1-1:ixfmax1-1,ix2,ixfmin3:ixfmax3,mag(1))) &
4014 -dx2x3*(w(ixfmin1:ixfmax1,ix2,ixfmin3+1:ixfmax3+1,mag(3))-&
4015 w(ixfmin1:ixfmax1,ix2,ixfmin3-1:ixfmax3-1,mag(3)))
4016 end do
4017 else
4018 do ix2=ixfmin2,ixfmax2
4019 w(ixfmin1:ixfmax1,ix2+1,ixfmin3:ixfmax3,mag(2))=&
4020 ( (w(ixfmin1:ixfmax1,ix2-1,ixfmin3:ixfmax3,mag(2))+&
4021 w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(2)))*&
4022 block%surfaceC(ixfmin1:ixfmax1,ix2-1,ixfmin3:ixfmax3,2)&
4023 -(w(ixfmin1+1:ixfmax1+1,ix2,ixfmin3:ixfmax3,mag(1))+&
4024 w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(1)))*&
4025 block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,1)&
4026 +(w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(1))+&
4027 w(ixfmin1-1:ixfmax1-1,ix2,ixfmin3:ixfmax3,mag(1)))*&
4028 block%surfaceC(ixfmin1-1:ixfmax1-1,ix2,ixfmin3:ixfmax3,1)&
4029 -(w(ixfmin1:ixfmax1,ix2,ixfmin3+1:ixfmax3+1,mag(3))+&
4030 w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(3)))*&
4031 block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,3)&
4032 +(w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(3))+&
4033 w(ixfmin1:ixfmax1,ix2,ixfmin3-1:ixfmax3-1,mag(3)))*&
4034 block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3-1:ixfmax3-1,3) )&
4035 /block%surfaceC(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,2)-&
4036 w(ixfmin1:ixfmax1,ix2,ixfmin3:ixfmax3,mag(2))
4037 end do
4038 end if
4039 }
4040 if(total_energy) call rmhd_to_conserved(ixg^l,ixo^l,w,x)
4041 {^ifthreed
4042 case(5)
4043 if(total_energy) call rmhd_to_primitive(ixg^l,ixo^l,w,x)
4044 ixfmin1=ixomin1+1
4045 ixfmax1=ixomax1-1
4046 ixfmin2=ixomin2+1
4047 ixfmax2=ixomax2-1
4048 ixfmin3=ixomin3+1
4049 ixfmax3=ixomax3+1
4050 if(slab_uniform) then
4051 dx3x1=dxlevel(3)/dxlevel(1)
4052 dx3x2=dxlevel(3)/dxlevel(2)
4053 do ix3=ixfmax3,ixfmin3,-1
4054 w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3-1,mag(3))=w(ixfmin1:ixfmax1,&
4055 ixfmin2:ixfmax2,ix3+1,mag(3)) &
4056 +dx3x1*(w(ixfmin1+1:ixfmax1+1,ixfmin2:ixfmax2,ix3,mag(1))-&
4057 w(ixfmin1-1:ixfmax1-1,ixfmin2:ixfmax2,ix3,mag(1))) &
4058 +dx3x2*(w(ixfmin1:ixfmax1,ixfmin2+1:ixfmax2+1,ix3,mag(2))-&
4059 w(ixfmin1:ixfmax1,ixfmin2-1:ixfmax2-1,ix3,mag(2)))
4060 end do
4061 else
4062 do ix3=ixfmax3,ixfmin3,-1
4063 w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3-1,mag(3))=&
4064 ( (w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3+1,mag(3))+&
4065 w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(3)))*&
4066 block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,3)&
4067 +(w(ixfmin1+1:ixfmax1+1,ixfmin2:ixfmax2,ix3,mag(1))+&
4068 w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(1)))*&
4069 block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,1)&
4070 -(w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(1))+&
4071 w(ixfmin1-1:ixfmax1-1,ixfmin2:ixfmax2,ix3,mag(1)))*&
4072 block%surfaceC(ixfmin1-1:ixfmax1-1,ixfmin2:ixfmax2,ix3,1)&
4073 +(w(ixfmin1:ixfmax1,ixfmin2+1:ixfmax2+1,ix3,mag(2))+&
4074 w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(2)))*&
4075 block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,2)&
4076 -(w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(2))+&
4077 w(ixfmin1:ixfmax1,ixfmin2-1:ixfmax2-1,ix3,mag(2)))*&
4078 block%surfaceC(ixfmin1:ixfmax1,ixfmin2-1:ixfmax2-1,ix3,2) )&
4079 /block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3-1,3)-&
4080 w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(3))
4081 end do
4082 end if
4083 if(total_energy) call rmhd_to_conserved(ixg^l,ixo^l,w,x)
4084 case(6)
4085 if(total_energy) call rmhd_to_primitive(ixg^l,ixo^l,w,x)
4086 ixfmin1=ixomin1+1
4087 ixfmax1=ixomax1-1
4088 ixfmin2=ixomin2+1
4089 ixfmax2=ixomax2-1
4090 ixfmin3=ixomin3-1
4091 ixfmax3=ixomax3-1
4092 if(slab_uniform) then
4093 dx3x1=dxlevel(3)/dxlevel(1)
4094 dx3x2=dxlevel(3)/dxlevel(2)
4095 do ix3=ixfmin3,ixfmax3
4096 w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3+1,mag(3))=w(ixfmin1:ixfmax1,&
4097 ixfmin2:ixfmax2,ix3-1,mag(3)) &
4098 -dx3x1*(w(ixfmin1+1:ixfmax1+1,ixfmin2:ixfmax2,ix3,mag(1))-&
4099 w(ixfmin1-1:ixfmax1-1,ixfmin2:ixfmax2,ix3,mag(1))) &
4100 -dx3x2*(w(ixfmin1:ixfmax1,ixfmin2+1:ixfmax2+1,ix3,mag(2))-&
4101 w(ixfmin1:ixfmax1,ixfmin2-1:ixfmax2-1,ix3,mag(2)))
4102 end do
4103 else
4104 do ix3=ixfmin3,ixfmax3
4105 w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3+1,mag(3))=&
4106 ( (w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3-1,mag(3))+&
4107 w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(3)))*&
4108 block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3-1,3)&
4109 -(w(ixfmin1+1:ixfmax1+1,ixfmin2:ixfmax2,ix3,mag(1))+&
4110 w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(1)))*&
4111 block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,1)&
4112 +(w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(1))+&
4113 w(ixfmin1-1:ixfmax1-1,ixfmin2:ixfmax2,ix3,mag(1)))*&
4114 block%surfaceC(ixfmin1-1:ixfmax1-1,ixfmin2:ixfmax2,ix3,1)&
4115 -(w(ixfmin1:ixfmax1,ixfmin2+1:ixfmax2+1,ix3,mag(2))+&
4116 w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(2)))*&
4117 block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,2)&
4118 +(w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(2))+&
4119 w(ixfmin1:ixfmax1,ixfmin2-1:ixfmax2-1,ix3,mag(2)))*&
4120 block%surfaceC(ixfmin1:ixfmax1,ixfmin2-1:ixfmax2-1,ix3,2) )&
4121 /block%surfaceC(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,3)-&
4122 w(ixfmin1:ixfmax1,ixfmin2:ixfmax2,ix3,mag(3))
4123 end do
4124 end if
4125 if(total_energy) call rmhd_to_conserved(ixg^l,ixo^l,w,x)
4126 }
4127 case default
4128 call mpistop("Special boundary is not defined for this region")
4129 end select
4130 end subroutine fixdivb_boundary
4131
4132 {^nooned
4133 subroutine rmhd_clean_divb_multigrid(qdt, qt, active)
4134 use mod_forest
4137 use mod_geometry
4138 double precision, intent(in) :: qdt !< Current time step
4139 double precision, intent(in) :: qt !< Current time
4140 logical, intent(inout) :: active !< Output if the source is active
4141 integer :: id
4142 integer, parameter :: max_its = 50
4143 double precision :: residual_it(max_its), max_divb
4144 double precision :: tmp(ixg^t), grad(ixg^t, ndim)
4145 double precision :: res
4146 double precision, parameter :: max_residual = 1d-3
4147 double precision, parameter :: residual_reduction = 1d-10
4148 integer :: iigrid, igrid
4149 integer :: n, nc, lvl, ix^l, ixc^l, idim
4150 type(tree_node), pointer :: pnode
4151
4152 mg%operator_type = mg_laplacian
4153 ! Set boundary conditions
4154 do n = 1, 2*ndim
4155 idim = (n+1)/2
4156 select case (typeboundary(mag(idim), n))
4157 case (bc_symm)
4158 ! d/dx B = 0, take phi = 0
4159 mg%bc(n, mg_iphi)%bc_type = mg_bc_dirichlet
4160 mg%bc(n, mg_iphi)%bc_value = 0.0_dp
4161 case (bc_asymm)
4162 ! B = 0, so grad(phi) = 0
4163 mg%bc(n, mg_iphi)%bc_type = mg_bc_neumann
4164 mg%bc(n, mg_iphi)%bc_value = 0.0_dp
4165 case (bc_cont)
4166 mg%bc(n, mg_iphi)%bc_type = mg_bc_dirichlet
4167 mg%bc(n, mg_iphi)%bc_value = 0.0_dp
4168 case (bc_special)
4169 ! Assume Dirichlet boundary conditions, derivative zero
4170 mg%bc(n, mg_iphi)%bc_type = mg_bc_dirichlet
4171 mg%bc(n, mg_iphi)%bc_value = 0.0_dp
4172 case (bc_periodic)
4173 ! Nothing to do here
4174 case default
4175 write(*,*) "rmhd_clean_divb_multigrid warning: unknown boundary type"
4176 mg%bc(n, mg_iphi)%bc_type = mg_bc_dirichlet
4177 mg%bc(n, mg_iphi)%bc_value = 0.0_dp
4178 end select
4179 end do
4180
4181 ix^l=ixm^ll^ladd1;
4182 max_divb = 0.0d0
4183 ! Store divergence of B as right-hand side
4184 do iigrid = 1, igridstail
4185 igrid = igrids(iigrid);
4186 pnode => igrid_to_node(igrid, mype)%node
4187 id = pnode%id
4188 lvl = mg%boxes(id)%lvl
4189 nc = mg%box_size_lvl(lvl)
4190
4191 ! Geometry subroutines expect this to be set
4192 block => ps(igrid)
4193 ^d&dxlevel(^d)=rnode(rpdx^d_,igrid);
4194
4195 call get_divb(ps(igrid)%w(ixg^t, 1:nw), ixg^ll, ixm^ll, tmp, &
4197 mg%boxes(id)%cc({1:nc}, mg_irhs) = tmp(ixm^t)
4198 max_divb = max(max_divb, maxval(abs(tmp(ixm^t))))
4199 end do
4200
4201 ! Solve laplacian(phi) = divB
4202 if(stagger_grid) then
4203 call mpi_allreduce(mpi_in_place, max_divb, 1, mpi_double_precision, &
4204 mpi_max, icomm, ierrmpi)
4205
4206 if (mype == 0) print *, "Performing multigrid divB cleaning"
4207 if (mype == 0) print *, "iteration vs residual"
4208 ! Solve laplacian(phi) = divB
4209 do n = 1, max_its
4210 call mg_fas_fmg(mg, n>1, max_res=residual_it(n))
4211 if (mype == 0) write(*, "(I4,E11.3)") n, residual_it(n)
4212 if (residual_it(n) < residual_reduction * max_divb) exit
4213 end do
4214 if (mype == 0 .and. n > max_its) then
4215 print *, "divb_multigrid warning: not fully converged"
4216 print *, "current amplitude of divb: ", residual_it(max_its)
4217 print *, "multigrid smallest grid: ", &
4218 mg%domain_size_lvl(:, mg%lowest_lvl)
4219 print *, "note: smallest grid ideally has <= 8 cells"
4220 print *, "multigrid dx/dy/dz ratio: ", mg%dr(:, 1)/mg%dr(1, 1)
4221 print *, "note: dx/dy/dz should be similar"
4222 end if
4223 else
4224 do n = 1, max_its
4225 call mg_fas_vcycle(mg, max_res=res)
4226 if (res < max_residual) exit
4227 end do
4228 if (res > max_residual) call mpistop("divb_multigrid: no convergence")
4229 end if
4230
4231 ! Correct the magnetic field
4232 do iigrid = 1, igridstail
4233 igrid = igrids(iigrid);
4234 pnode => igrid_to_node(igrid, mype)%node
4235 id = pnode%id
4236 ! Geometry subroutines expect this to be set
4237 block => ps(igrid)
4238 ^d&dxlevel(^d)=rnode(rpdx^d_,igrid);
4239 ! Compute the gradient of phi
4240 tmp(ix^s) = mg%boxes(id)%cc({:,}, mg_iphi)
4241 if(stagger_grid) then
4242 do idim =1, ndim
4243 ixcmin^d=ixmlo^d-kr(idim,^d);
4244 ixcmax^d=ixmhi^d;
4245 call gradientf(tmp,ps(igrid)%x,ixg^ll,ixc^l,idim,grad(ixg^t,idim))
4246 ! Apply the correction B* = B - gradient(phi)
4247 ps(igrid)%ws(ixc^s,idim)=ps(igrid)%ws(ixc^s,idim)-grad(ixc^s,idim)
4248 end do
4249 ! store cell-center magnetic energy
4250 tmp(ixm^t) = sum(ps(igrid)%w(ixm^t, mag(1:ndim))**2, dim=ndim+1)
4251 ! change cell-center magnetic field
4252 call rmhd_face_to_center(ixm^ll,ps(igrid))
4253 else
4254 do idim = 1, ndim
4255 call gradient(tmp,ixg^ll,ixm^ll,idim,grad(ixg^t, idim))
4256 end do
4257 ! store cell-center magnetic energy
4258 tmp(ixm^t) = sum(ps(igrid)%w(ixm^t, mag(1:ndim))**2, dim=ndim+1)
4259 ! Apply the correction B* = B - gradient(phi)
4260 ps(igrid)%w(ixm^t, mag(1:ndim)) = &
4261 ps(igrid)%w(ixm^t, mag(1:ndim)) - grad(ixm^t, :)
4262 end if
4263 if(total_energy) then
4264 ! Determine magnetic energy difference
4265 tmp(ixm^t) = 0.5_dp * (sum(ps(igrid)%w(ixm^t, &
4266 mag(1:ndim))**2, dim=ndim+1) - tmp(ixm^t))
4267 ! Keep thermal pressure the same
4268 ps(igrid)%w(ixm^t, e_) = ps(igrid)%w(ixm^t, e_) + tmp(ixm^t)
4269 end if
4270 end do
4271 active = .true.
4272 end subroutine rmhd_clean_divb_multigrid
4273 }
4274
4275 subroutine rmhd_update_faces(ixI^L,ixO^L,qt,qdt,wprim,fC,fE,sCT,s,vcts)
4277 integer, intent(in) :: ixi^l, ixo^l
4278 double precision, intent(in) :: qt,qdt
4279 ! cell-center primitive variables
4280 double precision, intent(in) :: wprim(ixi^s,1:nw)
4281 type(state) :: sct, s
4282 type(ct_velocity) :: vcts
4283 double precision, intent(in) :: fc(ixi^s,1:nwflux,1:ndim)
4284 double precision, intent(inout) :: fe(ixi^s,sdim:3)
4285
4286 select case(type_ct)
4287 case('average')
4288 call update_faces_average(ixi^l,ixo^l,qt,qdt,fc,fe,sct,s)
4289 case('uct_contact')
4290 call update_faces_contact(ixi^l,ixo^l,qt,qdt,wprim,fc,fe,sct,s,vcts)
4291 case('uct_hll')
4292 call update_faces_hll(ixi^l,ixo^l,qt,qdt,fe,sct,s,vcts)
4293 case default
4294 call mpistop('choose average, uct_contact,or uct_hll for type_ct!')
4295 end select
4296 end subroutine rmhd_update_faces
4297
4298 !> get electric field though averaging neighors to update faces in CT
4299 subroutine update_faces_average(ixI^L,ixO^L,qt,qdt,fC,fE,sCT,s)
4301 use mod_usr_methods
4302 integer, intent(in) :: ixi^l, ixo^l
4303 double precision, intent(in) :: qt, qdt
4304 type(state) :: sct, s
4305 double precision, intent(in) :: fc(ixi^s,1:nwflux,1:ndim)
4306 double precision, intent(inout) :: fe(ixi^s,sdim:3)
4307 double precision :: circ(ixi^s,1:ndim)
4308 ! non-ideal electric field on cell edges
4309 double precision, dimension(ixI^S,sdim:3) :: e_resi
4310 integer :: ix^d,ixc^l,ixa^l,i1kr^d,i2kr^d
4311 integer :: idim1,idim2,idir,iwdim1,iwdim2
4312
4313 associate(bfaces=>s%ws,x=>s%x)
4314 ! Calculate contribution to FEM of each edge,
4315 ! that is, estimate value of line integral of
4316 ! electric field in the positive idir direction.
4317 ! if there is resistivity, get eta J
4318 if(rmhd_eta/=zero) call get_resistive_electric_field(ixi^l,ixo^l,sct,s,e_resi)
4319 do idim1=1,ndim
4320 iwdim1 = mag(idim1)
4321 i1kr^d=kr(idim1,^d);
4322 do idim2=1,ndim
4323 iwdim2 = mag(idim2)
4324 i2kr^d=kr(idim2,^d);
4325 do idir=sdim,3! Direction of line integral
4326 ! Allow only even permutations
4327 if (lvc(idim1,idim2,idir)==1) then
4328 ixcmax^d=ixomax^d;
4329 ixcmin^d=ixomin^d+kr(idir,^d)-1;
4330 ! average cell-face electric field to cell edges
4331 {do ix^db=ixcmin^db,ixcmax^db\}
4332 fe(ix^d,idir)=quarter*&
4333 (fc(ix^d,iwdim1,idim2)+fc({ix^d+i1kr^d},iwdim1,idim2)&
4334 -fc(ix^d,iwdim2,idim1)-fc({ix^d+i2kr^d},iwdim2,idim1))
4335 ! add resistive electric field at cell edges E=-vxB+eta J
4336 if(rmhd_eta/=zero) fe(ix^d,idir)=fe(ix^d,idir)+e_resi(ix^d,idir)
4337 ! times time step and edge length
4338 fe(ix^d,idir)=fe(ix^d,idir)*qdt*s%dsC(ix^d,idir)
4339 {end do\}
4340 end if
4341 end do
4342 end do
4343 end do
4344 ! allow user to change inductive electric field, especially for boundary driven applications
4345 if(associated(usr_set_electric_field)) &
4346 call usr_set_electric_field(ixi^l,ixo^l,qt,qdt,fe,sct)
4347 circ(ixi^s,1:ndim)=zero
4348 ! Calculate circulation on each face
4349 do idim1=1,ndim ! Coordinate perpendicular to face
4350 ixcmax^d=ixomax^d;
4351 ixcmin^d=ixomin^d-kr(idim1,^d);
4352 do idim2=1,ndim
4353 ixa^l=ixc^l-kr(idim2,^d);
4354 do idir=sdim,3 ! Direction of line integral
4355 ! Assemble indices
4356 if(lvc(idim1,idim2,idir)==1) then
4357 ! Add line integrals in direction idir
4358 circ(ixc^s,idim1)=circ(ixc^s,idim1)&
4359 +(fe(ixc^s,idir)&
4360 -fe(ixa^s,idir))
4361 else if(lvc(idim1,idim2,idir)==-1) then
4362 ! Add line integrals in direction idir
4363 circ(ixc^s,idim1)=circ(ixc^s,idim1)&
4364 -(fe(ixc^s,idir)&
4365 -fe(ixa^s,idir))
4366 end if
4367 end do
4368 end do
4369 ! Divide by the area of the face to get dB/dt
4370 where(s%surfaceC(ixc^s,idim1) > 1.0d-9*s%dvolume(ixc^s))
4371 circ(ixc^s,idim1)=circ(ixc^s,idim1)/s%surfaceC(ixc^s,idim1)
4372 elsewhere
4373 circ(ixc^s,idim1)=zero
4374 end where
4375 ! Time update cell-face magnetic field component
4376 bfaces(ixc^s,idim1)=bfaces(ixc^s,idim1)-circ(ixc^s,idim1)
4377 end do
4378 end associate
4379 end subroutine update_faces_average
4380
4381 !> update faces using UCT contact mode by Gardiner and Stone 2005 JCP 205, 509
4382 subroutine update_faces_contact(ixI^L,ixO^L,qt,qdt,wp,fC,fE,sCT,s,vcts)
4384 use mod_usr_methods
4385 use mod_geometry
4386 integer, intent(in) :: ixi^l, ixo^l
4387 double precision, intent(in) :: qt, qdt
4388 ! cell-center primitive variables
4389 double precision, intent(in) :: wp(ixi^s,1:nw)
4390 type(state) :: sct, s
4391 type(ct_velocity) :: vcts
4392 double precision, intent(in) :: fc(ixi^s,1:nwflux,1:ndim)
4393 double precision, intent(inout) :: fe(ixi^s,sdim:3)
4394 double precision :: circ(ixi^s,1:ndim)
4395 ! electric field at cell centers
4396 double precision :: ecc(ixi^s,sdim:3)
4397 double precision :: ein(ixi^s,sdim:3)
4398 ! gradient of E at left and right side of a cell face
4399 double precision :: el(ixi^s),er(ixi^s)
4400 ! gradient of E at left and right side of a cell corner
4401 double precision :: elc,erc
4402 ! non-ideal electric field on cell edges
4403 double precision, dimension(ixI^S,sdim:3) :: e_resi
4404 ! current on cell edges
4405 double precision :: jce(ixi^s,sdim:3)
4406 ! location at cell faces
4407 double precision :: xs(ixgs^t,1:ndim)
4408 double precision :: gradi(ixgs^t)
4409 integer :: ixc^l,ixa^l
4410 integer :: idim1,idim2,idir,iwdim1,iwdim2,ix^d,i1kr^d,i2kr^d
4411
4412 associate(bfaces=>s%ws,x=>s%x,w=>s%w,vnorm=>vcts%vnorm,wcts=>sct%ws)
4413 ! if there is resistivity, get eta J
4414 if(rmhd_eta/=zero) call get_resistive_electric_field(ixi^l,ixo^l,sct,s,e_resi)
4415 if(b0field) then
4416 {do ix^db=iximin^db,iximax^db\}
4417 ! Calculate electric field at cell centers
4418 {^ifthreed
4419 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_)
4420 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_)
4421 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_)
4422 }
4423 {^iftwod
4424 ecc(ix^d,3)=wp(ix^d,b1_)*wp(ix^d,m2_)-wp(ix^d,b2_)*wp(ix^d,m1_)
4425 }
4426 {^ifoned
4427 ecc(ix^d,3)=0.d0
4428 }
4429 {end do\}
4430 else
4431 {do ix^db=iximin^db,iximax^db\}
4432 ! Calculate electric field at cell centers
4433 {^ifthreed
4434 ecc(ix^d,1)=wp(ix^d,b2_)*wp(ix^d,m3_)-wp(ix^d,b3_)*wp(ix^d,m2_)
4435 ecc(ix^d,2)=wp(ix^d,b3_)*wp(ix^d,m1_)-wp(ix^d,b1_)*wp(ix^d,m3_)
4436 ecc(ix^d,3)=wp(ix^d,b1_)*wp(ix^d,m2_)-wp(ix^d,b2_)*wp(ix^d,m1_)
4437 }
4438 {^iftwod
4439 ecc(ix^d,3)=wp(ix^d,b1_)*wp(ix^d,m2_)-wp(ix^d,b2_)*wp(ix^d,m1_)
4440 }
4441 {^ifoned
4442 ecc(ix^d,3)=0.d0
4443 }
4444 {end do\}
4445 end if
4446
4447 ! Calculate contribution to FEM of each edge,
4448 ! that is, estimate value of line integral of
4449 ! electric field in the positive idir direction.
4450 ! evaluate electric field along cell edges according to equation (41)
4451 do idim1=1,ndim
4452 iwdim1 = mag(idim1)
4453 i1kr^d=kr(idim1,^d);
4454 do idim2=1,ndim
4455 iwdim2 = mag(idim2)
4456 i2kr^d=kr(idim2,^d);
4457 do idir=sdim,3 ! Direction of line integral
4458 ! Allow only even permutations
4459 if (lvc(idim1,idim2,idir)==1) then
4460 ixcmax^d=ixomax^d;
4461 ixcmin^d=ixomin^d+kr(idir,^d)-1;
4462 ! Assemble indices
4463 ! average cell-face electric field to cell edges
4464 {do ix^db=ixcmin^db,ixcmax^db\}
4465 fe(ix^d,idir)=quarter*&
4466 (fc(ix^d,iwdim1,idim2)+fc({ix^d+i1kr^d},iwdim1,idim2)&
4467 -fc(ix^d,iwdim2,idim1)-fc({ix^d+i2kr^d},iwdim2,idim1))
4468 if(partial_energy) ein(ix^d,idir)=fe(ix^d,idir)
4469 {end do\}
4470 ! add slope in idim2 direction from equation (50)
4471 ixamin^d=ixcmin^d;
4472 ixamax^d=ixcmax^d+i1kr^d;
4473 {do ix^db=ixamin^db,ixamax^db\}
4474 el(ix^d)=fc(ix^d,iwdim1,idim2)-ecc(ix^d,idir)
4475 er(ix^d)=fc(ix^d,iwdim1,idim2)-ecc({ix^d+i2kr^d},idir)
4476 {end do\}
4477 {!dir$ ivdep
4478 do ix^db=ixcmin^db,ixcmax^db\}
4479 if(vnorm(ix^d,idim1)>0.d0) then
4480 elc=el(ix^d)
4481 else if(vnorm(ix^d,idim1)<0.d0) then
4482 elc=el({ix^d+i1kr^d})
4483 else
4484 elc=0.5d0*(el(ix^d)+el({ix^d+i1kr^d}))
4485 end if
4486 if(vnorm({ix^d+i2kr^d},idim1)>0.d0) then
4487 erc=er(ix^d)
4488 else if(vnorm({ix^d+i2kr^d},idim1)<0.d0) then
4489 erc=er({ix^d+i1kr^d})
4490 else
4491 erc=0.5d0*(er(ix^d)+er({ix^d+i1kr^d}))
4492 end if
4493 fe(ix^d,idir)=fe(ix^d,idir)+0.25d0*(elc+erc)
4494 {end do\}
4495 ! add slope in idim1 direction from equation (50)
4496 ixamin^d=ixcmin^d;
4497 ixamax^d=ixcmax^d+i2kr^d;
4498 {do ix^db=ixamin^db,ixamax^db\}
4499 el(ix^d)=-fc(ix^d,iwdim2,idim1)-ecc(ix^d,idir)
4500 er(ix^d)=-fc(ix^d,iwdim2,idim1)-ecc({ix^d+i1kr^d},idir)
4501 {end do\}
4502 {!dir$ ivdep
4503 do ix^db=ixcmin^db,ixcmax^db\}
4504 if(vnorm(ix^d,idim2)>0.d0) then
4505 elc=el(ix^d)
4506 else if(vnorm(ix^d,idim2)<0.d0) then
4507 elc=el({ix^d+i2kr^d})
4508 else
4509 elc=0.5d0*(el(ix^d)+el({ix^d+i2kr^d}))
4510 end if
4511 if(vnorm({ix^d+i1kr^d},idim2)>0.d0) then
4512 erc=er(ix^d)
4513 else if(vnorm({ix^d+i1kr^d},idim2)<0.d0) then
4514 erc=er({ix^d+i2kr^d})
4515 else
4516 erc=0.5d0*(er(ix^d)+er({ix^d+i2kr^d}))
4517 end if
4518 fe(ix^d,idir)=fe(ix^d,idir)+0.25d0*(elc+erc)
4519 ! difference between average and upwind interpolated E
4520 if(partial_energy) ein(ix^d,idir)=fe(ix^d,idir)-ein(ix^d,idir)
4521 ! add resistive electric field at cell edges E=-vxB+eta J
4522 if(rmhd_eta/=zero) fe(ix^d,idir)=fe(ix^d,idir)+e_resi(ix^d,idir)
4523 ! times time step and edge length
4524 fe(ix^d,idir)=fe(ix^d,idir)*qdt*s%dsC(ix^d,idir)
4525 {end do\}
4526 end if
4527 end do
4528 end do
4529 end do
4530 if(partial_energy) then
4531 ! add upwind diffused magnetic energy back to energy
4532 ! calculate current density at cell edges
4533 jce=0.d0
4534 do idim1=1,ndim
4535 do idim2=1,ndim
4536 do idir=sdim,3
4537 if (lvc(idim1,idim2,idir)==0) cycle
4538 ixcmax^d=ixomax^d;
4539 ixcmin^d=ixomin^d+kr(idir,^d)-1;
4540 ixamax^d=ixcmax^d-kr(idir,^d)+1;
4541 ixamin^d=ixcmin^d;
4542 ! current at transverse faces
4543 xs(ixa^s,:)=x(ixa^s,:)
4544 xs(ixa^s,idim2)=x(ixa^s,idim2)+half*s%dx(ixa^s,idim2)
4545 call gradientf(wcts(ixgs^t,idim2),xs,ixgs^ll,ixc^l,idim1,gradi)
4546 if (lvc(idim1,idim2,idir)==1) then
4547 jce(ixc^s,idir)=jce(ixc^s,idir)+gradi(ixc^s)
4548 else
4549 jce(ixc^s,idir)=jce(ixc^s,idir)-gradi(ixc^s)
4550 end if
4551 end do
4552 end do
4553 end do
4554 do idir=sdim,3
4555 ixcmax^d=ixomax^d;
4556 ixcmin^d=ixomin^d+kr(idir,^d)-1;
4557 ! E dot J on cell edges
4558 ein(ixc^s,idir)=ein(ixc^s,idir)*jce(ixc^s,idir)
4559 ! average from cell edge to cell center
4560 {^ifthreed
4561 if(idir==1) then
4562 {do ix^db=ixomin^db,ixomax^db\}
4563 jce(ix^d,idir)=0.25d0*(ein(ix^d,idir)+ein(ix1,ix2-1,ix3,idir)+ein(ix1,ix2,ix3-1,idir)&
4564 +ein(ix1,ix2-1,ix3-1,idir))
4565 if(jce(ix^d,idir)<0.d0) jce(ix^d,idir)=0.d0
4566 w(ix^d,e_)=w(ix^d,e_)+qdt*jce(ix^d,idir)
4567 {end do\}
4568 else if(idir==2) then
4569 {do ix^db=ixomin^db,ixomax^db\}
4570 jce(ix^d,idir)=0.25d0*(ein(ix^d,idir)+ein(ix1-1,ix2,ix3,idir)+ein(ix1,ix2,ix3-1,idir)&
4571 +ein(ix1-1,ix2,ix3-1,idir))
4572 if(jce(ix^d,idir)<0.d0) jce(ix^d,idir)=0.d0
4573 w(ix^d,e_)=w(ix^d,e_)+qdt*jce(ix^d,idir)
4574 {end do\}
4575 else
4576 {do ix^db=ixomin^db,ixomax^db\}
4577 jce(ix^d,idir)=0.25d0*(ein(ix^d,idir)+ein(ix1-1,ix2,ix3,idir)+ein(ix1,ix2-1,ix3,idir)&
4578 +ein(ix1-1,ix2-1,ix3,idir))
4579 if(jce(ix^d,idir)<0.d0) jce(ix^d,idir)=0.d0
4580 w(ix^d,e_)=w(ix^d,e_)+qdt*jce(ix^d,idir)
4581 {end do\}
4582 end if
4583 }
4584 {^iftwod
4585 !idir=3
4586 {do ix^db=ixomin^db,ixomax^db\}
4587 jce(ix^d,idir)=0.25d0*(ein(ix^d,idir)+ein(ix1-1,ix2,idir)+ein(ix1,ix2-1,idir)&
4588 +ein(ix1-1,ix2-1,idir))
4589 if(jce(ix^d,idir)<0.d0) jce(ix^d,idir)=0.d0
4590 w(ix^d,e_)=w(ix^d,e_)+qdt*jce(ix^d,idir)
4591 {end do\}
4592 }
4593 ! save additional numerical resistive heating to an extra variable
4594 if(nwextra>0) then
4595 block%w(ixo^s,nw)=block%w(ixo^s,nw)+jce(ixo^s,idir)
4596 end if
4597 end do
4598 end if
4599 ! allow user to change inductive electric field, especially for boundary driven applications
4600 if(associated(usr_set_electric_field)) &
4601 call usr_set_electric_field(ixi^l,ixo^l,qt,qdt,fe,sct)
4602 circ(ixi^s,1:ndim)=zero
4603 ! Calculate circulation on each face
4604 do idim1=1,ndim ! Coordinate perpendicular to face
4605 ixcmax^d=ixomax^d;
4606 ixcmin^d=ixomin^d-kr(idim1,^d);
4607 do idim2=1,ndim
4608 ixa^l=ixc^l-kr(idim2,^d);
4609 do idir=sdim,3 ! Direction of line integral
4610 ! Assemble indices
4611 if(lvc(idim1,idim2,idir)==1) then
4612 ! Add line integrals in direction idir
4613 circ(ixc^s,idim1)=circ(ixc^s,idim1)&
4614 +(fe(ixc^s,idir)&
4615 -fe(ixa^s,idir))
4616 else if(lvc(idim1,idim2,idir)==-1) then
4617 ! Add line integrals in direction idir
4618 circ(ixc^s,idim1)=circ(ixc^s,idim1)&
4619 -(fe(ixc^s,idir)&
4620 -fe(ixa^s,idir))
4621 end if
4622 end do
4623 end do
4624 ! Divide by the area of the face to get dB/dt
4625 where(s%surfaceC(ixc^s,idim1) > smalldouble)
4626 circ(ixc^s,idim1)=circ(ixc^s,idim1)/s%surfaceC(ixc^s,idim1)
4627 elsewhere
4628 circ(ixc^s,idim1)=zero
4629 end where
4630 ! Time update cell-face magnetic field component
4631 bfaces(ixc^s,idim1)=bfaces(ixc^s,idim1)-circ(ixc^s,idim1)
4632 end do
4633 end associate
4634 end subroutine update_faces_contact
4635
4636 !> update faces
4637 subroutine update_faces_hll(ixI^L,ixO^L,qt,qdt,fE,sCT,s,vcts)
4640 use mod_usr_methods
4641 integer, intent(in) :: ixi^l, ixo^l
4642 double precision, intent(in) :: qt, qdt
4643 double precision, intent(inout) :: fe(ixi^s,sdim:3)
4644 type(state) :: sct, s
4645 type(ct_velocity) :: vcts
4646 double precision :: vtill(ixi^s,2)
4647 double precision :: vtilr(ixi^s,2)
4648 double precision :: bfacetot(ixi^s,ndim)
4649 double precision :: btill(ixi^s,ndim)
4650 double precision :: btilr(ixi^s,ndim)
4651 double precision :: cp(ixi^s,2)
4652 double precision :: cm(ixi^s,2)
4653 double precision :: circ(ixi^s,1:ndim)
4654 ! non-ideal electric field on cell edges
4655 double precision, dimension(ixI^S,sdim:3) :: e_resi
4656 integer :: hxc^l,ixc^l,ixcp^l,jxc^l,ixcm^l
4657 integer :: idim1,idim2,idir
4658
4659 associate(bfaces=>s%ws,bfacesct=>sct%ws,x=>s%x,vbarc=>vcts%vbarC,cbarmin=>vcts%cbarmin,&
4660 cbarmax=>vcts%cbarmax)
4661 ! Calculate contribution to FEM of each edge,
4662 ! that is, estimate value of line integral of
4663 ! electric field in the positive idir direction.
4664
4665 ! Loop over components of electric field
4666
4667 ! idir: electric field component we need to calculate
4668 ! idim1: directions in which we already performed the reconstruction
4669 ! idim2: directions in which we perform the reconstruction
4670
4671 ! if there is resistivity, get eta J
4672 if(rmhd_eta/=zero) call get_resistive_electric_field(ixi^l,ixo^l,sct,s,e_resi)
4673
4674 do idir=sdim,3
4675 ! Indices
4676 ! idir: electric field component
4677 ! idim1: one surface
4678 ! idim2: the other surface
4679 ! cyclic permutation: idim1,idim2,idir=1,2,3
4680 ! Velocity components on the surface
4681 ! follow cyclic premutations:
4682 ! Sx(1),Sx(2)=y,z ; Sy(1),Sy(2)=z,x ; Sz(1),Sz(2)=x,y
4683 ixcmax^d=ixomax^d;
4684 ixcmin^d=ixomin^d-1+kr(idir,^d);
4685 ! Set indices and directions
4686 idim1=mod(idir,3)+1
4687 idim2=mod(idir+1,3)+1
4688 jxc^l=ixc^l+kr(idim1,^d);
4689 ixcp^l=ixc^l+kr(idim2,^d);
4690 ! Reconstruct transverse transport velocities
4691 call reconstruct(ixi^l,ixc^l,idim2,vbarc(ixi^s,idim1,1),&
4692 vtill(ixi^s,2),vtilr(ixi^s,2))
4693 call reconstruct(ixi^l,ixc^l,idim1,vbarc(ixi^s,idim2,2),&
4694 vtill(ixi^s,1),vtilr(ixi^s,1))
4695 ! Reconstruct magnetic fields
4696 ! Eventhough the arrays are larger, reconstruct works with
4697 ! the limits ixG.
4698 if(b0field) then
4699 bfacetot(ixi^s,idim1)=bfacesct(ixi^s,idim1)+block%B0(ixi^s,idim1,idim1)
4700 bfacetot(ixi^s,idim2)=bfacesct(ixi^s,idim2)+block%B0(ixi^s,idim2,idim2)
4701 else
4702 bfacetot(ixi^s,idim1)=bfacesct(ixi^s,idim1)
4703 bfacetot(ixi^s,idim2)=bfacesct(ixi^s,idim2)
4704 end if
4705 call reconstruct(ixi^l,ixc^l,idim2,bfacetot(ixi^s,idim1),&
4706 btill(ixi^s,idim1),btilr(ixi^s,idim1))
4707 call reconstruct(ixi^l,ixc^l,idim1,bfacetot(ixi^s,idim2),&
4708 btill(ixi^s,idim2),btilr(ixi^s,idim2))
4709 ! Take the maximum characteristic
4710 cm(ixc^s,1)=max(cbarmin(ixcp^s,idim1),cbarmin(ixc^s,idim1))
4711 cp(ixc^s,1)=max(cbarmax(ixcp^s,idim1),cbarmax(ixc^s,idim1))
4712 cm(ixc^s,2)=max(cbarmin(jxc^s,idim2),cbarmin(ixc^s,idim2))
4713 cp(ixc^s,2)=max(cbarmax(jxc^s,idim2),cbarmax(ixc^s,idim2))
4714 ! Calculate eletric field
4715 fe(ixc^s,idir)=-(cp(ixc^s,1)*vtill(ixc^s,1)*btill(ixc^s,idim2) &
4716 + cm(ixc^s,1)*vtilr(ixc^s,1)*btilr(ixc^s,idim2) &
4717 - cp(ixc^s,1)*cm(ixc^s,1)*(btilr(ixc^s,idim2)-btill(ixc^s,idim2)))&
4718 /(cp(ixc^s,1)+cm(ixc^s,1)) &
4719 +(cp(ixc^s,2)*vtill(ixc^s,2)*btill(ixc^s,idim1) &
4720 + cm(ixc^s,2)*vtilr(ixc^s,2)*btilr(ixc^s,idim1) &
4721 - cp(ixc^s,2)*cm(ixc^s,2)*(btilr(ixc^s,idim1)-btill(ixc^s,idim1)))&
4722 /(cp(ixc^s,2)+cm(ixc^s,2))
4723 ! add resistive electric field at cell edges E=-vxB+eta J
4724 if(rmhd_eta/=zero) fe(ixc^s,idir)=fe(ixc^s,idir)+e_resi(ixc^s,idir)
4725 fe(ixc^s,idir)=qdt*s%dsC(ixc^s,idir)*fe(ixc^s,idir)
4726 if (.not.slab) then
4727 where(abs(x(ixc^s,r_)+half*dxlevel(r_)).lt.1.0d-9)
4728 fe(ixc^s,idir)=zero
4729 end where
4730 end if
4731 end do
4732 ! allow user to change inductive electric field, especially for boundary driven applications
4733 if(associated(usr_set_electric_field)) &
4734 call usr_set_electric_field(ixi^l,ixo^l,qt,qdt,fe,sct)
4735 circ(ixi^s,1:ndim)=zero
4736 ! Calculate circulation on each face: interal(fE dot dl)
4737 do idim1=1,ndim ! Coordinate perpendicular to face
4738 ixcmax^d=ixomax^d;
4739 ixcmin^d=ixomin^d-kr(idim1,^d);
4740 do idim2=1,ndim
4741 do idir=sdim,3 ! Direction of line integral
4742 ! Assemble indices
4743 if(lvc(idim1,idim2,idir)/=0) then
4744 hxc^l=ixc^l-kr(idim2,^d);
4745 ! Add line integrals in direction idir
4746 circ(ixc^s,idim1)=circ(ixc^s,idim1)&
4747 +lvc(idim1,idim2,idir)&
4748 *(fe(ixc^s,idir)&
4749 -fe(hxc^s,idir))
4750 end if
4751 end do
4752 end do
4753 ! Divide by the area of the face to get dB/dt
4754 where(s%surfaceC(ixc^s,idim1) > 1.0d-9*s%dvolume(ixc^s))
4755 circ(ixc^s,idim1)=circ(ixc^s,idim1)/s%surfaceC(ixc^s,idim1)
4756 elsewhere
4757 circ(ixc^s,idim1)=zero
4758 end where
4759 ! Time update cell-face magnetic field component
4760 bfaces(ixc^s,idim1)=bfaces(ixc^s,idim1)-circ(ixc^s,idim1)
4761 end do
4762 end associate
4763 end subroutine update_faces_hll
4764
4765 !> calculate eta J at cell edges
4766 subroutine get_resistive_electric_field(ixI^L,ixO^L,sCT,s,jce)
4768 use mod_usr_methods
4769 use mod_geometry
4770 integer, intent(in) :: ixi^l, ixo^l
4771 type(state), intent(in) :: sct, s
4772 ! current on cell edges
4773 double precision :: jce(ixi^s,sdim:3)
4774 ! current on cell centers
4775 double precision :: jcc(ixi^s,7-2*ndir:3)
4776 ! location at cell faces
4777 double precision :: xs(ixgs^t,1:ndim)
4778 ! resistivity
4779 double precision :: eta(ixi^s)
4780 double precision :: gradi(ixgs^t)
4781 integer :: ix^d,ixc^l,ixa^l,ixb^l,idir,idirmin,idim1,idim2
4782
4783 associate(x=>s%x,dx=>s%dx,w=>s%w,wct=>sct%w,wcts=>sct%ws)
4784 ! calculate current density at cell edges
4785 jce=0.d0
4786 do idim1=1,ndim
4787 do idim2=1,ndim
4788 do idir=sdim,3
4789 if (lvc(idim1,idim2,idir)==0) cycle
4790 ixcmax^d=ixomax^d;
4791 ixcmin^d=ixomin^d+kr(idir,^d)-1;
4792 ixbmax^d=ixcmax^d-kr(idir,^d)+1;
4793 ixbmin^d=ixcmin^d;
4794 ! current at transverse faces
4795 xs(ixb^s,:)=x(ixb^s,:)
4796 xs(ixb^s,idim2)=x(ixb^s,idim2)+half*dx(ixb^s,idim2)
4797 call gradientf(wcts(ixgs^t,idim2),xs,ixgs^ll,ixc^l,idim1,gradi,2)
4798 if (lvc(idim1,idim2,idir)==1) then
4799 jce(ixc^s,idir)=jce(ixc^s,idir)+gradi(ixc^s)
4800 else
4801 jce(ixc^s,idir)=jce(ixc^s,idir)-gradi(ixc^s)
4802 end if
4803 end do
4804 end do
4805 end do
4806 ! get resistivity
4807 if(rmhd_eta>zero)then
4808 jce(ixi^s,:)=jce(ixi^s,:)*rmhd_eta
4809 else
4810 ixa^l=ixo^l^ladd1;
4811 call get_current(wct,ixi^l,ixa^l,idirmin,jcc)
4812 call usr_special_resistivity(wct,ixi^l,ixa^l,idirmin,x,jcc,eta)
4813 ! calcuate eta on cell edges
4814 do idir=sdim,3
4815 ixcmax^d=ixomax^d;
4816 ixcmin^d=ixomin^d+kr(idir,^d)-1;
4817 jcc(ixc^s,idir)=0.d0
4818 {do ix^db=0,1\}
4819 if({ ix^d==1 .and. ^d==idir | .or.}) cycle
4820 ixamin^d=ixcmin^d+ix^d;
4821 ixamax^d=ixcmax^d+ix^d;
4822 jcc(ixc^s,idir)=jcc(ixc^s,idir)+eta(ixa^s)
4823 {end do\}
4824 jcc(ixc^s,idir)=jcc(ixc^s,idir)*0.25d0
4825 jce(ixc^s,idir)=jce(ixc^s,idir)*jcc(ixc^s,idir)
4826 end do
4827 end if
4828 end associate
4829 end subroutine get_resistive_electric_field
4830
4831 !> calculate cell-center values from face-center values
4832 subroutine rmhd_face_to_center(ixO^L,s)
4834 ! Non-staggered interpolation range
4835 integer, intent(in) :: ixo^l
4836 type(state) :: s
4837 integer :: ix^d
4838
4839 ! calculate cell-center values from face-center values in 2nd order
4840 ! because the staggered arrays have an additional place to the left.
4841 ! Interpolate to cell barycentre using arithmetic average
4842 ! This might be done better later, to make the method less diffusive.
4843 {!dir$ ivdep
4844 do ix^db=ixomin^db,ixomax^db\}
4845 {^ifthreed
4846 s%w(ix^d,b1_)=half/s%surface(ix^d,1)*(s%ws(ix^d,1)*s%surfaceC(ix^d,1)&
4847 +s%ws(ix1-1,ix2,ix3,1)*s%surfaceC(ix1-1,ix2,ix3,1))
4848 s%w(ix^d,b2_)=half/s%surface(ix^d,2)*(s%ws(ix^d,2)*s%surfaceC(ix^d,2)&
4849 +s%ws(ix1,ix2-1,ix3,2)*s%surfaceC(ix1,ix2-1,ix3,2))
4850 s%w(ix^d,b3_)=half/s%surface(ix^d,3)*(s%ws(ix^d,3)*s%surfaceC(ix^d,3)&
4851 +s%ws(ix1,ix2,ix3-1,3)*s%surfaceC(ix1,ix2,ix3-1,3))
4852 }
4853 {^iftwod
4854 s%w(ix^d,b1_)=half/s%surface(ix^d,1)*(s%ws(ix^d,1)*s%surfaceC(ix^d,1)&
4855 +s%ws(ix1-1,ix2,1)*s%surfaceC(ix1-1,ix2,1))
4856 s%w(ix^d,b2_)=half/s%surface(ix^d,2)*(s%ws(ix^d,2)*s%surfaceC(ix^d,2)&
4857 +s%ws(ix1,ix2-1,2)*s%surfaceC(ix1,ix2-1,2))
4858 }
4859 {end do\}
4860 ! calculate cell-center values from face-center values in 4th order
4861 !do idim=1,ndim
4862 ! gxO^L=ixO^L-2*kr(idim,^D);
4863 ! hxO^L=ixO^L-kr(idim,^D);
4864 ! jxO^L=ixO^L+kr(idim,^D);
4865
4866 ! ! Interpolate to cell barycentre using fourth order central formula
4867 ! w(ixO^S,mag(idim))=(0.0625d0/s%surface(ixO^S,idim))*&
4868 ! ( -ws(gxO^S,idim)*s%surfaceC(gxO^S,idim) &
4869 ! +9.0d0*ws(hxO^S,idim)*s%surfaceC(hxO^S,idim) &
4870 ! +9.0d0*ws(ixO^S,idim)*s%surfaceC(ixO^S,idim) &
4871 ! -ws(jxO^S,idim)*s%surfaceC(jxO^S,idim) )
4872 !end do
4873
4874 ! calculate cell-center values from face-center values in 6th order
4875 !do idim=1,ndim
4876 ! fxO^L=ixO^L-3*kr(idim,^D);
4877 ! gxO^L=ixO^L-2*kr(idim,^D);
4878 ! hxO^L=ixO^L-kr(idim,^D);
4879 ! jxO^L=ixO^L+kr(idim,^D);
4880 ! kxO^L=ixO^L+2*kr(idim,^D);
4881
4882 ! ! Interpolate to cell barycentre using sixth order central formula
4883 ! w(ixO^S,mag(idim))=(0.00390625d0/s%surface(ixO^S,idim))* &
4884 ! ( +3.0d0*ws(fxO^S,idim)*s%surfaceC(fxO^S,idim) &
4885 ! -25.0d0*ws(gxO^S,idim)*s%surfaceC(gxO^S,idim) &
4886 ! +150.0d0*ws(hxO^S,idim)*s%surfaceC(hxO^S,idim) &
4887 ! +150.0d0*ws(ixO^S,idim)*s%surfaceC(ixO^S,idim) &
4888 ! -25.0d0*ws(jxO^S,idim)*s%surfaceC(jxO^S,idim) &
4889 ! +3.0d0*ws(kxO^S,idim)*s%surfaceC(kxO^S,idim) )
4890 !end do
4891 end subroutine rmhd_face_to_center
4892
4893 !> calculate magnetic field from vector potential
4894 subroutine b_from_vector_potential(ixIs^L, ixI^L, ixO^L, ws, x)
4897 integer, intent(in) :: ixis^l, ixi^l, ixo^l
4898 double precision, intent(inout) :: ws(ixis^s,1:nws)
4899 double precision, intent(in) :: x(ixi^s,1:ndim)
4900 double precision :: adummy(ixis^s,1:3)
4901
4902 call b_from_vector_potentiala(ixis^l, ixi^l, ixo^l, ws, x, adummy)
4903 end subroutine b_from_vector_potential
4904
4905 subroutine rfactor_from_temperature_ionization(w,x,ixI^L,ixO^L,Rfactor)
4908 integer, intent(in) :: ixi^l, ixo^l
4909 double precision, intent(in) :: w(ixi^s,1:nw)
4910 double precision, intent(in) :: x(ixi^s,1:ndim)
4911 double precision, intent(out):: rfactor(ixi^s)
4912 double precision :: iz_h(ixo^s),iz_he(ixo^s)
4913
4914 call ionization_degree_from_temperature(ixi^l,ixo^l,w(ixi^s,te_),iz_h,iz_he)
4915 ! assume the first and second ionization of Helium have the same degree
4916 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)
4917 end subroutine rfactor_from_temperature_ionization
4918
4919 subroutine rfactor_from_constant_ionization(w,x,ixI^L,ixO^L,Rfactor)
4921 integer, intent(in) :: ixi^l, ixo^l
4922 double precision, intent(in) :: w(ixi^s,1:nw)
4923 double precision, intent(in) :: x(ixi^s,1:ndim)
4924 double precision, intent(out):: rfactor(ixi^s)
4925
4926 rfactor(ixo^s)=rr
4927 end subroutine rfactor_from_constant_ionization
4928end module mod_rmhd_phys
Module for including anisotropic flux limited diffusion (AFLD)-approximation in Radiation-hydrodynami...
Definition mod_afld.t:8
subroutine afld_get_diffcoef_central(w, wct, x, ixil, ixol)
Calculates cell-centered diffusion coefficient to be used in multigrid.
Definition mod_afld.t:684
subroutine, public get_afld_rad_force(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 This subroutine handles th...
Definition mod_afld.t:141
subroutine, public afld_init(he_abundance, rhd_radiation_diffusion, afld_gamma)
Initialising FLD-module: Read opacities Initialise Multigrid adimensionalise kappa Add extra variable...
Definition mod_afld.t:93
subroutine, public afld_radforce_get_dt(w, ixil, ixol, dtnew, dxd, x)
Definition mod_afld.t:217
subroutine, public afld_get_radpress(w, x, ixil, ixol, rad_pressure, nth)
Calculate Radiation Pressure Returns Radiation Pressure as tensor.
Definition mod_afld.t:518
subroutine, public get_afld_energy_interact(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 This subroutine handles th...
Definition mod_afld.t:244
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 const_rad_a
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.
Nicolas Moens Module for including flux limited diffusion (FLD)-approximation in Radiation-hydrodynam...
Definition mod_fld.t:9
subroutine, public get_fld_rad_force(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 This subroutine handles th...
Definition mod_fld.t:146
subroutine, public fld_get_radpress(w, x, ixil, ixol, rad_pressure, nth)
Calculate Radiation Pressure Returns Radiation Pressure as tensor.
Definition mod_fld.t:456
subroutine, public fld_init(he_abundance, radiation_diffusion, energy_interact, r_gamma)
Initialising FLD-module: Read opacities Initialise Multigrid adimensionalise kappa Add extra variable...
Definition mod_fld.t:94
subroutine fld_get_diffcoef_central(w, wct, x, ixil, ixol)
Calculates cell-centered diffusion coefficient to be used in multigrid.
Definition mod_fld.t:719
character(len=8) fld_diff_scheme
Which method to solve diffusion part.
Definition mod_fld.t:35
subroutine, public fld_radforce_get_dt(w, ixil, ixol, dtnew, dxd, x)
Definition mod_fld.t:181
Module with basic grid data structures.
Definition mod_forest.t:2
type(tree_node_ptr), dimension(:,:), allocatable, save igrid_to_node
Array to go from an [igrid, ipe] index to a node pointer.
Definition mod_forest.t:32
subroutine, public get_divb(w, ixil, ixol, divb, nth_in)
Calculate div B within ixO.
integer, dimension(:), allocatable, public mag
Indices of the magnetic field.
Module with geometry-related routines (e.g., divergence, curl)
Definition mod_geometry.t:2
subroutine divvector(qvec, ixil, ixol, divq, nth_in)
integer coordinate
Definition mod_geometry.t:7
integer, parameter spherical
integer, parameter cylindrical
subroutine curlvector(qvec, ixil, ixol, curlvec, idirmin, idirmin0, ndir0, fourthorder)
Calculate curl of a vector qvec within ixL Options to employ standard second order CD evaluations use...
subroutine gradient(q, ixil, ixol, idir, gradq, nth_in)
subroutine gradientf(q, x, ixil, ixol, idir, gradq, nth_in, pm_in)
subroutine gradientl(q, ixil, ixol, idir, gradq)
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, parameter bc_noinflow
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.
double precision unit_opacity
Physical scaling factor for Opacity.
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.
double precision unit_radflux
Physical scaling factor for radiation flux.
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 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
Radiation-magneto-hydrodynamics module.
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)...
integer, public, protected rmhd_trac_type
Which TRAC method is used.
character(len=8), public rmhd_pressure
In the case of no rmhd_energy, how to compute pressure.
subroutine, public rmhd_phys_init()
logical, public, protected rmhd_thermal_conduction
Whether thermal conduction is used.
double precision, public rmhd_gamma
The adiabatic index.
character(len=8), public rmhd_radiation_formalism
Formalism to treat radiation.
logical, public divbwave
Add divB wave in Roe solver.
integer, public, protected rmhd_trac_finegrid
Distance between two adjacent traced magnetic field lines (in finest cell size)
double precision, public, protected h_ion_fr
Ionization fraction of H H_ion_fr = H+/(H+ + H)
integer, dimension(2 *^nd), public, protected boundary_divbfix_skip
To skip * layer of ghost cells during divB=0 fix for boundary.
logical, public, protected rmhd_hyperbolic_thermal_conduction
Whether thermal conduction is used.
double precision, public, protected rr
logical, public rmhd_equi_thermal
double precision, public rmhd_etah
Hall resistivity.
logical, public, protected rmhd_radiation_diffusion
Treat radiation energy diffusion.
subroutine, public rmhd_face_to_center(ixol, s)
calculate cell-center values from face-center values
procedure(sub_get_pthermal), pointer, public rmhd_get_pthermal
integer, public, protected psi_
Indices of the GLM psi.
type(tc_fluid), allocatable, public tc_fl
type of fluid for thermal conduction
integer, public, protected c
Indices of the momentum density for the form of better vectorization.
subroutine, public b_from_vector_potential(ixisl, ixil, ixol, ws, x)
calculate magnetic field from vector potential
logical, public, protected rmhd_cak_force
Whether CAK radiation line force is activated.
logical, public, protected rmhd_radiation_force
Treat radiation fld_Rad_force.
logical, public, protected rmhd_glm
Whether GLM-MHD is used to control div B.
double precision, public, protected small_r_e
The smallest allowed radiation energy.
double precision, public rmhd_eta_hyper
The MHD hyper-resistivity.
logical, public clean_initial_divb
clean initial divB
integer, public, protected rmhd_n_tracer
Number of tracer species.
logical, public, protected rmhd_particles
Whether particles module is added.
integer, public, protected b
double precision, public kbmpmua4
kb/(m_p mu)* 1/a_rad**4,
integer, public, protected m
subroutine, public rmhd_get_trad(w, x, ixil, ixol, trad)
Calculates radiation temperature.
integer, public equi_rho0_
equi vars indices in the stateequi_vars array
double precision, public rmhd_adiab
The adiabatic constant.
subroutine, public rmhd_get_pthermal_plus_pradiation(w, x, ixil, ixol, pth_plus_prad)
Calculates the sum of the gas pressure and the max Prad tensor element.
integer, public, protected q_
Index of the heat flux q.
integer, public, protected tweight_
logical, public has_equi_rho0
whether split off equilibrium density
double precision, public rmhd_eta
The MHD resistivity.
integer, public, protected p_
Index of the gas pressure (-1 if not present) should equal e_.
subroutine, public get_normalized_divb(w, ixil, ixol, divb)
get dimensionless div B = |divB| * volume / area / |B|
integer, public, protected rho_
Index of the density (in the w array)
integer, public, protected c_
double precision function, dimension(ixo^s), public rmhd_mag_en_all(w, ixil, ixol)
Compute 2 times total magnetic energy.
type(te_fluid), allocatable, public te_fl_rmhd
type of fluid for thermal emission synthesis
logical, public, protected rmhd_gravity
Whether gravity is added.
integer, dimension(:), allocatable, public, protected mom
Indices of the momentum density.
logical, public, protected rmhd_glm_extended
Whether extended GLM-MHD is used with additional sources.
logical, public, protected rmhd_viscosity
Whether viscosity is added.
logical, public, protected rmhd_partial_ionization
Whether plasma is partially ionized.
integer, public, protected tcoff_
Index of the cutoff temperature for the TRAC method.
integer, public, protected e_
Index of the energy density (-1 if not present)
logical, public, protected rmhd_radiation_advection
Treat radiation advection.
double precision, public, protected he_ion_fr2
Ratio of number He2+ / number He+ + He2+ He_ion_fr2 = He2+/(He2+ + He+)
subroutine, public rmhd_get_rho(w, x, ixil, ixol, rho)
integer, dimension(:), allocatable, public, protected tracer
Indices of the tracers.
logical, public, protected rmhd_energy_interact
Treat radiation-gas energy interaction.
subroutine, public rmhd_get_tgas(w, x, ixil, ixol, tgas)
Calculates gas temperature.
character(len=std_len), public, protected type_ct
Method type of constrained transport.
procedure(sub_convert), pointer, public rmhd_to_conserved
double precision, public, protected he_abundance
Helium abundance over Hydrogen.
logical, public partial_energy
Whether an internal or hydrodynamic energy equation is used.
procedure(sub_convert), pointer, public rmhd_to_primitive
logical, public, protected rmhd_dump_full_vars
whether dump full variables (when splitting is used) in a separate dat file
logical, public, protected rmhd_trac
Whether TRAC method is used.
subroutine, public rmhd_clean_divb_multigrid(qdt, qt, active)
subroutine, public rmhd_set_mg_bounds
Set the boundaries for the diffusion of E.
subroutine, public rmhd_get_v(w, x, ixil, ixol, v)
Calculate v vector.
double precision, public hypertc_kappa
The thermal conductivity kappa in hyperbolic thermal conduction.
logical, public has_equi_pe0
whether split off equilibrium thermal pressure
subroutine, public rmhd_get_pradiation(w, x, ixil, ixol, prad, nth)
Calculate radiation pressure within ixO^L.
integer, public, protected te_
Indices of temperature.
logical, public, protected source_split_divb
Whether divB cleaning sources are added splitting from fluid solver.
integer, public, protected r_e
Index of the radiation energy.
procedure(sub_get_pthermal), pointer, public rmhd_get_temperature
character(len=std_len), public, protected typedivbfix
Method type to clean divergence of B.
logical, public, protected b0field_forcefree
B0 field is force-free.
double precision, public rmhd_glm_alpha
GLM-MHD parameter: ratio of the diffusive and advective time scales for div b taking values within [0...
integer, public, protected rmhd_divb_nth
Whether divB is computed with a fourth order approximation.
subroutine, public rmhd_ei_to_e(ixil, ixol, w, x)
Transform internal energy to total energy.
integer, public equi_pe0_
double precision, public, protected he_ion_fr
Ionization fraction of He He_ion_fr = (He2+ + He+)/(He2+ + He+ + He)
logical, public, protected rmhd_energy
Whether an energy equation is used.
logical, dimension(2 *^nd), public, protected boundary_divbfix
To control divB=0 fix for boundary.
double precision, public, protected rmhd_trac_mask
Height of the mask used in the TRAC method.
logical, public, protected eq_state_units
subroutine, public rmhd_e_to_ei(ixil, ixol, w, x)
Transform total energy to internal energy.
logical, public, protected rmhd_4th_order
MHD fourth order.
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(set_equi_vars), pointer usr_set_equi_vars
procedure(special_mg_bc), pointer usr_special_mg_bc
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