27 double precision,
protected :: small_e
29 double precision,
public,
protected ::
small_r_e = 0.d0
38 double precision :: divbdiff = 0.8d0
43 double precision,
public,
protected ::
h_ion_fr=1d0
46 double precision,
public,
protected ::
he_ion_fr=1d0
53 double precision,
public,
protected ::
rr=1d0
55 double precision :: gamma_1, inv_gamma_1
57 double precision :: inv_squared_c0, inv_squared_c
64 integer,
public,
protected ::
rho_
66 integer,
allocatable,
public,
protected ::
mom(:)
68 integer,
public,
protected :: ^
c&m^C_
70 integer,
public,
protected ::
e_
72 integer,
public,
protected ::
r_e
74 integer,
public,
protected :: ^
c&b^C_
76 integer,
public,
protected ::
p_
78 integer,
public,
protected ::
q_
80 integer,
public,
protected ::
psi_
82 integer,
public,
protected ::
te_
87 integer,
allocatable,
public,
protected ::
tracer(:)
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
145 logical :: compactres = .false.
163 logical,
protected :: radio_acoustic_filter = .false.
164 integer,
protected :: size_ra_filter = 1
168 logical :: dt_c = .false.
178 logical :: total_energy = .true.
182 logical :: gravity_energy
184 logical :: gravity_rhov = .false.
186 character(len=std_len),
public,
protected ::
typedivbfix =
'linde'
188 character(len=std_len),
public,
protected ::
type_ct =
'uct_contact'
190 character(len=std_len) :: typedivbdiff =
'all'
230 subroutine rmhd_read_params(files)
233 character(len=*),
intent(in) :: files(:)
251 do n = 1,
size(files)
252 open(
unitpar, file=trim(files(n)), status=
"old")
253 read(
unitpar, rmhd_list,
end=111)
257 end subroutine rmhd_read_params
260 subroutine rmhd_write_info(fh)
262 integer,
intent(in) :: fh
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)
269 call mpi_file_write(fh, n_par, 1, mpi_integer, st, er)
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
301 if(
mype==0)
write(*,*)
'WARNING: set rmhd_partial_ionization=F when eq_state_units=F'
307 if(
mype==0)
write(*,*)
'WARNING: turn off parabolic TC when using hyperbolic TC'
310 physics_type =
"rmhd"
325 phys_total_energy=total_energy
327 gravity_energy=.true.
332 gravity_energy=.false.
338 if(
mype==0)
write(*,*)
'WARNING: reset rmhd_trac_type=1 for 1D simulation'
343 if(
mype==0)
write(*,*)
'WARNING: set rmhd_trac_mask==bigdouble for global TRAC method'
352 type_divb = divb_none
355 type_divb = divb_multigrid
357 mg%operator_type = mg_laplacian
364 case (
'powel',
'powell')
365 type_divb = divb_powel
367 type_divb = divb_janhunen
369 type_divb = divb_linde
370 case (
'lindejanhunen')
371 type_divb = divb_lindejanhunen
373 type_divb = divb_lindepowel
377 type_divb = divb_lindeglm
382 call mpistop(
'Unknown divB fix')
385 allocate(start_indices(number_species),stop_indices(number_species))
392 mom(:) = var_set_momentum(
ndir)
398 e_ = var_set_energy()
407 mag(:) = var_set_bfield(
ndir)
411 psi_ = var_set_fluxvar(
'psi',
'psi', need_bc=.false.)
417 r_e = var_set_radiation_energy()
430 tracer(itr) = var_set_fluxvar(
"trc",
"trp", itr, need_bc=.false.)
443 te_ = var_set_auxvar(
'Te',
'Te')
452 stop_indices(1)=nwflux
482 allocate(iw_vector(nvector))
483 iw_vector(1) = mom(1) - 1
484 iw_vector(2) = mag(1) - 1
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")
494 if(nwflux>mag(
ndir))
then
496 flux_type(:,mag(
ndir)+1:nwflux)=flux_hll
501 flux_type(:,
psi_)=flux_special
503 flux_type(idir,mag(idir))=flux_special
507 flux_type(idir,mag(idir))=flux_tvdlf
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
519 phys_get_cbounds => rmhd_get_cbounds_split_rho
521 phys_get_cbounds => rmhd_get_cbounds
524 phys_to_primitive => rmhd_to_primitive_split_rho
526 phys_to_conserved => rmhd_to_conserved_split_rho
529 phys_to_primitive => rmhd_to_primitive_origin
531 phys_to_conserved => rmhd_to_conserved_origin
535 phys_get_flux => rmhd_get_flux_split
537 phys_get_flux => rmhd_get_flux
541 phys_add_source_geom => rmhd_add_source_geom_split
543 phys_add_source_geom => rmhd_add_source_geom
545 phys_add_source => rmhd_add_source
546 phys_check_params => rmhd_check_params
547 phys_write_info => rmhd_write_info
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
557 phys_get_pthermal => rmhd_get_pthermal_origin
561 phys_set_equi_vars => set_equi_vars_grid
564 if(type_divb==divb_glm)
then
565 phys_modify_wlr => rmhd_modify_wlr
570 rmhd_get_rfactor=>rfactor_from_temperature_ionization
571 phys_update_temperature => rmhd_update_temperature
575 rmhd_get_rfactor=>rfactor_from_constant_ionization
590 phys_get_ct_velocity => rmhd_get_ct_velocity
591 phys_update_faces => rmhd_update_faces
593 phys_modify_wlr => rmhd_modify_wlr
595 phys_boundary_adjust => rmhd_boundary_adjust
604 call rmhd_physical_units()
613 call mpistop(
'Radiation formalism unknown')
620 call mpistop(
"thermal conduction needs rmhd_energy=T")
623 call mpistop(
"hyperbolic thermal conduction needs rmhd_energy=T")
633 call add_sts_method(rmhd_get_tc_dt_rmhd,rmhd_sts_set_source_tc_rmhd,e_,1,e_,1,.false.)
635 tc_fl%get_temperature_from_conserved => rmhd_get_temperature_from_etot_with_equi
637 tc_fl%get_temperature_from_conserved => rmhd_get_temperature_from_etot
640 tc_fl%get_temperature_from_eint => rmhd_get_temperature_from_eint_with_equi
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
646 tc_fl%has_equi = .false.
649 tc_fl%get_temperature_from_eint => rmhd_get_temperature_from_eint
661 te_fl_rmhd%get_var_Rfactor => rmhd_get_rfactor
663 phys_te_images => rmhd_te_images
676 if (particles_eta < zero) particles_eta =
rmhd_eta
677 if (particles_etah < zero) particles_eta =
rmhd_etah
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
692 subroutine rmhd_te_images
697 case(
'EIvtiCCmpi',
'EIvtuCCmpi')
699 case(
'ESvtiCCmpi',
'ESvtuCCmpi')
701 case(
'SIvtiCCmpi',
'SIvtuCCmpi')
703 case(
'WIvtiCCmpi',
'WIvtuCCmpi')
706 call mpistop(
"Error in synthesize emission: Unknown convert_type")
708 end subroutine rmhd_te_images
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
724 end subroutine rmhd_sts_set_source_tc_rmhd
726 function rmhd_get_tc_dt_rmhd(w,ixI^L,ixO^L,dx^D,x)
result(dtnew)
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
738 end function rmhd_get_tc_dt_rmhd
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
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
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
760 logical :: tc_perpendicular=.false.
761 logical :: tc_saturate=.false.
762 character(len=std_len) :: tc_slope_limiter=
"MC"
764 namelist /tc_list/ tc_perpendicular, tc_saturate, tc_slope_limiter, tc_k_para, tc_k_perp
768 read(
unitpar, tc_list,
end=111)
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)
778 fl%tc_slope_limiter = 0
781 fl%tc_slope_limiter = 1
784 fl%tc_slope_limiter = 2
787 fl%tc_slope_limiter = 3
790 fl%tc_slope_limiter = 4
792 call mpistop(
"Unknown tc_slope_limiter, choose MC, minmod")
794 end subroutine tc_params_read_rmhd
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
811 delx(ixi^s,1:
ndim)=ps(igrid)%dx(ixi^s,1:
ndim)
815 hxo^
l=ixo^
l-
kr(idims,^
d);
821 ixcmax^
d=ixomax^
d; ixcmin^
d=hxomin^
d;
824 xshift^
d=half*(one-
kr(^
d,idims));
831 xc(ix^
d%ixC^s,^
d)=x(ix^
d%ixC^s,^
d)+(half-xshift^
d)*delx(ix^
d%ixC^s,^
d)
835 call usr_set_equi_vars(ixi^l,ixc^l,xc,ps(igrid)%equi_vars(ixi^s,1:number_equi_vars,idims))
837 end subroutine set_equi_vars_grid_faces
840 subroutine set_equi_vars_grid(igrid)
843 integer,
intent(in) :: igrid
849 call set_equi_vars_grid_faces(igrid,ps(igrid)%x,ixg^
ll,
ixm^
ll)
850 end subroutine set_equi_vars_grid
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)
865 wnew(ixo^s,
mom(:))=w(ixo^s,
mom(:))
871 wnew(ixo^s,mag(1:
ndir))=w(ixo^s,mag(1:
ndir))
875 wnew(ixo^s,
e_)=w(ixo^s,
e_)
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)
884 end function convert_vars_splitting
886 subroutine rmhd_check_params
894 if (
rmhd_gamma <= 0.0d0)
call mpistop (
"Error: rmhd_gamma <= 0")
895 if (
rmhd_adiab < 0.0d0)
call mpistop (
"Error: rmhd_adiab < 0")
899 call mpistop (
"Error: rmhd_gamma <= 0 or rmhd_gamma == 1")
900 inv_gamma_1=1.d0/gamma_1
907 call mpistop(
"usr_set_equi_vars has to be implemented in the user file")
912 if(
mype .eq. 0) print*,
" add conversion method: split -> full "
919 end subroutine rmhd_check_params
933 mg%bc(ib, mg_iphi)%bc_type = mg_bc_neumann
934 mg%bc(ib, mg_iphi)%bc_value = 0.0_dp
937 mg%bc(ib, mg_iphi)%bc_type = mg_bc_dirichlet
938 mg%bc(ib, mg_iphi)%bc_value = 0.0_dp
942 mg%bc(ib, mg_iphi)%bc_type = mg_bc_neumann
943 mg%bc(ib, mg_iphi)%bc_value = 0.0_dp
951 call mpistop(
"divE_multigrid warning: unknown b.c. ")
956 subroutine rmhd_physical_units()
958 double precision :: mp,kb,miu0,c_lightspeed
959 double precision :: a,
b
1104 end subroutine rmhd_physical_units
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
1116 {
do ix^db=ixomin^db,ixomax^db\}
1130 tmp=w(ix^
d,
e_)-half*((^
c&w(ix^
d,
m^
c_)**2+)/tmp+(^
c&w(ix^
d,
b^
c_)**2+))
1134 if(tmp<small_e) flag(ix^
d,
e_) = .true.
1139 end subroutine rmhd_check_w_origin
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)
1149 {
do ix^db=ixomin^db,ixomax^db\}
1151 w(ix^
d,
e_)=w(ix^
d,
p_)*inv_gamma_1&
1153 +(^
c&w(ix^
d,
b^
c_)**2+))
1157 end subroutine rmhd_to_conserved_origin
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
1168 {
do ix^db=ixomin^db,ixomax^db\}
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+))
1177 end subroutine rmhd_to_conserved_split_rho
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
1190 call rmhd_handle_small_values(.false., w, x, ixi^
l, ixo^
l,
'rmhd_to_primitive_origin')
1193 {
do ix^db=ixomin^db,ixomax^db\}
1194 inv_rho = 1.d0/w(ix^
d,
rho_)
1198 w(ix^
d,
p_)=gamma_1*(w(ix^
d,
e_)&
1200 +(^
c&w(ix^
d,
b^
c_)**2+)))
1202 end subroutine rmhd_to_primitive_origin
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
1215 call rmhd_handle_small_values(.false., w, x, ixi^
l, ixo^
l,
'rmhd_to_primitive_split_rho')
1218 {
do ix^db=ixomin^db,ixomax^db\}
1223 w(ix^
d,
p_)=gamma_1*(w(ix^
d,
e_)&
1225 (^
c&w(ix^
d,
m^
c_)**2+)+(^
c&w(ix^
d,
b^
c_)**2+)))
1227 end subroutine rmhd_to_primitive_split_rho
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)
1239 {
do ix^db=ixomin^db,ixomax^db\}
1242 +half*((^
c&w(ix^
d,
m^
c_)**2+)/&
1244 +(^
c&w(ix^
d,
b^
c_)**2+))
1247 {
do ix^db=ixomin^db,ixomax^db\}
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+))
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)
1266 {
do ix^db=ixomin^db,ixomax^db\}
1269 -half*((^
c&w(ix^
d,
m^
c_)**2+)/&
1271 +(^
c&w(ix^
d,
b^
c_)**2+))
1274 {
do ix^db=ixomin^db,ixomax^db\}
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+))
1282 if(fix_small_values)
then
1283 call rmhd_handle_small_ei(w,x,ixi^l,ixi^l,
e_,
'rmhd_e_to_ei')
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)
1299 call phys_check_w(primitive, ixi^
l, ixi^
l, w, flag)
1303 {
do ix^db=ixomin^db,ixomax^db\}
1313 if(flag({ix^
d},
rho_)) w({ix^
d},
m^
c_)=0.0d0
1325 w(ix^
d,
e_)=small_e+half*((^
c&w(ix^
d,
m^
c_)**2+)/rho+(^
c&w(ix^
d,
b^
c_)**2+))&
1329 w(ix^
d,
e_)=small_e+half*((^
c&w(ix^
d,
m^
c_)**2+)/rho+(^
c&w(ix^
d,
b^
c_)**2+))
1336 call small_values_average(ixi^l, ixo^l, w, x, flag,
rho_)
1338 call small_values_average(ixi^l, ixo^l, w, x, flag,
p_)
1341 {
do ix^db=iximin^db,iximax^db\}
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+))
1350 call small_values_average(ixi^l, ixo^l, w, x, flag,
e_)
1352 {
do ix^db=iximin^db,iximax^db\}
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+))
1362 call small_values_average(ixi^l, ixo^l, w, x, flag,
r_e)
1364 if(.not.primitive)
then
1367 {
do ix^db=iximin^db,iximax^db\}
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+)))
1378 call small_values_error(w, x, ixi^l, ixo^l, flag, subname)
1381 end subroutine rmhd_handle_small_values_origin
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)
1393 rho(ixo^s)=1.d0/rho(ixo^s)
1396 v(ixo^s, idir) = w(ixo^s,
mom(idir))*rho(ixo^s)
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
1410 {
do ix^db=ixomin^db,ixomax^db \}
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)
1428 {
do ix^db=ixomin^db,ixomax^db \}
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)
1446 end subroutine rmhd_get_cmax_origin
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
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
1467 end subroutine rmhd_get_a2max
1470 subroutine rmhd_get_tcutoff(ixI^L,ixO^L,w,x,Tco_local,Tmax_local)
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
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)
1489 call rmhd_get_temperature_from_te(w,x,ixi^
l,ixi^
l,te)
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_))
1495 tmax_local=maxval(te(ixo^s))
1505 lts(ixo^s)=0.5d0*abs(te(jxo^s)-te(hxo^s))/te(ixo^s)
1507 where(lts(ixo^s) > trac_delta)
1510 if(any(lrlt(ixo^s)))
then
1511 tco_local=maxval(te(ixo^s), mask=lrlt(ixo^s))
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
1527 call mpistop(
"rmhd_trac_type not allowed for 1D simulation")
1539 gradt(ixo^s,idims)=tmp1(ixo^s)
1543 bunitvec(ixo^s,:)=w(ixo^s,iw_mag(:))+
block%B0(ixo^s,:,0)
1545 bunitvec(ixo^s,:)=w(ixo^s,iw_mag(:))
1551 ixb^
d=(ixomin^
d+ixomax^
d-1)/2+ixa^
d;
1554 if(sum(bdir(:)**2) .gt. zero)
then
1555 bdir(1:ndim)=bdir(1:ndim)/dsqrt(sum(bdir(:)**2))
1557 block%special_values(3:ndim+2)=bdir(1:ndim)
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)
1563 tmp1(ixo^s)=bigdouble
1567 bunitvec(ixo^s,idims)=bunitvec(ixo^s,idims)*tmp1(ixo^s)
1570 lts(ixo^s)=abs(sum(gradt(ixo^s,1:ndim)*bunitvec(ixo^s,1:ndim),dim=ndim+1))/te(ixo^s)
1572 if(slab_uniform)
then
1573 lts(ixo^s)=minval(dxlevel)*lts(ixo^s)
1575 lts(ixo^s)=minval(block%ds(ixo^s,:),dim=ndim+1)*lts(ixo^s)
1578 where(lts(ixo^s) > trac_delta)
1581 if(any(lrlt(ixo^s)))
then
1582 block%special_values(1)=maxval(te(ixo^s), mask=lrlt(ixo^s))
1584 block%special_values(1)=zero
1586 block%special_values(2)=tmax_local
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.)
1610 {
do ix^db=ixpmin^db,ixpmax^db\}
1612 ^
c&bunitvec(ix^d,^
c)=w(ix^d,iw_mag(^
c))+block%B0(ix^d,^
c,0)\
1614 ^
c&bunitvec(ix^d,^
c)=w(ix^d,iw_mag(^
c))\
1616 tmp1(ix^d)=1.d0/(dsqrt(^
c&bunitvec(ix^d,^
c)**2+)+smalldouble)
1618 ^d&bunitvec({ix^d},^d)=bunitvec({ix^d},^d)*tmp1({ix^d})\
1620 lts(ix^d)=abs(^d&gradt({ix^d},^d)*bunitvec({ix^d},^d)+)/te(ix^d)
1622 if(slab_uniform)
then
1623 lts(ix^d)=min(^d&dxlevel(^d))*lts(ix^d)
1625 lts(ix^d)=min(^d&block%ds({ix^d},^d))*lts(ix^d)
1627 lts(ix^d)=max(one,(exp(lts(ix^d))/ltrc)**ltrp)
1632 hxo^l=ixp^l-kr(idims,^d);
1633 jxo^l=ixp^l+kr(idims,^d);
1635 altr(ixp^s)=0.25d0*(lts(hxo^s)+two*lts(ixp^s)+lts(jxo^s))*bunitvec(ixp^s,idims)**2
1637 altr(ixp^s)=altr(ixp^s)+0.25d0*(lts(hxo^s)+two*lts(ixp^s)+lts(jxo^s))*bunitvec(ixp^s,idims)**2
1640 block%wextra(ixp^s,
tcoff_)=te(ixp^s)*altr(ixp^s)**0.4d0
1644 call mpistop(
"unknown rmhd_trac_type")
1647 end subroutine rmhd_get_tcutoff
1650 subroutine rmhd_get_h_speed(wprim,x,ixI^L,ixO^L,idim,Hspeed)
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)
1658 double precision :: csound(ixi^s,
ndim)
1659 double precision,
allocatable :: tmp(:^
d&)
1660 integer :: jxc^
l, ixc^
l, ixa^
l, id, ix^
d
1664 allocate(tmp(ixa^s))
1666 call rmhd_get_csound_prim(wprim,x,ixi^
l,ixa^
l,id,tmp)
1667 csound(ixa^s,id)=tmp(ixa^s)
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))
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)))
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)))
1696 end subroutine rmhd_get_h_speed
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)
1709 double precision :: wmean(ixi^s,nw), csoundl(ixo^s), csoundr(ixo^s)
1710 double precision :: umean, dmean, tmp1, tmp2, tmp3
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
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))
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
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)
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))
1762 cmax(ixo^s,1)=abs(wmean(ixo^s,
mom(idim)))+csoundr(ixo^s)
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)
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))
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)
1787 end subroutine rmhd_get_cbounds
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
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\}
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
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))
1827 {
do ix^db=ixomin^db,ixomax^db\}
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
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)
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))
1852 cmax(ixo^s,1)=abs(wmean(ixo^s,
mom(idim)))+csoundr(ixo^s)
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)
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))
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)
1877 end subroutine rmhd_get_cbounds_split_rho
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
1893 if(.not.
allocated(vcts%vnorm))
allocate(vcts%vnorm(ixi^s,1:
ndim))
1895 vcts%vnorm(ixo^s,idim)=0.5d0*(wlp(ixo^s,
mom(idim))+wrp(ixo^s,
mom(idim)))
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))
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)
1906 vcts%cbarmax(ixo^s,idim)=max( cmax(ixo^s),zero)
1907 vcts%cbarmin(ixo^s,idim)=vcts%cbarmax(ixo^s,idim)
1910 idimn=mod(idim,
ndir)+1
1911 idime=mod(idim+1,
ndir)+1
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))
1924 call mpistop(
'choose average, uct_contact,or uct_hll for type_ct!')
1926 end subroutine rmhd_get_ct_velocity
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)
1941 if(radio_acoustic_filter)
then
1942 call rmhd_radio_acoustic_filter(x, ixi^
l, ixo^
l, prad_max)
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,:,:))
1950 csound(ix^
d)=max(
rmhd_gamma,4.d0/3.d0)*(w(ix^
d,
p_)+prad_max(ix^
d))*inv_rho
1955 cfast2=b2*inv_rho+csound(ix^
d)
1956 avmincs2=cfast2**2-4.0d0*csound(ix^
d)*(w(ix^
d,mag(idim))+&
1958 if(avmincs2<zero) avmincs2=zero
1959 csound(ix^
d)=sqrt(half*(cfast2+sqrt(avmincs2)))
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,:,:))
1966 csound(ix^d)=max(
rmhd_gamma,4.d0/3.d0)*(w(ix^d,
p_)+prad_max(ix^d))*inv_rho
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)))
1977 end subroutine rmhd_get_csound_prim
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)
1992 if (radio_acoustic_filter)
then
1993 call rmhd_radio_acoustic_filter(x, ixi^
l, ixo^
l, prad_max)
1998 {
do ix^db=ixomin^db,ixomax^db \}
2001 prad_max(ix^
d) = maxval(prad_tensor(ix^
d,:,:))
2006 cfast2=b2*inv_rho+csound(ix^
d)
2007 avmincs2=cfast2**2-4.0d0*csound(ix^
d)*(w(ix^
d,mag(idim))+&
2009 if(avmincs2<zero) avmincs2=zero
2010 csound(ix^
d)=sqrt(half*(cfast2+sqrt(avmincs2)))
2013 {
do ix^db=ixomin^db,ixomax^db \}
2016 prad_max(ix^d) = maxval(prad_tensor(ix^d,:,:))
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
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)))
2027 end subroutine rmhd_get_csound_prim_split
2030 subroutine rmhd_get_pthermal_origin(w,x,ixI^L,ixO^L,pth)
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)
2041 {
do ix^db=ixomin^db,ixomax^db\}
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+)))
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
2061 write(*,*) trim(cons_wnames(iw)),
": ",w(ix^d,iw)
2064 if(trace_small_values)
write(*,*) sqrt(pth(ix^d)-bigdouble)
2065 write(*,*)
"Saving status at the previous time step"
2070 end subroutine rmhd_get_pthermal_origin
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
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)
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
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)
2104 call rmhd_get_rfactor(w,x,ixi^
l,ixo^
l,r)
2106 res(ixo^s)=res(ixo^s)/(r(ixo^s)*w(ixo^s,
rho_))
2107 end subroutine rmhd_get_temperature_from_etot
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)
2117 call rmhd_get_rfactor(w,x,ixi^
l,ixo^
l,r)
2120 end subroutine rmhd_get_temperature_from_etot_with_equi
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)
2130 call rmhd_get_rfactor(w,x,ixi^
l,ixo^
l,r)
2133 end subroutine rmhd_get_temperature_from_eint_with_equi
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)
2143 call rmhd_get_rfactor(w,x,ixi^
l,ixo^
l,r)
2145 end subroutine rmhd_get_temperature_equi
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)
2154 end subroutine rmhd_get_rho_equi
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)
2163 end subroutine rmhd_get_pe_equi
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)
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
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)
2193 call mpistop(
'Radiation formalism unknown')
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)
2211 {
do ix^
d = ixomin^
d,ixomax^
d\}
2212 prad_max(ix^
d) = maxval(prad_tensor(ix^
d,:,:))
2215 if (radio_acoustic_filter)
then
2216 call rmhd_radio_acoustic_filter(x, ixi^
l, ixo^
l, prad_max)
2218 pth_plus_prad(ixo^s) = pth(ixo^s) + prad_max(ixo^s)
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
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")
2233 tmp_prad(ixi^s) = zero
2234 tmp_prad(ixo^s) = prad_max(ixo^s)
2235 do filter = 1,size_ra_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)))
2244 end subroutine rmhd_radio_acoustic_filter
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)
2256 tgas(ixi^s) = pth(ixi^s)/w(ixi^s,
rho_)
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)
2274 subroutine rmhd_get_flux(wC,w,x,ixI^L,ixO^L,idim,f)
2278 integer,
intent(in) :: ixi^
l, ixo^
l, idim
2280 double precision,
intent(in) :: wc(ixi^s,nw)
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
2289 {
do ix^db=ixomin^db,ixomax^db\}
2294 ptotal=w(ix^
d,
p_)+half*(^
c&w(ix^
d,
b^
c_)**2+)
2296 f(ix^
d,
mom(idim))=f(ix^
d,
mom(idim))+ptotal
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_)+)
2305 {
do ix^db=ixomin^db,ixomax^db\}
2306 f(ix^d,mag(idim))=w(ix^d,
psi_)
2308 f(ix^d,
psi_)=cmax_global**2*w(ix^d,mag(idim))
2312 {
do ix^db=ixomin^db,ixomax^db\}
2313 f(ix^d,
r_e)=w(ix^d,
mom(idim))*wc(ix^d,
r_e)
2320 {
do ix^db=ixomin^db,ixomax^db\}
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)
2330 end subroutine rmhd_get_flux
2333 subroutine rmhd_get_flux_split(wC,w,x,ixI^L,ixO^L,idim,f)
2336 integer,
intent(in) :: ixi^
l, ixo^
l, idim
2338 double precision,
intent(in) :: wc(ixi^s,nw)
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)
2347 {
do ix^db=ixomin^db,ixomax^db\}
2355 ptotal=w(ix^
d,
p_)+half*(^
c&w(ix^
d,
b^
c_)**2+)
2364 ptotal=ptotal+(^
c&w(ix^
d,
b^
c_)*
block%B0(ix^
d,^
c,idim)+)
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
2371 ^
c&btotal(ix^
d,^
c)=w(ix^
d,
b^
c_)\
2375 f(ix^
d,
mom(idim))=f(ix^
d,
mom(idim))+ptotal
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_)\
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_)+)
2387 {
do ix^db=ixomin^db,ixomax^db\}
2388 f(ix^d,mag(idim))=w(ix^d,
psi_)
2390 f(ix^d,
psi_) = cmax_global**2*w(ix^d,mag(idim))
2394 {
do ix^db=ixomin^db,ixomax^db\}
2395 f(ix^d,
r_e)=w(ix^d,
mom(idim))*wc(ix^d,
r_e)
2402 {
do ix^db=ixomin^db,ixomax^db\}
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)
2412 end subroutine rmhd_get_flux_split
2416 subroutine get_flux_on_cell_face(ixI^L,ixO^L,ff,src)
2419 integer,
intent(in) :: ixi^
l, ixo^
l
2420 double precision,
dimension(:^D&,:),
intent(inout) :: ff
2421 double precision,
intent(out) :: src(ixi^s)
2423 double precision :: ffc(ixi^s,1:
ndim)
2424 double precision :: dxinv(
ndim)
2425 integer :: idims, ix^
d, ixa^
l, ixb^
l, ixc^
l
2431 ixcmax^
d=ixomax^
d; ixcmin^
d=ixomin^
d-1;
2433 ixbmin^
d=ixcmin^
d+ix^
d;
2434 ixbmax^
d=ixcmax^
d+ix^
d;
2437 ffc(ixc^s,1:ndim)=0.5d0**ndim*ffc(ixc^s,1:ndim)
2439 ff(ixi^s,1:ndim)=0.d0
2441 ixb^l=ixo^l-kr(idims,^d);
2442 ixcmax^d=ixomax^d; ixcmin^d=ixbmin^d;
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)
2450 ff(ixc^s,idims)=ff(ixc^s,idims)*0.5d0**(ndim-1)
2453 if(slab_uniform)
then
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)
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)
2465 src(ixo^s)=src(ixo^s)/block%dvolume(ixo^s)
2467 end subroutine get_flux_on_cell_face
2470 subroutine rmhd_add_source(qdt,dtfactor,ixI^L,ixO^L,wCT,wCTprim,w,x,qsourcesplit,active)
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
2487 if (.not. qsourcesplit)
then
2490 call add_pe0_divv(qdt,dtfactor,ixi^
l,ixo^
l,wctprim,w,x)
2493 call add_hypertc_source(qdt,ixi^
l,ixo^
l,wct,w,x,wctprim)
2498 call add_source_b0split(qdt,dtfactor,ixi^
l,ixo^
l,wctprim,w,x)
2503 call add_source_res2(qdt,ixi^
l,ixo^
l,wct,w,x)
2507 call add_source_hyperres(qdt,ixi^
l,ixo^
l,wct,w,x)
2513 select case (type_divb)
2518 call add_source_linde(qdt,ixi^
l,ixo^
l,wct,w,x)
2521 call add_source_glm(qdt,ixi^
l,ixo^
l,wct,w,x)
2524 call add_source_powel(qdt,ixi^
l,ixo^
l,wctprim,w,x)
2525 case (divb_janhunen)
2527 call add_source_janhunen(qdt,ixi^
l,ixo^
l,wctprim,w,x)
2528 case (divb_lindejanhunen)
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)
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)
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)
2545 call mpistop(
'Unknown divB fix')
2555 w,x,gravity_energy,gravity_rhov,qsourcesplit,active)
2561 call rmhd_add_radiation_source(qdt,ixi^
l,ixo^
l,wct,w,x,qsourcesplit,active)
2564 if(.not.qsourcesplit)
then
2566 call rmhd_update_temperature(ixi^
l,ixo^
l,wct,w,x)
2569 end subroutine rmhd_add_source
2571 subroutine rmhd_add_radiation_source(qdt,ixI^L,ixO^L,wCT,w,x,qsourcesplit,active)
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)
2590 call rmhd_handle_small_values(.true., w, x, ixi^
l, ixo^
l,
'fld_e_interact')
2595 call rmhd_handle_small_values(.true., w, x, ixi^
l, ixo^
l,
'fld_e_interact')
2601 call mpistop(
'Radiation formalism unknown')
2603 end subroutine rmhd_add_radiation_source
2605 subroutine add_pe0_divv(qdt,dtfactor,ixI^L,ixO^L,wCT,w,x)
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)
2628 end subroutine add_pe0_divv
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
2645 sigt7(ixo^s)=sigt5(ixo^s)*
block%wextra(ixo^s,
tcoff_)
2648 sigt7(ixo^s)=sigt5(ixo^s)*te(ixo^s)
2652 sigt7(ixo^s)=sigt5(ixo^s)*te(ixo^s)
2655 tau(ixo^s)=max(taumin*
dt,sigt7(ixo^s)/eint(ixo^s)/
cmax_global**2)
2656 end subroutine get_tau
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
2670 integer :: hxc^
l,hxo^
l,ixc^
l,jxc^
l,jxo^
l,kxc^
l
2672 call rmhd_get_rfactor(wctprim,x,ixi^
l,ixi^
l,r)
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)
2679 btot(ixo^s,idims)=wct(ixo^s,mag(idims))+
block%B0(ixo^s,idims,0)
2681 btot(ixo^s,idims)=wct(ixo^s,mag(idims))
2684 bsum(ixo^s)=sqrt(sum(btot(ixo^s,:)**2,dim=
ndim+1))+smalldouble
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
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
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)
2709 double precision :: current(ixi^s,7-2*
ndir:3)
2710 integer :: idir, idirmin
2715 b(ixo^s, idir) = w(ixo^s,mag(idir))+
block%B0(ixo^s,idir,0)
2719 b(ixo^s, idir) = w(ixo^s,mag(idir))
2726 a(ixo^s,idir)=current(ixo^s,idir)
2729 end subroutine get_lorentz_force
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)
2744 rho(ixo^s) = w(ixo^s,
rho_)
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
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)
2758 call rmhd_gamma2_alfven(ixi^
l, ixo^
l, w, gamma_a)
2759 gamma_a = sqrt(gamma_a)
2760 end function rmhd_gamma_alfven
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)
2771 rho(ixo^s) = w(ixo^s,
rho_)
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)
2785 logical :: flag(ixi^s,1:nw)
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.
2792 where(w(ixo^s,ie)<small_e) flag(ixo^s,ie)=.true.
2794 if(any(flag(ixo^s,ie)))
then
2798 where(flag(ixo^s,ie)) w(ixo^s,ie)=small_e - &
2801 where(flag(ixo^s,ie)) w(ixo^s,ie)=small_e
2807 w(ixo^s,
e_)=w(ixo^s,
e_)*gamma_1
2810 w(ixo^s,
mom(idir)) = w(ixo^s,
mom(idir))/rho(ixo^s)
2815 end subroutine rmhd_handle_small_ei
2817 subroutine rmhd_update_temperature(ixI^L,ixO^L,wCT,w,x)
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)
2825 double precision :: iz_h(ixo^s),iz_he(ixo^s), pth(ixi^s)
2833 end subroutine rmhd_update_temperature
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)
2852 a(ixo^s,idir)=
block%J0(ixo^s,idir)
2857 axb(ixo^s,idir)=axb(ixo^s,idir)*
block%dt(ixo^s)*dtfactor
2860 axb(ixo^s,:)=axb(ixo^s,:)*qdt
2865 if(total_energy)
then
2868 b(ixo^s,:)=wct(ixo^s,mag(:))
2877 axb(ixo^s,idir)=axb(ixo^s,idir)*
block%dt(ixo^s)*dtfactor
2880 axb(ixo^s,:)=axb(ixo^s,:)*qdt
2884 w(ixo^s,
e_)=w(ixo^s,
e_)-axb(ixo^s,idir)*
block%J0(ixo^s,idir)
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
2894 subroutine add_source_res1(qdt,ixI^L,ixO^L,wCT,w,x)
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)
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)
2915 if (iximin^
d>ixamin^
d.or.iximax^
d<ixamax^
d|.or.) &
2916 call mpistop(
"Error in add_source_res1: Non-conforming input limits")
2921 gradeta(ixo^s,1:
ndim)=zero
2927 gradeta(ixo^s,idim)=tmp(ixo^s)
2933 bf(ixi^s,1:
ndir)=wct(ixi^s,mag(1:
ndir))
2939 tmp2(ixi^s)=bf(ixi^s,idir)
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)) &
2951 tmp2(ixi^s)=bf(ixi^s,idir)
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
2960 tmp(ixo^s)=tmp(ixo^s)*eta(ixo^s)
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)
2968 tmp(ixo^s)=tmp(ixo^s)+gradeta(ixo^s,jdir)*current(ixo^s,kdir)
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)
2981 w(ixo^s,
e_)=w(ixo^s,
e_)+qdt*eta(ixo^s)*sum(current(ixo^s,:)**2,dim=ndim+1)
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
2988 subroutine add_source_res2(qdt,ixI^L,ixO^L,wCT,w,x)
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)
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
3002 if (iximin^
d>ixamin^
d.or.iximax^
d<ixamax^
d|.or.) &
3003 call mpistop(
"Error in add_source_res2: Non-conforming input limits")
3011 tmpvec(ixa^s,idir)=current(ixa^s,idir)*
rmhd_eta
3016 tmpvec(ixa^s,idir)=current(ixa^s,idir)*eta(ixa^s)
3024 w(ixo^s,mag(
ndir)) = w(ixo^s,mag(
ndir))-qdt*curlj(ixo^s,
ndir)
3027 w(ixo^s,mag(1:
ndir)) = w(ixo^s,mag(1:
ndir))-qdt*curlj(ixo^s,1:
ndir)
3031 tmp(ixo^s)=qdt*
rmhd_eta*sum(current(ixo^s,:)**2,dim=
ndim+1)
3033 tmp(ixo^s)=qdt*eta(ixo^s)*sum(current(ixo^s,:)**2,dim=
ndim+1)
3035 if(total_energy)
then
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)
3042 w(ixo^s,
e_)=w(ixo^s,
e_)+tmp(ixo^s)
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
3050 subroutine add_source_hyperres(qdt,ixI^L,ixO^L,wCT,w,x)
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)
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
3063 if (iximin^
d>ixamin^
d.or.iximax^
d<ixamax^
d|.or.) &
3064 call mpistop(
"Error in add_source_hyperres: Non-conforming input limits")
3066 tmpvec(ixa^s,1:
ndir)=zero
3068 tmpvec(ixa^s,jdir)=current(ixa^s,jdir)
3071 call curlvector(tmpvec,ixi^
l,ixa^
l,tmpvec2,idirmin1,1,3)
3073 tmpvec(ixa^s,1:
ndir)=zero
3074 call curlvector(tmpvec2,ixi^
l,ixa^
l,tmpvec,idirmin1,1,3)
3077 tmpvec2(ixa^s,1:
ndir)=zero
3078 call curlvector(ehyper,ixi^
l,ixa^
l,tmpvec2,idirmin1,1,3)
3080 w(ixo^s,mag(idir)) = w(ixo^s,mag(idir))-tmpvec2(ixo^s,idir)*qdt
3082 if(total_energy)
then
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
3091 call divvector(tmpvec2,ixi^l,ixo^l,tmp)
3092 w(ixo^s,
e_)=w(ixo^s,
e_)+tmp(ixo^s)*qdt
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
3097 subroutine add_source_glm(qdt,ixI^L,ixO^L,wCT,w,x)
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)
3125 ba(ixo^s,1:
ndir)=wct(ixo^s,mag(1:
ndir))
3128 if(total_energy)
then
3137 w(ixo^s,
e_) = w(ixo^s,
e_)-qdt*ba(ixo^s,idir)*gradpsi(ixo^s)
3144 w(ixo^s,
mom(idir))=w(ixo^s,
mom(idir))-qdt*ba(ixo^s,idir)*divb(ixo^s)
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
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
3162 {
do ix^db=ixomin^db,ixomax^db\}
3167 if (total_energy)
then
3173 {
do ix^db=ixomin^db,ixomax^db\}
3175 ^
c&w(ix^d,
b^
c_)=w(ix^d,
b^
c_)-qdt*wct(ix^d,
m^
c_)*divb(ix^d)\
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
3180 w(ix^d,
e_)=w(ix^d,
e_)-qdt*(^
c&wct(ix^d,
m^
c_)*wct(ix^d,
b^
c_)+)*divb(ix^d)
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
3187 subroutine add_source_janhunen(qdt,ixI^L,ixO^L,wCT,w,x)
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
3199 {
do ix^db=ixomin^db,ixomax^db\}
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
3206 subroutine add_source_linde(qdt,ixI^L,ixO^L,wCT,w,x)
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
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.
3226 leveljump(i^
d)=.false.
3234 i^dd=kr(^dd,^d)*(2*iside-3);
3235 if (leveljump(i^dd))
then
3237 ixpmin^d=ixomin^d-i^d
3239 ixpmax^d=ixomax^d-i^d
3249 select case(typegrad)
3251 call gradient(divb,ixi^l,ixp^l,idim,graddivb)
3253 call gradientl(divb,ixi^l,ixp^l,idim,graddivb)
3256 if (slab_uniform)
then
3257 graddivb(ixp^s)=graddivb(ixp^s)*divbdiff/(^d&1.0d0/dxlevel(^d)**2+)
3259 graddivb(ixp^s)=graddivb(ixp^s)*divbdiff &
3260 /(^d&1.0d0/block%ds(ixp^s,^d)**2+)
3262 w(ixp^s,mag(idim))=w(ixp^s,mag(idim))+graddivb(ixp^s)
3264 if (typedivbdiff==
'all' .and. total_energy)
then
3266 w(ixp^s,
e_)=w(ixp^s,
e_)+wct(ixp^s,mag(idim))*graddivb(ixp^s)
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
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
3281 call get_divb(w,ixi^
l,ixo^
l,divb)
3283 where(invb(ixo^s)/=0.d0)
3284 invb(ixo^s)=1.d0/invb(ixo^s)
3287 divb(ixo^s)=0.5d0*abs(divb(ixo^s))*invb(ixo^s)/sum(1.d0/
dxlevel(:))
3289 ixamin^
d=ixomin^
d-1;
3290 ixamax^
d=ixomax^
d-1;
3291 dsurface(ixo^s)= sum(
block%surfaceC(ixo^s,:),dim=
ndim+1)
3293 ixa^
l=ixo^
l-
kr(idims,^
d);
3294 dsurface(ixo^s)=dsurface(ixo^s)+
block%surfaceC(ixa^s,idims)
3296 divb(ixo^s)=abs(divb(ixo^s))*invb(ixo^s)*&
3297 block%dvolume(ixo^s)/dsurface(ixo^s)
3306 integer,
intent(in) :: ixo^
l, ixi^
l
3307 double precision,
intent(in) :: w(ixi^s,1:nw)
3308 integer,
intent(out) :: idirmin
3310 double precision :: current(ixi^s,7-2*
ndir:3)
3311 integer :: idir, idirmin0
3315 if(
b0field) current(ixo^s,idirmin0:3)=current(ixo^s,idirmin0:3)+&
3316 block%J0(ixo^s,idirmin0:3)
3320 subroutine rmhd_get_dt(w,ixI^L,ixO^L,dtnew,dx^D,x)
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
3339 if (.not. dt_c)
then
3350 dtdiffpar/(smalldouble+maxval(eta(ixo^s)/dxarr(idim)**2)))
3353 dtdiffpar/(smalldouble+maxval(eta(ixo^s)/
block%ds(ixo^s,idim)**2)))
3371 call mpistop(
'Radiation formalism unknown')
3387 end subroutine rmhd_get_dt
3390 subroutine rmhd_add_source_geom(qdt,dtfactor,ixI^L,ixO^L,wCT,wprim,w,x)
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
3398 integer :: mr_,mphi_
3399 integer :: br_,bphi_
3402 br_=mag(1); bphi_=mag(1)-1+
phi_
3405 {
do ix^db=ixomin^db,ixomax^db\}
3408 invr=
block%dt(ix^
d) * dtfactor/x(ix^
d,1)
3413 tmp=wprim(ix^
d,
p_)+half*(^
c&wprim(ix^
d,
b^
c_)**2+)
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_))
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_))
3429 w(ix^
d,mr_)=w(ix^
d,mr_)+invr*tmp
3434 {
do ix^db=ixomin^db,ixomax^db\}
3436 if(local_timestep)
then
3437 invr=block%dt(ix^d) * dtfactor/x(ix^d,1)
3442 tmp1=wprim(ix^d,
p_)+half*(^
c&wprim(ix^d,
b^
c_)**2+)
3448 w(ix^d,
mom(1))=w(ix^d,
mom(1))+two*tmp1*invr
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+))
3456 w(ix^d,mag(1))=w(ix^d,mag(1))+invr*2.0d0*wprim(ix^d,
psi_)
3462 cot=1.d0/tan(x(ix^d,2))
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_))
3469 if(.not.stagger_grid)
then
3470 tmp=wprim(ix^d,m1_)*wprim(ix^d,b2_)-wprim(ix^d,m2_)*wprim(ix^d,b1_)
3472 tmp=tmp+wprim(ix^d,
psi_)*cot
3474 w(ix^d,mag(2))=w(ix^d,mag(2))+tmp*invr
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)
3483 if(.not.stagger_grid)
then
3484 tmp=wprim(ix^d,m1_)*wprim(ix^d,b2_)-wprim(ix^d,m2_)*wprim(ix^d,b1_)
3486 tmp=tmp+wprim(ix^d,
psi_)*cot
3488 w(ix^d,mag(2))=w(ix^d,mag(2))+tmp*invr
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)
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)
3507 end subroutine rmhd_add_source_geom
3510 subroutine rmhd_add_source_geom_split(qdt,dtfactor, ixI^L,ixO^L,wCT,wprim,w,x)
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_
3519 integer :: br_,bphi_
3522 br_=mag(1); bphi_=mag(1)-1+
phi_
3526 invrho(ixo^s) = 1d0/wct(ixo^s,
rho_)
3530 invr(ixo^s) =
block%dt(ixo^s) * dtfactor/x(ixo^s,1)
3532 invr(ixo^s) = qdt/x(ixo^s,1)
3537 call rmhd_get_p_total(wct,x,ixi^
l,ixo^
l,tmp)
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_))
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_)) &
3551 w(ixo^s,mr_)=w(ixo^s,mr_)+invr(ixo^s)*tmp(ixo^s)
3553 if(
rmhd_glm) w(ixo^s,br_)=w(ixo^s,br_)+wct(ixo^s,
psi_)*invr(ixo^s)
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)
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)
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)
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))
3571 w(ixo^s,
mom(1))=w(ixo^s,
mom(1))+tmp(ixo^s)*invr(ixo^s)
3574 w(ixo^s,mag(1))=w(ixo^s,mag(1))+invr(ixo^s)*2.0d0*wct(ixo^s,
psi_)
3578 tmp(ixo^s)=tmp1(ixo^s)
3580 tmp(ixo^s)=tmp(ixo^s)+tmp2(ixo^s)
3583 tmp1(ixo^s) =
block%dt(ixo^s) * tmp(ixo^s)
3585 tmp1(ixo^s) = qdt * tmp(ixo^s)
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)))
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)
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))
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))
3605 w(ixo^s,
mom(2))=w(ixo^s,
mom(2))+tmp(ixo^s)*invr(ixo^s)
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)
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)
3615 tmp(ixo^s)=tmp(ixo^s) &
3616 + dcos(x(ixo^s,2))/dsin(x(ixo^s,2))*wct(ixo^s,
psi_)
3618 w(ixo^s,mag(2))=w(ixo^s,mag(2))+tmp(ixo^s)*invr(ixo^s)
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)) }
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)) }
3635 w(ixo^s,
mom(3))=w(ixo^s,
mom(3))+tmp(ixo^s)*invr(ixo^s)
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)) }
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)) }
3650 w(ixo^s,mag(3))=w(ixo^s,mag(3))+tmp(ixo^s)*invr(ixo^s)
3654 end subroutine rmhd_add_source_geom_split
3659 integer,
intent(in) :: ixi^
l, ixo^
l
3660 double precision,
intent(in) :: w(ixi^s, nw)
3661 double precision :: mge(ixo^s)
3664 mge = sum((w(ixo^s, mag(:))+
block%B0(ixo^s,:,
b0i))**2, dim=
ndim+1)
3666 mge = sum(w(ixo^s, mag(:))**2, dim=
ndim+1)
3670 subroutine rmhd_modify_wlr(ixI^L,ixO^L,qt,wLC,wRC,wLp,wRp,s,idir)
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)
3678 double precision :: db(ixo^s), dpsi(ixo^s)
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)
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))
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
3706 wrc(ix^d,mag(idir))=wlp(ix^d,mag(idir))
3708 wlc(ix^d,mag(idir))=wlp(ix^d,mag(idir))
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
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
3720 subroutine rmhd_boundary_adjust(igrid,psb)
3722 integer,
intent(in) :: igrid
3724 integer :: ib, idims, iside, ixo^
l, i^
d
3733 i^
d=
kr(^
d,idims)*(2*iside-3);
3734 if (neighbor_type(i^
d,igrid)/=1) cycle
3735 ib=(idims-1)*2+iside
3753 call fixdivb_boundary(ixg^
ll,ixo^
l,psb(igrid)%w,psb(igrid)%x,ib)
3757 end subroutine rmhd_boundary_adjust
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
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)))
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))
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)))
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))
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)))
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))
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)))
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))
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)))
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))
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)))
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))
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)))
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))
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)))
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))
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)))
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))
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)))
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))
4128 call mpistop(
"Special boundary is not defined for this region")
4130 end subroutine fixdivb_boundary
4138 double precision,
intent(in) :: qdt
4139 double precision,
intent(in) :: qt
4140 logical,
intent(inout) :: active
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 = 1
d-3
4147 double precision,
parameter :: residual_reduction = 1
d-10
4148 integer :: iigrid, igrid
4149 integer :: n, nc, lvl, ix^
l, ixc^
l, idim
4152 mg%operator_type = mg_laplacian
4159 mg%bc(n, mg_iphi)%bc_type = mg_bc_dirichlet
4160 mg%bc(n, mg_iphi)%bc_value = 0.0_dp
4163 mg%bc(n, mg_iphi)%bc_type = mg_bc_neumann
4164 mg%bc(n, mg_iphi)%bc_value = 0.0_dp
4166 mg%bc(n, mg_iphi)%bc_type = mg_bc_dirichlet
4167 mg%bc(n, mg_iphi)%bc_value = 0.0_dp
4170 mg%bc(n, mg_iphi)%bc_type = mg_bc_dirichlet
4171 mg%bc(n, mg_iphi)%bc_value = 0.0_dp
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
4184 do iigrid = 1, igridstail
4185 igrid = igrids(iigrid);
4188 lvl =
mg%boxes(id)%lvl
4189 nc =
mg%box_size_lvl(lvl)
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))))
4203 call mpi_allreduce(mpi_in_place, max_divb, 1, mpi_double_precision, &
4206 if (
mype == 0) print *,
"Performing multigrid divB cleaning"
4207 if (
mype == 0) print *,
"iteration vs residual"
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
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"
4225 call mg_fas_vcycle(
mg, max_res=res)
4226 if (res < max_residual)
exit
4228 if (res > max_residual)
call mpistop(
"divb_multigrid: no convergence")
4232 do iigrid = 1, igridstail
4233 igrid = igrids(iigrid);
4240 tmp(ix^s) =
mg%boxes(id)%cc({:,}, mg_iphi)
4243 ixcmin^
d=ixmlo^
d-
kr(idim,^
d);
4245 call gradientf(tmp,ps(igrid)%x,ixg^
ll,ixc^
l,idim,grad(ixg^t,idim))
4247 ps(igrid)%ws(ixc^s,idim)=ps(igrid)%ws(ixc^s,idim)-grad(ixc^s,idim)
4260 ps(igrid)%w(
ixm^t, mag(1:
ndim)) = &
4261 ps(igrid)%w(
ixm^t, mag(1:
ndim)) - grad(
ixm^t, :)
4263 if(total_energy)
then
4265 tmp(
ixm^t) = 0.5_dp * (sum(ps(igrid)%w(
ixm^t, &
4268 ps(igrid)%w(
ixm^t,
e_) = ps(igrid)%w(
ixm^t,
e_) + tmp(
ixm^t)
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
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)
4288 call update_faces_average(ixi^
l,ixo^
l,qt,qdt,fc,fe,sct,s)
4290 call update_faces_contact(ixi^
l,ixo^
l,qt,qdt,wprim,fc,fe,sct,s,vcts)
4292 call update_faces_hll(ixi^
l,ixo^
l,qt,qdt,fe,sct,s,vcts)
4294 call mpistop(
'choose average, uct_contact,or uct_hll for type_ct!')
4296 end subroutine rmhd_update_faces
4299 subroutine update_faces_average(ixI^L,ixO^L,qt,qdt,fC,fE,sCT,s)
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)
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
4313 associate(bfaces=>s%ws,x=>s%x)
4318 if(
rmhd_eta/=zero)
call get_resistive_electric_field(ixi^
l,ixo^
l,sct,s,e_resi)
4321 i1kr^
d=
kr(idim1,^
d);
4324 i2kr^
d=
kr(idim2,^
d);
4327 if (
lvc(idim1,idim2,idir)==1)
then
4329 ixcmin^
d=ixomin^
d+
kr(idir,^
d)-1;
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))
4336 if(
rmhd_eta/=zero) fe(ix^
d,idir)=fe(ix^
d,idir)+e_resi(ix^
d,idir)
4338 fe(ix^
d,idir)=fe(ix^
d,idir)*qdt*s%dsC(ix^
d,idir)
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
4351 ixcmin^d=ixomin^d-kr(idim1,^d);
4353 ixa^l=ixc^l-kr(idim2,^d);
4356 if(lvc(idim1,idim2,idir)==1)
then
4358 circ(ixc^s,idim1)=circ(ixc^s,idim1)&
4361 else if(lvc(idim1,idim2,idir)==-1)
then
4363 circ(ixc^s,idim1)=circ(ixc^s,idim1)&
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)
4373 circ(ixc^s,idim1)=zero
4376 bfaces(ixc^s,idim1)=bfaces(ixc^s,idim1)-circ(ixc^s,idim1)
4379 end subroutine update_faces_average
4382 subroutine update_faces_contact(ixI^L,ixO^L,qt,qdt,wp,fC,fE,sCT,s,vcts)
4386 integer,
intent(in) :: ixi^
l, ixo^
l
4387 double precision,
intent(in) :: qt, qdt
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)
4396 double precision :: ecc(ixi^s,
sdim:3)
4397 double precision :: ein(ixi^s,
sdim:3)
4399 double precision :: el(ixi^s),er(ixi^s)
4401 double precision :: elc,erc
4403 double precision,
dimension(ixI^S,sdim:3) :: e_resi
4405 double precision :: jce(ixi^s,
sdim:3)
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
4412 associate(bfaces=>s%ws,x=>s%x,w=>s%w,vnorm=>vcts%vnorm,wcts=>sct%ws)
4414 if(
rmhd_eta/=zero)
call get_resistive_electric_field(ixi^
l,ixo^
l,sct,s,e_resi)
4416 {
do ix^db=iximin^db,iximax^db\}
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_)
4424 ecc(ix^
d,3)=wp(ix^
d,b1_)*wp(ix^
d,m2_)-wp(ix^
d,b2_)*wp(ix^
d,m1_)
4431 {
do ix^db=iximin^db,iximax^db\}
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_)
4439 ecc(ix^d,3)=wp(ix^d,b1_)*wp(ix^d,m2_)-wp(ix^d,b2_)*wp(ix^d,m1_)
4453 i1kr^d=kr(idim1,^d);
4456 i2kr^d=kr(idim2,^d);
4459 if (lvc(idim1,idim2,idir)==1)
then
4461 ixcmin^d=ixomin^d+kr(idir,^d)-1;
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))
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)
4478 do ix^db=ixcmin^db,ixcmax^db\}
4479 if(vnorm(ix^d,idim1)>0.d0)
then
4481 else if(vnorm(ix^d,idim1)<0.d0)
then
4482 elc=el({ix^d+i1kr^d})
4484 elc=0.5d0*(el(ix^d)+el({ix^d+i1kr^d}))
4486 if(vnorm({ix^d+i2kr^d},idim1)>0.d0)
then
4488 else if(vnorm({ix^d+i2kr^d},idim1)<0.d0)
then
4489 erc=er({ix^d+i1kr^d})
4491 erc=0.5d0*(er(ix^d)+er({ix^d+i1kr^d}))
4493 fe(ix^d,idir)=fe(ix^d,idir)+0.25d0*(elc+erc)
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)
4503 do ix^db=ixcmin^db,ixcmax^db\}
4504 if(vnorm(ix^d,idim2)>0.d0)
then
4506 else if(vnorm(ix^d,idim2)<0.d0)
then
4507 elc=el({ix^d+i2kr^d})
4509 elc=0.5d0*(el(ix^d)+el({ix^d+i2kr^d}))
4511 if(vnorm({ix^d+i1kr^d},idim2)>0.d0)
then
4513 else if(vnorm({ix^d+i1kr^d},idim2)<0.d0)
then
4514 erc=er({ix^d+i2kr^d})
4516 erc=0.5d0*(er(ix^d)+er({ix^d+i2kr^d}))
4518 fe(ix^d,idir)=fe(ix^d,idir)+0.25d0*(elc+erc)
4522 if(
rmhd_eta/=zero) fe(ix^d,idir)=fe(ix^d,idir)+e_resi(ix^d,idir)
4524 fe(ix^d,idir)=fe(ix^d,idir)*qdt*s%dsC(ix^d,idir)
4537 if (lvc(idim1,idim2,idir)==0) cycle
4539 ixcmin^d=ixomin^d+kr(idir,^d)-1;
4540 ixamax^d=ixcmax^d-kr(idir,^d)+1;
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)
4549 jce(ixc^s,idir)=jce(ixc^s,idir)-gradi(ixc^s)
4556 ixcmin^d=ixomin^d+kr(idir,^d)-1;
4558 ein(ixc^s,idir)=ein(ixc^s,idir)*jce(ixc^s,idir)
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)
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)
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)
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)
4595 block%w(ixo^s,nw)=block%w(ixo^s,nw)+jce(ixo^s,idir)
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
4606 ixcmin^d=ixomin^d-kr(idim1,^d);
4608 ixa^l=ixc^l-kr(idim2,^d);
4611 if(lvc(idim1,idim2,idir)==1)
then
4613 circ(ixc^s,idim1)=circ(ixc^s,idim1)&
4616 else if(lvc(idim1,idim2,idir)==-1)
then
4618 circ(ixc^s,idim1)=circ(ixc^s,idim1)&
4625 where(s%surfaceC(ixc^s,idim1) > smalldouble)
4626 circ(ixc^s,idim1)=circ(ixc^s,idim1)/s%surfaceC(ixc^s,idim1)
4628 circ(ixc^s,idim1)=zero
4631 bfaces(ixc^s,idim1)=bfaces(ixc^s,idim1)-circ(ixc^s,idim1)
4634 end subroutine update_faces_contact
4637 subroutine update_faces_hll(ixI^L,ixO^L,qt,qdt,fE,sCT,s,vcts)
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)
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
4659 associate(bfaces=>s%ws,bfacesct=>sct%ws,x=>s%x,vbarc=>vcts%vbarC,cbarmin=>vcts%cbarmin,&
4660 cbarmax=>vcts%cbarmax)
4672 if(
rmhd_eta/=zero)
call get_resistive_electric_field(ixi^
l,ixo^
l,sct,s,e_resi)
4684 ixcmin^
d=ixomin^
d-1+
kr(idir,^
d);
4687 idim2=mod(idir+1,3)+1
4688 jxc^
l=ixc^
l+
kr(idim1,^
d);
4689 ixcp^
l=ixc^
l+
kr(idim2,^
d);
4692 vtill(ixi^s,2),vtilr(ixi^s,2))
4694 vtill(ixi^s,1),vtilr(ixi^s,1))
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)
4702 bfacetot(ixi^s,idim1)=bfacesct(ixi^s,idim1)
4703 bfacetot(ixi^s,idim2)=bfacesct(ixi^s,idim2)
4706 btill(ixi^s,idim1),btilr(ixi^s,idim1))
4708 btill(ixi^s,idim2),btilr(ixi^s,idim2))
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))
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))
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)
4735 circ(ixi^s,1:
ndim)=zero
4739 ixcmin^
d=ixomin^
d-
kr(idim1,^
d);
4743 if(
lvc(idim1,idim2,idir)/=0)
then
4744 hxc^
l=ixc^
l-
kr(idim2,^
d);
4746 circ(ixc^s,idim1)=circ(ixc^s,idim1)&
4747 +
lvc(idim1,idim2,idir)&
4754 where(s%surfaceC(ixc^s,idim1) > 1.0
d-9*s%dvolume(ixc^s))
4755 circ(ixc^s,idim1)=circ(ixc^s,idim1)/s%surfaceC(ixc^s,idim1)
4757 circ(ixc^s,idim1)=zero
4760 bfaces(ixc^s,idim1)=bfaces(ixc^s,idim1)-circ(ixc^s,idim1)
4763 end subroutine update_faces_hll
4766 subroutine get_resistive_electric_field(ixI^L,ixO^L,sCT,s,jce)
4770 integer,
intent(in) :: ixi^
l, ixo^
l
4771 type(state),
intent(in) :: sct, s
4773 double precision :: jce(ixi^s,
sdim:3)
4775 double precision :: jcc(ixi^s,7-2*
ndir:3)
4777 double precision :: xs(ixgs^t,1:
ndim)
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
4783 associate(x=>s%x,
dx=>s%dx,w=>s%w,wct=>sct%w,wcts=>sct%ws)
4789 if (
lvc(idim1,idim2,idir)==0) cycle
4791 ixcmin^
d=ixomin^
d+
kr(idir,^
d)-1;
4792 ixbmax^
d=ixcmax^
d-
kr(idir,^
d)+1;
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)
4801 jce(ixc^s,idir)=jce(ixc^s,idir)-gradi(ixc^s)
4816 ixcmin^
d=ixomin^
d+
kr(idir,^
d)-1;
4817 jcc(ixc^s,idir)=0.d0
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)
4824 jcc(ixc^s,idir)=jcc(ixc^s,idir)*0.25d0
4825 jce(ixc^s,idir)=jce(ixc^s,idir)*jcc(ixc^s,idir)
4829 end subroutine get_resistive_electric_field
4835 integer,
intent(in) :: ixo^
l
4844 do ix^db=ixomin^db,ixomax^db\}
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))
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))
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)
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)
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
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)
4927 end subroutine rfactor_from_constant_ionization
Module for including anisotropic flux limited diffusion (AFLD)-approximation in Radiation-hydrodynami...
subroutine afld_get_diffcoef_central(w, wct, x, ixil, ixol)
Calculates cell-centered diffusion coefficient to be used in multigrid.
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...
subroutine, public afld_init(he_abundance, rhd_radiation_diffusion, afld_gamma)
Initialising FLD-module: Read opacities Initialise Multigrid adimensionalise kappa Add extra variable...
subroutine, public afld_radforce_get_dt(w, ixil, ixol, dtnew, dxd, x)
subroutine, public afld_get_radpress(w, x, ixil, ixol, rad_pressure, nth)
Calculate Radiation Pressure Returns Radiation Pressure as tensor.
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...
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)
Module for flux conservation near refinement boundaries.
Nicolas Moens Module for including flux limited diffusion (FLD)-approximation in Radiation-hydrodynam...
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...
subroutine, public fld_get_radpress(w, x, ixil, ixol, rad_pressure, nth)
Calculate Radiation Pressure Returns Radiation Pressure as tensor.
subroutine, public fld_init(he_abundance, radiation_diffusion, energy_interact, r_gamma)
Initialising FLD-module: Read opacities Initialise Multigrid adimensionalise kappa Add extra variable...
subroutine fld_get_diffcoef_central(w, wct, x, ixil, ixol)
Calculates cell-centered diffusion coefficient to be used in multigrid.
character(len=8) fld_diff_scheme
Which method to solve diffusion part.
subroutine, public fld_radforce_get_dt(w, ixil, ixol, dtnew, dxd, x)
Module with basic grid data structures.
type(tree_node_ptr), dimension(:,:), allocatable, save igrid_to_node
Array to go from an [igrid, ipe] index to a node pointer.
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)
subroutine divvector(qvec, ixil, ixol, divq, nth_in)
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
double precision small_pressure
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
integer, parameter bc_asymm
double precision unit_mass
Physical scaling factor for mass.
integer, dimension(3, 3) kr
Kronecker delta tensor.
double precision phys_trac_mask
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.
integer, parameter bc_cont
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
integer, parameter bc_symm
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)
double precision small_density
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 phys_trac_finegrid
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.
subroutine gravity_get_dt(w, ixil, ixol, dtnew, dxd, x)
subroutine gravity_init()
Initialize the module.
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
module ionization degree - get ionization degree for given temperature
subroutine ionization_degree_from_temperature(ixil, ixol, te, iz_h, iz_he)
subroutine ionization_degree_init()
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...
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.