!
! This module add solid (as in no-fluid) cells in the domain.
! This can be used e.g. in order to simulate a cylinder in a cross flow.
!
!** AUTOMATIC CPARAM.INC GENERATION ****************************
! Declare (for generation of cparam.inc) the number of f array
! variables and auxiliary variables added by this module
!
! CPARAM logical, parameter :: lsolid_cells = .true.
! CPARAM logical, parameter :: lsolid_ogrid = .true.
!
! MAUX CONTRIBUTION 0
!
!***************************************************************
!
! New solid cells module
! Overlapping cylindrical grid (O-grid) around cylinder or sphere,
! coupled to cartesian grid outside the o-grid by interpolation.
!
! Very fine resolution of boundary layer
!
module Solid_Cells
use Cdata
use General, only: keep_compiler_quiet
use Messages
use Solid_cells_ogrid_sub
use Solid_cells_ogrid_cdata
use Solid_cells_ogrid_chemistry
!
implicit none
!
include 'solid_cells.h'
!
interface get_polar_coords
module procedure get_polar_coords_2D
module procedure get_polar_coords_3D
module procedure get_polar_coords_3D_alt
endinterface
namelist /solid_cells_init_pars/ &
cylinder_temp, cylinder_radius, cylinder_xpos, ncylinders, &
cylinder_ypos, cylinder_zpos, flow_dir_set, skin_depth_solid, &
initsolid_cells, init_uu, r_ogrid, lset_flow_dir,ampl_noise, &
grid_func_ogrid, coeff_grid_o, xyz_star_ogrid, ltanh_rate, &
lcheck_interpolation, lcheck_init_interpolation, SBP, BDRY5, &
interpolation_method, lock_dt, lexpl_rho, SBP_reduced_to2, &
lshift_origin_ogrid,lshift_origin_lower_ogrid, interpol_filter, &
lrk_tvd, SBP_optimized, interp_shift, llin_BC, lnonegative_Yk, &
particle_interpolate, lparticle_uradonly, lsinus_spec_distr, &
interpol_order_poly, lfilter_solution, af, lspecial_rad_int, &
lfilter_rhoonly, lspecial_rad_int_mom, toler, reduce_timestep, &
init_rho_cyl, lfilter_TT, r_int_inner_vid, ldist_CO2, ldist_CO, &
TT_square_fit, Tgrad_stretch, filter_frequency, lreac_heter, &
solid_reactions_intro_time, tanh_a1, tanh_a2, scale_gas, &
scale_oxy, kinetics_heter
! Read run.in file
namelist /solid_cells_run_pars/ &
flow_dir_set, lset_flow_dir, interpolation_method, lcheck_interpolation, &
SBP, BDRY5, lrk_tvd, SBP_optimized, SBP_reduced_to2, lexpl_rho, &
particle_interpolate, lparticle_uradonly, lfilter_solution, lock_dt, af, &
lspecial_rad_int, lfilter_rhoonly, lspecial_rad_int_mom, &
solid_reactions_intro_time, toler,&
filter_frequency, lwrite_mdotc
interface dot2_ogrid
module procedure dot2_mn_ogrid
module procedure dot2_0_ogrid
endinterface
interface u_dot_grad_ogrid
module procedure u_dot_grad_scl_ogrid
module procedure u_dot_grad_vec_ogrid
endinterface
interface read_snap_ogrid
module procedure read_snap_double_ogrid
module procedure read_snap_single_ogrid
endinterface
!---------------------------------
!
! The two lines below can be included, together with the subroutine send_rcv_all_data
! for MPI-testing purposes. Exchanges all data between processors. Should not be used
! for other than testing, due to inefficiency.
!! real, dimension (mxgrid_ogrid, mygrid_ogrid, mzgrid_ogrid,mfarray_ogrid), save :: fgrid_ogrid=0.
!! real, dimension (mxgrid, mygrid, mzgrid,mfarray), save :: fgrid_cartesian=0.
!
!---------------------------------
!
real :: gamma, cp, cv, gamma1, gamma_m1
contains
!***********************************************************************
subroutine register_solid_cells
!
! Dummy routine
!
end subroutine register_solid_cells
!***********************************************************************
subroutine initialize_solid_cells(f)
!
! Define the geometry of the solids and construct the grid around the solid
! object.
! Currently only a single solid object with overlapping grid is implemented.
! Use solid_cells.f90 without overlapping grids if several solids inside the
! flow domain is desired.
!
! feb--apr-17/Jorgen: Coded
!
use Solid_Cells_Mpicomm, only: initialize_mpicomm_ogrid
use EquationOfState, only: lpres_grad, Pr_number, get_gamma_etc
! use Energy, only: lpres_grad
use SharedVariables, only: get_shared_variable
!
real, dimension(mx,my,mz,mfarray), intent(inout) :: f
integer :: i, ndims, k
!
call keep_compiler_quiet(f)
if (cylinder_radius <= 0) then
call fatal_error('initialize_solid_cells_ogrid', &
'All cylinders must have non-zero radii!')
endif
if (r_ogrid <= 0) r_ogrid=3.*cylinder_radius
!
if (r_int_inner_vid <= cylinder_radius) &
r_int_inner_vid = cylinder_radius+0.05*cylinder_radius
!
if (lroot) then
print*, 'nxgrid_ogrid, nygrid_ogrid, nzgrid_ogrid=', nxgrid_ogrid, nygrid_ogrid, nzgrid_ogrid
print*, 'Cylidner radius=',cylinder_radius
print*, 'Cylindrical grid radius=',r_ogrid
endif
! Interlap parameters of the ogrid
xyz0_ogrid(1)=cylinder_radius
xyz0_ogrid(2)=-pi
xyz0_ogrid(3)=xyz0(3)
Lxyz_ogrid(1)=r_ogrid-xyz0_ogrid(1)
Lxyz_ogrid(2)=2*pi
Lxyz_ogrid(3)=Lxyz(3)
! Position related to the flow domain and cartesian grid
xorigo_ogrid(1) = cylinder_xpos
xorigo_ogrid(2) = cylinder_ypos
xorigo_ogrid(3) = cylinder_zpos
call check_cyl_pos(xorigo_ogrid,xyz0,xyz1)
!
! Currently only implemented for single cylinder
!
if (ALWAYS_FALSE) print*, ncylinders
!
! Try to find flow direction
!
flow_dir = 0
if (fbcx(1,1) > 0) then; flow_dir = 1
elseif (fbcx(1,2) < 0) then; flow_dir = -1
elseif (fbcy(2,1) > 0) then; flow_dir = 2
elseif (fbcy(2,2) < 0) then; flow_dir = -2
elseif (fbcz(3,1) > 0) then; flow_dir = 3
elseif (fbcz(3,2) < 0) then; flow_dir = -3
endif
if (flow_dir /= 0) then
if (lroot) then
print*,'By using fbc[x,y,z] I found the flow direction to be in the ', &
flow_dir,' direction.'
endif
else
do i = 1,3
if (lperi(i)) then
if (.not. lperi(mod(i,3)+1) .and. .not. lperi(mod(i+1,3)+1)) then
flow_dir = i
if (lroot) then
print*,'By using lperi I found the flow direction to be in the ', &
flow_dir,' direction.'
endif
endif
endif
enddo
if (lset_flow_dir) flow_dir = flow_dir_set
if (flow_dir == 0) then
call fatal_error('initialize_solid_cells', &
'I was not able to determine the flow direction!')
endif
endif
!
! If velocity for initial potential flow is not set, use boundary condition to set this
!
if (init_uu==0.) then
if (flow_dir==1) then; init_uu=fbcx(1,1)
elseif (flow_dir==2) then; init_uu=fbcy(2,1)
elseif (flow_dir==3) then; init_uu=fbcz(3,1)
endif
print*, 'By using fbc[x,y,z] I set the initial velocity to ',init_uu
endif
!
! Find inlet temperature
!
if (ilnTT /= 0) then
if (flow_dir == 1) T0 = fbcx(ilnTT,1)
if (flow_dir == -1) T0 = fbcx(ilnTT,2)
if (flow_dir == 2) T0 = fbcy(ilnTT,1)
if (flow_dir == -2) T0 = fbcy(ilnTT,2)
if (flow_dir == 3) T0 = fbcz(ilnTT,1)
if (flow_dir == -3) T0 = fbcz(ilnTT,2)
if (.not. ltemperature_nolog) T0 = exp(T0)
endif
!
! Initial chemical composition
!
! Chemistry
if (lchemistry) then
do k = 1,nchemspec
if (flow_dir == 1) chemspec0(k) = fbcx(ichemspec(k),1)
if (flow_dir == -1) chemspec0(k) = fbcx(ichemspec(k),2)
if (flow_dir == 2) chemspec0(k) = fbcy(ichemspec(k),1)
if (flow_dir == -2) chemspec0(k) = fbcy(ichemspec(k),2)
if (flow_dir == 3) chemspec0(k) = fbcz(ichemspec(k),1)
if (flow_dir == -3) chemspec0(k) = fbcz(ichemspec(k),2)
enddo
endif
!
! Initialize the pencils overlapping grid and construct arrays
! for pencil indices
!
call initialize_pencils_ogrid(0.0)
call setup_mm_nn_ogrid
!
! Construct overlapping grid
!
call construct_grid_ogrid
!
! Initialize overlapping grid
!
call initialize_grid_ogrid
!
! Factor difference between timestep on background grid and overset grid
!
if (lock_dt) then
timestep_factor = 1
else
!Jorgen: Removed +1 from timestep_factor, still not safe if ogrid limited by
! diffusive timestep
timestep_factor = ceiling(dxmin/dxmin_ogrid)*reduce_timestep
if (timestep_factor < 1) then
timestep_factor = 1
endif
!timestep_factor = timestep_factor*timestep_factor
endif
!
! Set interpolation limits
!
call set_interpolation_limits
!
! Inform user
!
if (lroot) then
if (.not.lequidist_ogrid(1)) then
print*, ''
print*, 'Non-linear grid in radial direction - dx_rcyl, dx_rogrid:', &
0.5*(xglobal_ogrid(nghost+1)-xglobal_ogrid(nghost-1)), &
0.5*(xglobal_ogrid(mxgrid_ogrid-nghost+1)-xglobal_ogrid(mxgrid_ogrid-nghost-1))
print*, 'Theta grid spacing - r_cyl*dy_ogrid,r_int_outer*dy_ogrid,r_ogrid*dy_ogrid',&
xyz0_ogrid(1)*(yglobal_ogrid(2)-yglobal_ogrid(1)), &
r_int_outer*(yglobal_ogrid(2)-yglobal_ogrid(1)), &
r_ogrid*(yglobal_ogrid(2)-yglobal_ogrid(1))
print*, ''
print*, 'dtheta/dr_surf', &
xyz0_ogrid(1)*(yglobal_ogrid(2)-yglobal_ogrid(1)) /&
(0.5*(xglobal_ogrid(nghost+1)-xglobal_ogrid(nghost-1)))
print*, 'dtheta/dr_rogrid',&
r_ogrid*(yglobal_ogrid(2)-yglobal_ogrid(1)) / &
(0.5*(xglobal_ogrid(mxgrid_ogrid-nghost+1)-xglobal_ogrid(mxgrid_ogrid-nghost-1)) )
print*, 'dx/dr_rogrid', dx/ &
(0.5*(xglobal_ogrid(mxgrid_ogrid-nghost+1)-xglobal_ogrid(mxgrid_ogrid-nghost-1)) )
print*, 'dx/dtheta_rogrid', dx/ &
(r_ogrid*(yglobal_ogrid(2)-yglobal_ogrid(1)))
print*, ''
print*, 'Cartesian grid spacing - dx, dy, dz:', dx,dy,dz
else
print*, 'Radial grid spacing - dx_ogrid:', &
0.5*(xglobal_ogrid(nghost+1)-xglobal_ogrid(nghost-1))
print*, 'Theta grid spacing - r_cyl*dy_ogrid,r_int_outer*dy_ogrid,r_ogrid*dy_ogrid',&
xyz0_ogrid(1)*(yglobal_ogrid(2)-yglobal_ogrid(1)), &
r_int_outer*(yglobal_ogrid(2)-yglobal_ogrid(1)), &
r_ogrid*(yglobal_ogrid(2)-yglobal_ogrid(1))
print*, 'Cartesian grid spacing - dx, dy, dz:', dx,dy,dz
endif
print*, 'Timestep factor:', timestep_factor
if (.not.lequidist_ogrid(2)) then
call fatal_error('initialize_solid_cells','non-linear grid in theta direction not allowed')
endif
if (.not.lequidist_ogrid(3)) print*, 'Non-linear grid in z-direction'
endif
!
! Read data.
! Snapshot data are saved in the data subdirectory.
! This directory must exist, but may be linked to another disk.
!
if (lrun) call rsnap_ogrid('ogvar.dat',lread_nogrid)
!
! The following is here to avoid division in sub.f90 for diagnostic
! outputs of integrated values in the non equidistant case.
! Do this even for uniform meshes, in which case xprim=dx, etc.
! Remember that dx_1=0 for runs without extent in that direction.
!
if (nxgrid==1) then; xprim=1.0; else; xprim=1./dx_1; endif
if (nygrid==1) then; yprim=1.0; else; yprim=1./dy_1; endif
if (nzgrid==1) then; zprim=1.0; else; zprim=1./dz_1; endif
!
! Construct summation by parts-stencils, if SBP is on
!
if (BDRY5) then
if (lroot) print*, 'Cylinder boundary condition: Fifth order boundary closures'
SBP=.false.
elseif (SBP) then
if (.not. SBP_optimized .and. .not. SBP_reduced_to2) then
if (lroot) print*, 'Cylinder boundary condition: Third order SBP boundary closures'
D1_SBP(1,:)=(/ -21600./13649. , 104009./54596. , 30443./81894. , &
-33311./27298. , 16863./27298. , -15025./163788. , &
0. , 0. , 0. /)
D1_SBP(2,:)=(/ -104009./240260., 0. , -311./72078. , &
20229./24026. , -24337./48052. , 36661./360390. , &
0. , 0. , 0. /)
D1_SBP(3,:)=(/ -30443./162660. , 311./32532. , 0. , &
-11155./16266. , 41287./32532. , -21999./54220. , &
0. , 0. , 0. /)
D1_SBP(4,:)=(/ 33311./107180. , -20229./21436. , 485./1398. , &
0. , 4147./21436. , 25427./321540. , &
72./5359. , 0. , 0. /)
D1_SBP(5,:)=(/ -16863./78770. , 24337./31508. , -41287./47262. , &
-4147./15754. , 0. , 342523./472620. , &
-1296./7877. , 144./7877. , 0. /)
D1_SBP(6,:)=(/ 15025./525612. , -36661./262806. , 21999./87602. , &
-25427./262806. , -342523./525612., 0. , &
32400./43801. , -6480./43801. , 720./43801. /)
D2_SBP(1,:)=(/ 114170./40947. , -438107./54596. , 336409./40947. , &
-276997./81894. , 3747./13649. , 21035./163788. , &
0. , 0. , 0. /)
D2_SBP(2,:)=(/ 6173./5860. , -2066./879. , 3283./1758. , &
-303./293. , 2111./3516. , -601./4395. , &
0. , 0. , 0. /)
D2_SBP(3,:)=(/ -52391./81330. , 134603./32532. , -21982./2711. , &
112915./16266. , -46969./16266. , 30409./54220. , &
0. , 0. , 0. /)
D2_SBP(4,:)=(/ 68603./321540. , -12423./10718. , 112915./32154. , &
-75934./16077. , 53369./21436. , -54899./160770. , &
48./5359. , 0. , 0. /)
D2_SBP(5,:)=(/ -7053./39385. , 86551./94524. , -46969./23631. , &
53369./15754. , -87904./23631. , 820271./472620. , &
-1296./7877. , 96./7877. , 0. /)
D2_SBP(6,:)=(/ 21035./525612. , -24641./131403. , 30409./87602. , &
-54899./131403. , 820271./525612., -117600./43801. , &
64800./43801. , -6480./43801. , 480./43801. /)
elseif (SBP_reduced_to2) then
if (lroot) print*, 'Cylinder boundary condition: Second order SBP boundary closures'
D1_SBP(1,:)=(/-24./17. , 59./34. , -4./17. , &
-3./34. , 0. , 0. , &
0. , 0. , 0. /)
D1_SBP(2,:)=(/-1./2. , 0. , 1./2. , &
0. , 0. , 0. , &
0. , 0. , 0. /)
D1_SBP(3,:)=(/ 4./43. , -59./86. , 0. , &
59./86. , -4./43. , 0. , &
0. , 0. , 0. /)
D1_SBP(4,:)=(/ 3./98. , 0. , -59./98. , &
0. , 32./49. , -4./49. , &
0. , 0. , 0. /)
D1_SBP(5,:)=(/ 0. , 0. , 0. , &
0. , 0. , 0. , &
0. , 0. , 0. /)
D1_SBP(6,:)=(/ 0. , 0. , 0. , &
0. , 0. , 0. , &
0. , 0. , 0. /)
D2_SBP(1,:)=(/ 2. ,-5. , 4. , &
-1. , 0. , 0. , &
0. , 0. , 0. /)
D2_SBP(2,:)=(/ 1. ,-2. , 1. , &
0. , 0. , 0. , &
0. , 0. , 0. /)
D2_SBP(3,:)=(/ -4./43. , 59./43. , -110./43. , &
59./43. ,-4./43. , 0. , &
0. , 0. , 0. /)
D2_SBP(4,:)=(/-1./49. , 0. , 59./49. , &
-118./49. , 64./49. , -4./49. , &
0. , 0. , 0. /)
D2_SBP(5,:)=(/ 0. , 0. , 0. , &
0. , 0. , 0. , &
0. , 0. , 0. /)
D2_SBP(6,:)=(/ 0. , 0. , 0. , &
0. , 0. , 0. , &
0. , 0. , 0. /)
else
D1_SBP(1,1) = -21600./13649.; D1_SBP(1,2) = 81763./40947.; D1_SBP(1,3) = 131./27298.
D1_SBP(1,4) = -9143./13649.; D1_SBP(1,5) = 20539./81894.; D1_SBP(1,6) = 0.
D1_SBP(1,7) = 0.; D1_SBP(1,8) = 0.; D1_SBP(1,9) = 0.
D1_SBP(2,1) = -81763./180195.;D1_SBP(2,2) = 0.; D1_SBP(2,3) = 7357./36039.
D1_SBP(2,4) = 30637./72078.; D1_SBP(2,5) = -2328./12013.; D1_SBP(2,6) = 6611./360390.
D1_SBP(2,7) = 0.; D1_SBP(2,8) = 0.; D1_SBP(2,9) = 0.
D1_SBP(3,1) = -131./54220.; D1_SBP(3,2) = -7357./16266.; D1_SBP(3,3) = 0.
D1_SBP(3,4) = 645./2711.; D1_SBP(3,5) = 11237./32532.; D1_SBP(3,6) = -3487./27110.
D1_SBP(3,7) = 0.; D1_SBP(3,8) = 0.; D1_SBP(3,9) = 0.
D1_SBP(4,1) = 9143./53590.; D1_SBP(4,2) = -30637./64308.; D1_SBP(4,3) = -645./5359.
D1_SBP(4,4) = 0.; D1_SBP(4,5) = 13733./32154.; D1_SBP(4,6) = -67./4660.
D1_SBP(4,7) = 72./5359.; D1_SBP(4,8) = 0.; D1_SBP(4,9) = 0.
D1_SBP(5,1) = -20539./236310.;D1_SBP(5,2) = 2328./7877.; D1_SBP(5,3) =-11237./47262.
D1_SBP(5,4) = -13733./23631.; D1_SBP(5,5) = 0.; D1_SBP(5,6) = 89387./118155.
D1_SBP(5,7) = -1296./7877.; D1_SBP(5,8) = 144./7877.; D1_SBP(5,9) = 0.
D1_SBP(6,1) = 0.; D1_SBP(6,2) = -6611./262806.; D1_SBP(6,3) = 3487./43801.
D1_SBP(6,4) = 1541./87602.; D1_SBP(6,5) = -89387./131403.;D1_SBP(6,6) = 0.
D1_SBP(6,7) = 32400./43801.; D1_SBP(6,8) = -6480./43801.; D1_SBP(6,9) = 720./43801.
D2_SBP(1,1) =0.3548420602490798e1 ; D2_SBP(3,1) =-0.5393903966319141e-1 ; D2_SBP(5,1) = 0.1623318041994786e-1
D2_SBP(1,2) =-0.1162385694827807e2 ; D2_SBP(3,2) =0.1153943542621719e1 ; D2_SBP(5,2) =-0.8794616833597996e-1
D2_SBP(1,3) =0.1480964237069501e2 ; D2_SBP(3,3) =-0.2040716873611299e1 ; D2_SBP(5,3) = 0.103577624811612e0
D2_SBP(1,4) =-0.8968412049815223e1 ; D2_SBP(3,4) =0.698739734417074e0 ; D2_SBP(5,4) = 0.114967901600216e1
D2_SBP(1,5) =0.2059642370694317e1 ; D2_SBP(3,5) =0.421429883414006e0 ; D2_SBP(5,5) =-0.2443599523155367e1
D2_SBP(1,6) =0.3761430517226221e0 ; D2_SBP(3,6) =-0.2262171762222378e0 ; D2_SBP(5,6) = 0.1375113224609842e1
D2_SBP(1,7) =-0.2015793975095019e0 ; D2_SBP(3,7) =0.5090670369467911e-1 ; D2_SBP(5,7) =-0.1218565837960692e0
D2_SBP(1,8) =0.5117538641997827e-13 ; D2_SBP(3,8) =-0.4371323842747547e-2 ; D2_SBP(5,8) = 0.8668492495883396e-2
D2_SBP(1,9) =-0.3386357570016522e-15; D2_SBP(3,9) =0.2245491919975288e-3 ; D2_SBP(5,9) = 0.1307369479706344e-3
D2_SBP(2,1) =0.857883182233682e0 ; D2_SBP(4,1) =-0.2032638843942139e-1 ; D2_SBP(6,1) =-0.3185308684167192e-2
D2_SBP(2,2) =-0.1397247220064007e1 ; D2_SBP(4,2) =0.4181668262047738e-1 ; D2_SBP(6,2) = 0.1943844988205038e-1
D2_SBP(2,3) =0.3461647289468133e-1 ; D2_SBP(4,3) =0.1009041221554696e1 ; D2_SBP(6,3) =-0.3865422059089032e-1
D2_SBP(2,4) =0.6763679122231971e0 ; D2_SBP(4,4) =-0.2044119911750601e1 ; D2_SBP(6,4) =-0.8123817099768654e-1
D2_SBP(2,5) =-0.1325900419870384e0 ; D2_SBP(4,5) =0.9609112011420257e0 ; D2_SBP(6,5) = 0.1445296692538394e1
D2_SBP(2,6) =-0.6345391502339508e-1 ; D2_SBP(4,6) =0.9142374273488277e-1 ; D2_SBP(6,6) =-0.2697689107917306e1
D2_SBP(2,7) =0.244383001412735e-1 ; D2_SBP(4,7) =-0.4316909959745465e-1 ; D2_SBP(6,7) = 0.1494463382995396e1
D2_SBP(2,8) =-0.2800316968929196e-4 ; D2_SBP(4,8) =0.4668725019017949e-2 ; D2_SBP(6,8) =-0.1495167135596915e0
D2_SBP(2,9) =0.1331275129575954e-4 ; D2_SBP(4,9) =-0.2461732836225921e-3 ; D2_SBP(6,9) = 0.110849963339009e-1
endif
else
lbidiagonal_derij_ogrid=.true.
call warning('initialize_solid_cells','no cylinder boundary condition set')
endif
!
call get_gamma_etc(gamma,cp,cv)
gamma1=1./gamma; gamma_m1=gamma-1.
!
! Set up necessary units for equation of state
!
if (.not. lchemistry) then
call initialize_eos_ogr
else
call initialize_eos_chemistry
Pr_number1 = 1./Pr_number
endif
!
! Check if it will be necessary to use communication between processors
! to perform the interpolation between the overlapping grids.
! Build serial arrays and data structures necessary to performe communication
! and interpolation efficiently.
!
call construct_serial_bdry_cartesian
call construct_serial_bdry_curv
call initialize_interpolate_points
!call initialize_send_ip_points
call initialize_send_ip_points_alt
!
! If filterint is used, initialize additional boundary zones (halos) needed for high order filter
! Must be done before initialization of mpicomm
!
if (lfilter_solution) call initialize_pade_filter(f_ogrid)
!
! Allocate arrays used for communications across processors internally on the curvilinear grid
!
call initialize_mpicomm_ogrid(lfilter_solution)
!
! If particles are used in the simulation, set up 'local' arrays of f_ogrid variables to use
! when computing particle velocities (etc.) for particles inside r_ogrid
!
if (lparticles) then
call initialize_particles_ogrid(ivar1_part,ivar2_part)
endif
if (lroot) then
print*, 'Interpolation zone: r_ogrid, r_int_outer, r_int_inner',r_ogrid,r_int_outer,r_int_inner
endif
! Check interpolation method
if (lroot) then
if (interpolation_method==1) then
print*, 'interpolation_method==1: Linear interpolation used'
elseif (interpolation_method==3) then
print*, 'interpolation_method==3: Quadratic spline interpolation for velocities, T and species'
elseif (interpolation_method==5) then
print*, 'interpolation_method==5: Polynomial interpolation'
print*, 'WARNING : ONLY SERIAL AT THE MOMENT!!'
elseif (mod(interpolation_method,2)==0) then
print*, 'interpolation_method==',interpolation_method,': ',interpolation_method,&
'th order Lagrangian interpolation used'
endif
if (lparticles) then
print*, ''
if (particle_interpolate==1) then
print*, 'particle_interpolate==1: Linear particle interpolation'
elseif (particle_interpolate==4) then
print*, 'particle_interpolate==4: Qubic particle interpolation'
print*, 'WARNING : NOT PROPERLY TESTED YET!'
else
if (particle_interpolate==2) then
print*, 'particle_interpolate==2: Pseudo-quadratic particle interpolation'
elseif (particle_interpolate==3) then
print*, 'particle_interpolate==3: Quadratic particle interpolation'
else
call fatal_error('initialize_solid_cells','particle interpolation does not exist')
endif
if (lparticle_uradonly) print*, ' : Only for radial direction'
endif
if (lspecial_rad_int_mom) then
print*, 'Particle interpolation with special handling near surface,'
print*, 'withing (momentum thickness + radius):', delta_momentum
endif
endif
endif
!
! Get thermal diffusivity from energy module
!
if (iTT .ne. 0) then
if (.not. lchemistry) call get_shared_variable('chi',chi,caller='initialize_solid_cells')
call get_shared_variable('lheatc_chiconst',lheatc_chiconst)
call get_shared_variable('ladvection_temperature',ladvection_temperature)
call get_shared_variable('lupw_lnTT',lupw_lnTT)
call get_shared_variable('scale_Rgas',scale_Rgas)
else
! call fatal_error('initialize_solid_cells',&
! 'Must use linear temperature for solid_cells_ogrid')
endif
!
if (lchemistry) then
call get_shared_variable('lheatc_chemistry',lheatc_chemistry,caller='initialize_solid_cells')
call get_shared_variable('lflame_front_2D',lflame_front_2D)
call get_shared_variable('linterp_pressure',linterp_pressure)
call initialize_chemistry_og(f_ogrid)
call get_shared_variable('Lewis_coef1',Lewis_coef1)
call get_shared_variable('p_init',p_init)
endif
!
! If TVD Runge-Kutta method is used, temporary array is needed for storage.
!
if (lrk_tvd) then
if (.not.allocated(f_tmp)) allocate(f_tmp(mx_ogrid,my_ogrid,mz_ogrid,mfarray_ogrid))
endif
!
end subroutine initialize_solid_cells
!***********************************************************************
subroutine init_solid_cells(f)
!
! Initial conditions for cases where we have solid structures in the domain.
! Typically the flow field is set such that we have no-slip conditions
! at the solid structure surface.
!
! This routine is adapted to resolve the solid structures with overlapping
! curvilinear grids. Hence, the f-array, which is the array of flow variables
! on the carteisian grid, must use potential flow to set the ghost zones that
! will be set by intepolation for t>0.
!
! Only implemented for a single solid at present!
!
! XX-feb-17/Jorgen: Coded
!
use Initcond, only: gaunoise
use HDF5_IO, only: wdim
use Sub, only: control_file_exists
use EquationOfState, only: imass, lpres_grad
!
real, dimension(mx,my,mz,mfarray), intent(inout) :: f
real, dimension(mx,my,mz) :: mu1_full=0
real, dimension(mx_ogrid,my_ogrid,mz_ogrid) :: mu1_full_ogr=0
real :: a2, rr2, rr2_low, rr2_high
real :: wall_smoothing,wall_smoothing_temp, wall_smoothing_chem
real :: Lorth,flowx,flowy,shift_flow,shift_orth,flow_r,orth_r
integer i,j,cyl,iflow,iorth, k, j2, j3
real :: shift_top,shift_bot,r_k_top,r_k_bot,theta_k_top,theta_k_bot
real :: ur_k_top ,ur_k_bot ,uth_k_top,uth_k_bot
logical :: lnoerase=.false.
real :: coef1, coef2, coef0, r_gradT
real :: lambda_Suth = 1.5e-5, Suth_const = 200.
real :: Rgas_unit_sys, Rgas
!
! Cartesian array f:
!
! Set up variables in the appropriate direction of the flow
if (abs(flow_dir)==1.or.initsolid_cells=='cylinderstream_x') then
iflow= iux
iorth= iuy
Lorth= Lxyz(2)
flowx=1.
flowy=0.
if (xorigo_ogrid(2) /= 0) then
print*,'When using cylinderstream_x all cylinders must have'
print*,'zero offset in y-direction!'
call fatal_error('init_solid_cells:','')
endif
elseif (abs(flow_dir)==2.or.initsolid_cells=='cylinderstream_y') then
iflow= iuy
iorth= iux
Lorth= Lxyz(1)
flowx=0.
flowy=1.
if (xorigo_ogrid(1) /= 0) then
print*,'When using cylinderstream_y all cylinders must have'
print*,'zero offset in x-direction!'
call fatal_error('init_solid_cells:','')
endif
else
if (lroot) print*,'No such value for init_solid_cells:', initsolid_cells
call fatal_error('init_solid_cells','initialization of cylinderstream')
endif
!
! Stream functions for flow around a cylinder as initial condition.
!
call gaunoise(ampl_noise,f,iux,iuz)
f(:,:,:,iflow) = f(:,:,:,iflow)+init_uu
shift_flow = 0
a2=xyz0_ogrid(1)**2
if (TT_square_fit) then
r_gradT = Tgrad_stretch*r_ogrid
coef2 = (cylinder_temp-f(l2,m2,n2,ilnTT))/ &
(a2-2*r_gradT*xyz0_ogrid(1)+r_gradT**2)
coef1 = -2*coef2*r_gradT
coef0 = f(l2,m2,n2,ilnTT) + coef2*r_gradT**2
else
r_gradT = -1.0 ! [PAB] fill in a useful value - or fix the ambiguous if-condition below...
endif
if (unit_system=='cgs') then
Rgas_unit_sys=k_B_cgs/m_u_cgs
elseif (unit_system=='SI') then
Rgas_unit_sys=k_B_cgs/m_u_cgs*1.0e-4
endif
Rgas = Rgas_unit_sys*scale_Rgas/unit_energy
do i = l1,l2
do j = m1,m2
! Choose correct points depending on flow direction
flow_r=(x(i)-xorigo_ogrid(1))*flowx+(y(j)-xorigo_ogrid(2))*flowy
orth_r=(x(i)-xorigo_ogrid(1))*flowy+(y(j)-xorigo_ogrid(2))*flowx
rr2 = flow_r**2+orth_r**2
if (rr2 > a2) then
do cyl = 0,100
if (cyl == 0) then
wall_smoothing = 1-exp(-(rr2-a2)/skin_depth_solid**2)
f(i,j,:,iorth) = f(i,j,:,iorth)-init_uu* &
2*flow_r*orth_r*a2/rr2**2*wall_smoothing
f(i,j,:,iflow) = f(i,j,:,iflow)+init_uu* &
(0. - a2/rr2 + 2*orth_r**2*a2/rr2**2)*wall_smoothing
if ((ilnTT /= 0 .and. .not. lchemistry) .or. (lchemistry .and. .not. lflame_front_2D)) then
if (TT_square_fit .and. (sqrt(abs(rr2)) .le. r_gradT)) then
! [PAB] This condition is ambiguous!
! What should happen, if TT_square_fit=T and sqrt(abs(rr2))>r_gradT?
! Currently, this code goes into the else-clause, but is this correct!?
! If resolved, please check if the above default for r_gradT on TT_square_fit=F is still needed.
f(i,j,:,ilnTT) = coef2*rr2 + coef1*sqrt(abs(rr2)) + coef0
else
wall_smoothing_temp = 1-exp(-(rr2-a2)/(sqrt(a2)*Tgrad_stretch)**2)
f(i,j,:,ilnTT) = wall_smoothing_temp*f(i,j,:,ilnTT) &
+cylinder_temp*(1-wall_smoothing_temp)
endif
if (.not. lchemistry) then
f(i,j,:,irho) = f(l2,m2,n2,irho) &
* f(l2,m2,n2,ilnTT)/f(i,j,:,ilnTT)
endif
endif
if (lchemistry .and. .not. lflame_front_2D) then
do k = 1,nchemspec
f(i,j,:,ichemspec(k)) = chemspec0(k)
mu1_full(i,j,:)=mu1_full(i,j,:)+f(i,j,:,ichemspec(k))/species_constants(k,imass)
enddo
f(i,j,:,iRR) = mu1_full(i,j,:)*Rgas
f(i,j,:,irho) = p_init/f(i,j,:,iRR)/f(i,j,:,ilnTT)
endif
else
shift_orth = cyl*Lorth
rr2_low = (flow_r+shift_flow)**2+(orth_r+shift_orth)**2
rr2_high = (flow_r-shift_flow)**2+(orth_r-shift_orth)**2
f(i,j,:,iflow) = f(i,j,:,iflow)+init_uu*( &
+2*(orth_r-shift_orth)**2*a2/rr2_high**2-a2/rr2_high &
+2*(orth_r+shift_orth)**2*a2/rr2_low**2 -a2/rr2_low)
f(i,j,:,iorth) = f(i,j,:,iorth)-init_uu*( &
+2*(flow_r-shift_flow)*(orth_r-shift_orth) &
*a2/rr2_high**2 &
+2*(flow_r+shift_flow)*(orth_r+shift_orth) &
*a2/rr2_low**2)
endif
enddo
else
! Velocities inside the solid objects are set to zero
f(i,j,:,iux:iuz)=0.
if ((ilnTT /= 0 .and. .not. lchemistry) .or. (lchemistry .and. .not. lflame_front_2D)) then
f(i,j,:,ilnTT) = cylinder_temp
f(i,j,:,irho) = f(l2,m2,n2,irho) &
*f(l2,m2,n2,ilnTT)/cylinder_temp
endif
if (lchemistry .and. .not. lflame_front_2D) then
do k = 1,nchemspec
f(i,j,:,ichemspec(k)) = chemspec0(k)
enddo
endif
endif
enddo
enddo
!
! Cylindrical array f_ogrid:
!
! Stream functions for flow around a cylinder as initial condition.
! Note that here ux and uy are the velocities in r and theta directions, respectively
!
! Rotate system if the flow is in y-direction
flowy=-flowy*pi*0.5
f_ogrid(:,:,:,iux:iuz)=0.
if (iTT .ne. 0) then
f_ogrid(:,:,:,iTT)=f(l1,m1,n1,iTT)
endif
if (lchemistry) then
do k = 1,nchemspec
f_ogrid(:,:,:,ichemspec(k)) = f(l1,m1,n1,ichemspec(k))
enddo
endif
if (ldensity_nolog) then
f_ogrid(:,:,:,irho)=init_rho_cyl
else
call fatal_error('init_solid_cells','Must use linear density for solid_cells_ogrid')
endif
call gaunoise_ogrid(ampl_noise,iux,iuz)
do i=l1_ogrid,l2_ogrid+nghost
rr2=x_ogrid(i)**2
wall_smoothing = 1-exp(-(rr2-a2)/skin_depth_solid**2)
do j=m1_ogrid,m2_ogrid
! Compute potential flow past single cylinder
f_ogrid(i,j,:,iux) = +init_uu*(1-a2/rr2)*cos(y_ogrid(j)+flowy)
f_ogrid(i,j,:,iuy) = -init_uu*(1+a2/rr2)*sin(y_ogrid(j)+flowy)
if (ilnTT /= 0) then
if (TT_square_fit) then
f_ogrid(i,j,:,ilnTT) = coef2*rr2 + coef1*sqrt(rr2) + coef0
else
wall_smoothing_temp = 1-exp(-(rr2-a2)/(sqrt(a2)*Tgrad_stretch)**2)
f_ogrid(i,j,:,ilnTT) = wall_smoothing_temp*f_ogrid(i,j,:,ilnTT) &
+ cylinder_temp*(1-wall_smoothing_temp)
endif
! wall_smoothing_temp = 1-exp(-(rr2-a2)/(sqrt(a2))**2)
f_ogrid(i,j,:,irho) = f_ogrid(l2_ogrid,m2_ogrid,n2_ogrid,irho) &
*f(l2,m2,n2,ilnTT)/f_ogrid(i,j,:,ilnTT)
! EWA: I changed f_ogrid to f_cartesian here (see line above and below
! this comment) as it causes my simulations to crash
! *f_ogrid(l2_ogrid,m2_ogrid,n2_ogrid,ilnTT)/f_ogrid(i,j,:,ilnTT)
!
if (lchemistry) then
if (lsinus_spec_distr) then
wall_smoothing_chem = (sin(pi/(r_ogrid-cylinder_radius)*x_ogrid(i)-pi*(r_ogrid+cylinder_radius)&
/(2*(r_ogrid-cylinder_radius)))+1.)/2
else
wall_smoothing_chem = wall_smoothing
endif
do k = 1,nchemspec
f_ogrid(i,j,:,ichemspec(k)) = chemspec0(k)
enddo
! if (lreac_heter) then
! Heterogeneous reactions only work with simplified mechanism
if (ldist_CO2) then
! distribute CO2 exponentially close to the cylinder - this slowly introduces reactions
f_ogrid(i,j,:,ichemspec(4)) = f_ogrid(i,j,:,ichemspec(4))*wall_smoothing_chem
f_ogrid(i,j,:,ichemspec(1)) = 1.-f_ogrid(i,j,:,ichemspec(4))&
-f_ogrid(i,j,:,ichemspec(2))-f_ogrid(i,j,:,ichemspec(3))
if (nchemspec==5) then
f_ogrid(i,j,:,ichemspec(1))=f_ogrid(i,j,:,ichemspec(1))-f_ogrid(i,j,:,ichemspec(5))
endif
elseif (ldist_CO) then
! otherwise CO is distributed exponentially close to the cylinder
f_ogrid(i,j,:,ichemspec(4)) = f_ogrid(i,j,:,ichemspec(4))*wall_smoothing_chem
f_ogrid(i,j,:,ichemspec(2)) = 1.-f_ogrid(i,j,:,ichemspec(4))&
-f_ogrid(i,j,:,ichemspec(1))-f_ogrid(i,j,:,ichemspec(3))
if (nchemspec==5) then
f_ogrid(i,j,:,ichemspec(2))=f_ogrid(i,j,:,ichemspec(2))-f_ogrid(i,j,:,ichemspec(5))
endif
endif
! Never compute explicit BC for density with chemistry
lexpl_rho = .false.
! endif
endif
endif
! Compute contribution to flow from cylinders above and below, due to periodic boundary conditions
do cyl = 1,100
shift_top = cyl*Lorth
shift_bot = cyl*Lorth
r_k_top=sqrt(x_ogrid(i)**2-2*x_ogrid(i)*shift_top*sin(y_ogrid(j)+flowy)+shift_top**2)
r_k_bot=sqrt(x_ogrid(i)**2-2*x_ogrid(i)*shift_bot*sin(y_ogrid(j)+flowy)+shift_bot**2)
theta_k_top=atan2(x_ogrid(i)*sin(y_ogrid(j)+flowy)-shift_top,(x_ogrid(i)*cos(y_ogrid(j)+flowy)))
theta_k_bot=atan2(x_ogrid(i)*sin(y_ogrid(j)+flowy)-shift_bot,(x_ogrid(i)*cos(y_ogrid(j)+flowy)))
ur_k_top =init_uu*a2*( x_ogrid(i)*cos(theta_k_top)-shift_top*sin(theta_k_top-(y_ogrid(j)+flowy)))/(r_k_top**3)
ur_k_bot =init_uu*a2*( x_ogrid(i)*cos(theta_k_bot)-shift_bot*sin(theta_k_bot-(y_ogrid(j)+flowy)))/(r_k_bot**3)
uth_k_top=init_uu*a2*(-x_ogrid(i)*sin(theta_k_top)+shift_top*cos(theta_k_top-(y_ogrid(j)+flowy)))/(r_k_top**3)
uth_k_bot=init_uu*a2*(-x_ogrid(i)*sin(theta_k_bot)+shift_bot*cos(theta_k_bot-(y_ogrid(j)+flowy)))/(r_k_bot**3)
f_ogrid(i,j,:,iux) = f_ogrid(i,j,:,iux)+(ur_k_top+ur_k_bot)
f_ogrid(i,j,:,iuy) = f_ogrid(i,j,:,iuy)+(uth_k_top+uth_k_bot)
enddo
enddo
! Force no-slip condition on the cylinder surface
f_ogrid(i,:,:,iux:iuy)=f_ogrid(i,:,:,iux:iuy)*wall_smoothing
enddo
!
if (lchemistry .and. lflame_front_2D) then
!
f_ogrid(:,:,:,irho) = f(l2,m2,n2,irho)
f_ogrid(:,:,:,iTT) = f(l2,m2,n2,iTT)
do k = 1,nchemspec
f_ogrid(:,:,:,ichemspec(k)) = f(l2,m2,n2,ichemspec(k))
enddo
!
elseif (lchemistry) then
!
do k = 1,nchemspec
mu1_full_ogr(:,:,:) = mu1_full_ogr(:,:,:)+f_ogrid(:,:,:,ichemspec(k))/species_constants(k,imass)
enddo
!
f_ogrid(:,:,:,iRR) = mu1_full_ogr(:,:,:)*Rgas
f_ogrid(:,:,:,irho) = p_init/f_ogrid(:,:,:,iRR)/f_ogrid(:,:,:,ilnTT)
!
do j3 = 1,mz_ogrid
do j2 = 1,my_ogrid
f_ogrid(:,j2,j3,iviscosity) = lambda_Suth*f_ogrid(:,j2,j3,iTT)**(3./2.)&
/(Suth_const+f_ogrid(:,j2,j3,iTT))/f_ogrid(:,j2,j3,irho)
enddo
enddo
endif
!
if (lpres_grad) then
f_ogrid(:,:,:,igpx) = 0.
f_ogrid(:,:,:,igpy) = 0.
f(:,:,:,igpx) = 0.
f(:,:,:,igpy) = 0.
endif
!
! Write initial condition to disk.
!
if (lwrite_ic.and.lstart) then
call wsnap_ogrid('OGVAR0',ENUM=.false.,FLIST='ogvarN.list')
endif
!
! The option lnowrite writes everything except the actual var.dat file.
! This can be useful if auxiliary files are outdated, and don't want
! to overwrite an existing var.dat.
!
lnoerase = control_file_exists("NOERASE")
if (.not.lnowrite .and. .not.lnoerase) then
call wsnap_ogrid('ogvar.dat',ENUM=.false.)
endif
!
! Write ogdim.dat
!
call wdim('ogdim.dat', mx_ogrid, my_ogrid, mz_ogrid, mxgrid_ogrid, mygrid_ogrid, mzgrid_ogrid)
!
endsubroutine init_solid_cells
!***********************************************************************
subroutine initialize_pencils_ogrid(penc0)
!
! Initialize all pencils that are necessary on ogrid
!
! 14-feb-17/Jorgen: Coded
!
real :: penc0
!
p_ogrid%x_mn=penc0
p_ogrid%y_mn=penc0
p_ogrid%z_mn=penc0
p_ogrid%rcyl_mn=penc0
p_ogrid%phi_mn=penc0
p_ogrid%rcyl_mn1=penc0
p_ogrid%fpres=penc0
p_ogrid%fvisc=penc0
p_ogrid%rho=penc0
p_ogrid%rho1=penc0
p_ogrid%lnrho=penc0
p_ogrid%grho=penc0
p_ogrid%glnrho=penc0
p_ogrid%ugrho=penc0
p_ogrid%sglnrho=penc0
p_ogrid%uu=penc0
p_ogrid%u2=penc0
p_ogrid%uij=penc0
p_ogrid%sij=penc0
p_ogrid%sij2=penc0
p_ogrid%ugu=penc0
p_ogrid%ugu2=penc0
p_ogrid%del2u=penc0
p_ogrid%divu=penc0
p_ogrid%lnTT=penc0
p_ogrid%cs2=penc0
p_ogrid%pp=penc0
p_ogrid%ss=penc0
p_ogrid%ugTT=penc0
p_ogrid%TT=penc0
p_ogrid%gTT=penc0
p_ogrid%del2TT=penc0
p_ogrid%lambda=penc0
p_ogrid%glambda=penc0
p_ogrid%Diff_penc_add=penc0
p_ogrid%DYDt_diff=penc0
p_ogrid%DYDt_reac=penc0
p_ogrid%H0_RT=penc0
p_ogrid%hhk_full=penc0
p_ogrid%ghhk=penc0
p_ogrid%glncp=penc0
p_ogrid%cv=penc0
p_ogrid%cp=penc0
p_ogrid%nu=penc0
p_ogrid%gradnu=penc0
p_ogrid%cv1=penc0
p_ogrid%cp1=penc0
p_ogrid%glnTT=penc0
p_ogrid%del2lnTT=penc0
p_ogrid%glnRR=penc0
p_ogrid%RR=penc0
p_ogrid%rho1gpp=penc0
p_ogrid%TT1=penc0
p_ogrid%S0_R=penc0
!
! Defined which pencils to solve
!
lpencil_ogrid=.true.
if (iTT == 0) then
lpencil_ogrid(i_og_ugTT)=.false.
lpencil_ogrid(i_og_TT)=.false.
lpencil_ogrid(i_og_gTT)=.false.
lpencil_ogrid(i_og_del2TT)=.false.
endif
if (nchemspec == 0) then
lpencil_ogrid(i_og_lambda)=.false.
lpencil_ogrid(i_og_glambda)=.false.
lpencil_ogrid(i_og_Diff_penc_add)=.false.
lpencil_ogrid(i_og_DYDt_diff)=.false.
lpencil_ogrid(i_og_DYDt_reac)=.false.
lpencil_ogrid(i_og_H0_RT)=.false.
lpencil_ogrid(i_og_hhk_full)=.false.
lpencil_ogrid(i_og_ghhk)=.false.
lpencil_ogrid(i_og_glncp)=.false.
lpencil_ogrid(i_og_cv)=.false.
lpencil_ogrid(i_og_cp)=.false.
lpencil_ogrid(i_og_nu)=.false.
lpencil_ogrid(i_og_gradnu)=.false.
lpencil_ogrid(i_og_cv1)=.false.
lpencil_ogrid(i_og_cp1)=.false.
lpencil_ogrid(i_og_glnTT)=.false.
lpencil_ogrid(i_og_del2lnTT)=.false.
lpencil_ogrid(i_og_glnRR)=.false.
lpencil_ogrid(i_og_RR)=.false.
lpencil_ogrid(i_og_rho1gpp)=.false.
lpencil_ogrid(i_og_TT1)=.false.
lpencil_ogrid(i_og_S0_R)=.false.
endif
!
endsubroutine initialize_pencils_ogrid
!***********************************************************************
subroutine initialize_eos_ogr
!
! Set up parameters necessary to compute the energy and pressure using
! the ideal gas eos.
! This is done in the unit_eos routine in eos_idealgas.f90 for the
! cartesian solver
!
! 4-apr-17/Jorgen: Coded
!
use EquationOfState, only: cs20,rho0,lnrho0
if (.not.leos_idealgas) call fatal_error('initialize_eos_ogr','currently assumes EOS=eos_idealgas')
!
! rho0=1.0
! lnrho0=log(rho0)
if (gamma_m1/=0.0) then
lnTT0=log(cs20/(cp*gamma_m1)) !(general case)
leos_isentropic=.true.
else
lnTT0=log(cs20/cp) !(isothermal/polytropic cases: check!)
leos_isothermal=.true.
endif
!
endsubroutine initialize_eos_ogr
!***********************************************************************
subroutine initialize_interpolate_points
!
! Build arrays of interpolation data on processors that perform interpolation.
! Necessary to perform communications in an efficient manner.
!
! apr-17/Jorgen: Coded
!
real, dimension(3) :: xyz,rthz
integer :: i,j,k,ii
real, dimension(3) :: xyz_neigh, rthz_neigh
!
! Set the length of the interpolation stencil based on choice of method
!
if (interpolation_method==1) then
inter_len=2
elseif (interpolation_method==3) then
inter_len=3
elseif (interpolation_method==5) then
inter_len=interpol_order_poly
elseif (mod(interpolation_method,2)==0) then
inter_len=interpolation_method+1
else
call fatal_error('initialize_interpolate_points','selected interpolation method does not exist!')
endif
!
! Set up interpolation stencil and data for interpolation from cartesian
! to curvilinear grid
! Only done for processors at containing the end points of the radial values.
!
! If interpolation point requires data from outside this processors domain,
! set find the grid points and processor id for communication.
!
if (llast_proc_x) then
n_ip_cart_to_curv=ny_ogrid*nz_ogrid*nghost
allocate(cartesian_to_curvilinear(n_ip_cart_to_curv))
!
ii=0
do k=n1_ogrid,n2_ogrid
do j=m1_ogrid,m2_ogrid
do i=l2_ogrid+1,l2_ogrid+nghost
ii=ii+1
xyz=(/ x_ogrid(i)*cos(y_ogrid(j))+xorigo_ogrid(1), &
x_ogrid(i)*sin(y_ogrid(j))+xorigo_ogrid(2), &
z_ogrid(k) /)
cartesian_to_curvilinear(ii)%i_xyz = (/ i,j,k /)
cartesian_to_curvilinear(ii)%xyz = xyz
call find_near_ind_global_cart(cartesian_to_curvilinear(ii)%ind_global_neighbour, &
xyz,lcheck_init_interpolation)
!
! If higher order interpolation is used, adjust nearest index to be the index to point actually nearest
! the interpolation point, NOT the index of bottom left point in cell containing interpolation point
!
if (interpolation_method>1) then
call adjust_inear_cart_glob(cartesian_to_curvilinear(ii)%ind_global_neighbour,xyz)
endif
!
xyz_neigh= (/ xglobal(cartesian_to_curvilinear(ii)%ind_global_neighbour(1)), &
yglobal(cartesian_to_curvilinear(ii)%ind_global_neighbour(2)), &
zglobal(cartesian_to_curvilinear(ii)%ind_global_neighbour(3)) /)
call find_proc_cartesian(xyz_neigh,cartesian_to_curvilinear(ii)%from_proc)
if (cartesian_to_curvilinear(ii)%from_proc == iproc) then
call ind_global_to_local_cart(cartesian_to_curvilinear(ii)%ind_global_neighbour, &
cartesian_to_curvilinear(ii)%ind_local_neighbour,lcheck_init_interpolation)
endif
enddo
enddo
enddo
endif
!
! Set up interpolation stencil and data for interpolation from curvilinear
! to cartesian grid
! Here we do not know beforehand what points are needed, so we must iterate
! through all points. Do this twice, once to set the size of the arrays of
! interpolation data, and once to set the data values (after allocating arrays).
!
! If interpolation point requires data from outside this processors domain,
! find the grid points and processor id for communication.
!
do k=n1,n2
do j=m1,m2
do i=l1,l2
rthz(1)=radius_ogrid(x(i),y(j))
if ((rthz(1)<=r_int_outer) .and. rthz(1)>=r_int_inner_vid) then
n_ip_curv_to_cart=n_ip_curv_to_cart+1
endif
enddo
enddo
enddo
allocate(curvilinear_to_cartesian(n_ip_curv_to_cart))
!
ii=0
do k=n1,n2
do j=m1,m2
do i=l1,l2
call get_polar_coords(x(i),y(j),z(k),rthz)
if ((rthz(1)<=r_int_outer) .and. rthz(1)>=r_int_inner) then
ii=ii+1
curvilinear_to_cartesian(ii)%i_xyz = (/ i,j,k /)
curvilinear_to_cartesian(ii)%xyz = rthz
call find_near_ind_global_curv(curvilinear_to_cartesian(ii)%ind_global_neighbour, &
rthz,lcheck_init_interpolation)
!
! If higher order interpolation is used, adjust nearest index to be the index to point actually nearest
! the interpolation point, NOT the index of bottom left point in cell containing interpolation point
! Also, make sure that no interpolation points try to use points inside the cylinder
!
if (interpolation_method>1) then
call adjust_inear_curv_glob(curvilinear_to_cartesian(ii)%ind_global_neighbour,rthz)
endif
!
rthz_neigh= (/ xglobal_ogrid(curvilinear_to_cartesian(ii)%ind_global_neighbour(1)), &
yglobal_ogrid(curvilinear_to_cartesian(ii)%ind_global_neighbour(2)), &
zglobal_ogrid(curvilinear_to_cartesian(ii)%ind_global_neighbour(3)) /)
call find_proc_curvilinear(rthz_neigh,curvilinear_to_cartesian(ii)%from_proc)
if (curvilinear_to_cartesian(ii)%from_proc==iproc) then
call ind_global_to_local_curv(curvilinear_to_cartesian(ii)%ind_global_neighbour, &
curvilinear_to_cartesian(ii)%ind_local_neighbour,lcheck_init_interpolation)
endif
endif
enddo
enddo
enddo
interpol_max = ii
do k=n1,n2
do j=m1,m2
do i=l1,l2
call get_polar_coords(x(i),y(j),z(k),rthz)
if ((rthz(1)<r_int_inner) .and. rthz(1)>=r_int_inner_vid) then
ii=ii+1
curvilinear_to_cartesian(ii)%i_xyz = (/ i,j,k /)
curvilinear_to_cartesian(ii)%xyz = rthz
call find_near_ind_global_curv(curvilinear_to_cartesian(ii)%ind_global_neighbour, &
rthz,lcheck_init_interpolation)
!
! If higher order interpolation is used, adjust nearest index to be the index to point actually nearest
! the interpolation point, NOT the index of bottom left point in cell containing interpolation point
! Also, make sure that no interpolation points try to use points inside the cylinder
!
if (interpolation_method>1) then
call adjust_inear_curv_glob(curvilinear_to_cartesian(ii)%ind_global_neighbour,rthz)
endif
!
rthz_neigh= (/ xglobal_ogrid(curvilinear_to_cartesian(ii)%ind_global_neighbour(1)), &
yglobal_ogrid(curvilinear_to_cartesian(ii)%ind_global_neighbour(2)), &
zglobal_ogrid(curvilinear_to_cartesian(ii)%ind_global_neighbour(3)) /)
call find_proc_curvilinear(rthz_neigh,curvilinear_to_cartesian(ii)%from_proc)
if (curvilinear_to_cartesian(ii)%from_proc==iproc) then
call ind_global_to_local_curv(curvilinear_to_cartesian(ii)%ind_global_neighbour, &
curvilinear_to_cartesian(ii)%ind_local_neighbour,lcheck_init_interpolation)
endif
endif
enddo
enddo
enddo
!print*, 'read ii'
!read(*,*) ii
!
endsubroutine initialize_interpolate_points
!!***********************************************************************
subroutine initialize_send_ip_points_alt
!
! Build arrays of interpolation data on processors that contain data
! necessary for interpolation on other processors.
!
! apr-17/Jorgen: Coded
!
use Mpicomm, only: mpirecv_int, mpisend_nonblock_int, mpibarrier, &
mpirecv_nonblock_int, mpisend_int, mpiwait, mpibcast_int, &
mpirecv_nonblock_real, mpisend_real
use Solid_Cells_Mpicomm, only: finalize_isend_init_interpol
integer :: i,iip,npoint
integer, dimension(ncpus) :: from_proc_curv_to_cart=0
integer, dimension(ncpus) :: from_proc_cart_to_curv=0
integer, dimension(:,:,:), allocatable :: ind_from_proc_curv
integer, dimension(:,:,:), allocatable :: ind_from_proc_cart
integer, dimension(:,:), allocatable :: ip_id_curv_to_cart
integer, dimension(:,:), allocatable :: ip_id_cart_to_curv
integer :: max_from_proc, from_proc
integer, dimension(ncpus-1) :: ireq1D
integer, dimension(ncpus-1,3) :: ireq2D
integer, dimension(ncpus-1,3) :: ireq2D_xyz
!
integer, dimension(ncpus,ncpus) :: from_proc_curv_to_cart_glob=0
integer, dimension(ncpus,ncpus) :: from_proc_cart_to_curv_glob=0
integer, dimension(ncpus) :: from_proc_bufi =0
integer :: iter, ind_start, ind_stop, ip_recv_tot, ip_send_tot, n_ip_proc
integer, dimension(2) :: buf_size
integer, dimension(:), allocatable :: id_bufi, id_bufo
integer, dimension(:,:), allocatable :: ijk_bufi, ijk_bufo
real, dimension(:,:), allocatable :: xyz_bufi, xyz_bufo
integer, dimension(3) :: indices_global
!TODO TEMP BELOW
real, dimension(:,:,:), allocatable :: xyz_from_curv_to_cart
if (n_ip_curv_to_cart>0) then
do i=1,n_ip_curv_to_cart
from_proc=curvilinear_to_cartesian(i)%from_proc
if (from_proc/=iproc) then
! Must access from_proc+1 instead of from_proc, to avoid accessing element 0
from_proc_curv_to_cart(from_proc+1)=from_proc_curv_to_cart(from_proc+1)+1
endif
enddo
endif
!
max_from_proc=maxval(from_proc_curv_to_cart)
if (max_from_proc>0) then
allocate(ind_from_proc_curv(ncpus,max_from_proc,3))
allocate(ip_id_curv_to_cart(ncpus,max_from_proc))
allocate(xyz_from_curv_to_cart(ncpus,max_from_proc,3))
do iip=0,ncpus-1
if (from_proc_curv_to_cart(iip+1)>0) then
npoint=0
do i=1,n_ip_curv_to_cart
if (curvilinear_to_cartesian(i)%from_proc==iip) then
npoint=npoint+1
! Must access iip+1 instead of iip, to avoid accessing element 0
ind_from_proc_curv(iip+1,npoint,:)=curvilinear_to_cartesian(i)%ind_global_neighbour
ip_id_curv_to_cart(iip+1,npoint)=i
xyz_from_curv_to_cart(iip+1,npoint,:)=curvilinear_to_cartesian(i)%xyz
endif
enddo
endif
enddo
endif
!
if (n_ip_cart_to_curv>0) then
do i=1,n_ip_cart_to_curv
from_proc=cartesian_to_curvilinear(i)%from_proc
if (from_proc/=iproc) then
! Must access from_proc+1 instead of from_proc, to avoid accessing element 0
from_proc_cart_to_curv(from_proc+1)=from_proc_cart_to_curv(from_proc+1)+1
endif
enddo
endif
!
max_from_proc=maxval(from_proc_cart_to_curv)
if (max_from_proc>0) then
allocate(ind_from_proc_cart(ncpus,max_from_proc,3))
allocate(ip_id_cart_to_curv(ncpus,max_from_proc))
do iip=0,ncpus-1
if (from_proc_cart_to_curv(iip+1)>0) then
npoint=0
do i=1,n_ip_cart_to_curv
if (cartesian_to_curvilinear(i)%from_proc==iip) then
npoint=npoint+1
! Must access iip+1 instead of iip, to avoid accessing element 0
ind_from_proc_cart(iip+1,npoint,:)=cartesian_to_curvilinear(i)%ind_global_neighbour
ip_id_cart_to_curv(iip+1,npoint)=i
endif
enddo
endif
enddo
endif
!
! Arrays containing information about which points should be sent by what processor to this
! processor has now been created. Now, there should be some communication to let all processors
! know which grid points they should SEND and who should RECIEVE them.
!
! Note: Code is repeated twice in stead of being programmed as a function, since some compilers do
! not support allocatable arrays as in/out from subroutines/functions
! Use som variant of processor number as unique MPI tag (iip,iip+ncpus,etc.) in communication.
!
! Curvilinear to Cartesian
!
if (lroot) then
do iip=0,ncpus-1
if (iip/=root) then
call mpirecv_int(from_proc_bufi,ncpus,iip,110)
from_proc_curv_to_cart_glob(iip+1,:)=from_proc_bufi
call mpirecv_int(from_proc_bufi,ncpus,iip,115)
from_proc_cart_to_curv_glob(iip+1,:)=from_proc_bufi
else
from_proc_curv_to_cart_glob(root+1,:)=from_proc_curv_to_cart
from_proc_cart_to_curv_glob(root+1,:)=from_proc_cart_to_curv
endif
enddo
else
call mpisend_int(from_proc_curv_to_cart,ncpus,root,110)
call mpisend_int(from_proc_cart_to_curv,ncpus,root,115)
endif
call mpibcast_int(from_proc_curv_to_cart_glob,(/ncpus,ncpus/))
call mpibcast_int(from_proc_cart_to_curv_glob,(/ncpus,ncpus/))
!
! Set some auxiliary parameters to help with the interpolation communication
! Global to module, not to proc
!
n_procs_send_curv_to_cart=count(from_proc_curv_to_cart_glob(:,iproc+1).gt.0)
n_procs_send_cart_to_curv=count(from_proc_cart_to_curv_glob(:,iproc+1).gt.0)
allocate(n_ip_to_proc_curv_to_cart(n_procs_send_curv_to_cart))
allocate(n_ip_to_proc_cart_to_curv(n_procs_send_cart_to_curv))
n_ip_to_proc_curv_to_cart=pack(from_proc_curv_to_cart_glob(:,iproc+1),&
from_proc_curv_to_cart_glob(:,iproc+1).gt.0)
n_ip_to_proc_cart_to_curv=pack(from_proc_cart_to_curv_glob(:,iproc+1),&
from_proc_cart_to_curv_glob(:,iproc+1).gt.0)
allocate(procs_send_curv_to_cart(n_procs_send_curv_to_cart))
allocate(procs_send_cart_to_curv(n_procs_send_cart_to_curv))
iter=1
do iip=0,ncpus-1
if (from_proc_curv_to_cart_glob(iip+1,iproc+1)>0) then
procs_send_curv_to_cart(iter)=iip
iter=iter+1
endif
enddo
iter=1
do iip=0,ncpus-1
if (from_proc_cart_to_curv_glob(iip+1,iproc+1)>0) then
procs_send_cart_to_curv(iter)=iip
iter=iter+1
endif
enddo
!max_send_ip_curv_to_cart=maxval(n_ip_to_proc_curv_to_cart)
!max_send_ip_cart_to_curv=maxval(n_ip_to_proc_cart_to_curv)
if (n_procs_send_curv_to_cart>0) then
max_send_ip_curv_to_cart=maxval(n_ip_to_proc_curv_to_cart)
else
max_send_ip_curv_to_cart=0
endif
if (n_procs_send_cart_to_curv>0) then
max_send_ip_cart_to_curv=maxval(n_ip_to_proc_cart_to_curv)
else
max_send_ip_cart_to_curv=0
endif
!
n_procs_recv_curv_to_cart=count(from_proc_curv_to_cart.gt.0)
n_procs_recv_cart_to_curv=count(from_proc_cart_to_curv.gt.0)
allocate(n_ip_recv_proc_curv_to_cart(n_procs_recv_curv_to_cart))
allocate(n_ip_recv_proc_cart_to_curv(n_procs_recv_cart_to_curv))
n_ip_recv_proc_curv_to_cart=pack(from_proc_curv_to_cart,from_proc_curv_to_cart.gt.0)
n_ip_recv_proc_cart_to_curv=pack(from_proc_cart_to_curv,from_proc_cart_to_curv.gt.0)
allocate(procs_recv_curv_to_cart(n_procs_recv_curv_to_cart))
allocate(procs_recv_cart_to_curv(n_procs_recv_cart_to_curv))
iter=1
do iip=0,ncpus-1
if (from_proc_curv_to_cart(iip+1)>0) then
procs_recv_curv_to_cart(iter)=iip
iter=iter+1
endif
enddo
iter=1
do iip=0,ncpus-1
if (from_proc_cart_to_curv(iip+1)>0) then
procs_recv_cart_to_curv(iter)=iip
iter=iter+1
endif
enddo
!max_recv_ip_curv_to_cart=maxval(n_ip_recv_proc_curv_to_cart)
!max_recv_ip_cart_to_curv=maxval(n_ip_recv_proc_cart_to_curv)
if (n_procs_recv_curv_to_cart>0) then
max_recv_ip_curv_to_cart=maxval(n_ip_recv_proc_curv_to_cart)
else
max_recv_ip_curv_to_cart=0
endif
if (n_procs_recv_cart_to_curv>0) then
max_recv_ip_cart_to_curv=maxval(n_ip_recv_proc_cart_to_curv)
else
max_recv_ip_cart_to_curv=0
endif
!
! SEND/RECV CURVILINEAR TO CARTESIAN
!
! Build recv buffers for ip_send data
! That is, bufferes that RECIEVE data from processors REQUESTING interpolation points.
! Size of buffers set by n_procs_send** etc., since they will contain the send data SENT
! by this processor during interpolation.
!
ip_send_tot=sum(from_proc_curv_to_cart_glob(:,iproc+1))
allocate(ijk_bufi(ip_send_tot,3))
allocate(xyz_bufi(ip_send_tot,3))
allocate(id_bufi(ip_send_tot))
!
! Post non-blocking recieves
!
ind_start=1
do iter=1,n_procs_send_curv_to_cart
ind_stop=ind_start+n_ip_to_proc_curv_to_cart(iter)-1
iip=procs_send_curv_to_cart(iter)
buf_size=(/ind_stop-ind_start+1,3/)
do i=1,3
call mpirecv_nonblock_int(ijk_bufi(ind_start:ind_stop,i),buf_size(1),iip,200+i,ireq2D(iter,i))
call mpirecv_nonblock_real(xyz_bufi(ind_start:ind_stop,i),buf_size(1),iip,190+i,ireq2D_xyz(iter,i))
enddo
call mpirecv_nonblock_int(id_bufi(ind_start:ind_stop),buf_size(1),iip,210,ireq1D(iter))
ind_start=ind_stop+1
enddo
!
! Build send buffers for ip_send data and post blocking sends.
! That is, bufferes that SEND data from processors REQUESTING interpolation points.
! Size of buffers set by n_procs_recv** etc., since they will contain the data RECIEVED
! by this processor during interpolation.
!
ip_recv_tot=sum(from_proc_curv_to_cart)
allocate(ijk_bufo(ip_recv_tot,3))
allocate(xyz_bufo(ip_recv_tot,3))
allocate(id_bufo(ip_recv_tot))
ind_start=1
do iter=1,n_procs_recv_curv_to_cart
n_ip_proc=n_ip_recv_proc_curv_to_cart(iter)
ind_stop=ind_start+n_ip_proc-1
iip=procs_recv_curv_to_cart(iter)
ijk_bufo(ind_start:ind_stop,:)=ind_from_proc_curv(iip+1,1:n_ip_proc,:)
!TODO TEMP
xyz_bufo(ind_start:ind_stop,:)=xyz_from_curv_to_cart(iip+1,1:n_ip_proc,:)
!
id_bufo(ind_start:ind_stop)=ip_id_curv_to_cart(iip+1,1:n_ip_proc)
buf_size=(/ind_stop-ind_start+1,3/)
do i=1,3
call mpisend_int(ijk_bufo(ind_start:ind_stop,i),buf_size(1),iip,200+i)
call mpisend_real(xyz_bufo(ind_start:ind_stop,i),buf_size(1),iip,190+i)
enddo
call mpisend_int(id_bufo(ind_start:ind_stop),buf_size(1),iip,210)
ind_start=ind_stop+1
enddo
!
! Wait for recieved data and build send_curvilinear_to_cartesian data container
!
allocate(send_curvilinear_to_cartesian(ip_send_tot))
ind_start=1
do iter=1,n_procs_send_curv_to_cart
ind_stop=ind_start+n_ip_to_proc_curv_to_cart(iter)-1
iip=procs_send_curv_to_cart(iter)
buf_size=(/ind_stop-ind_start+1,3/)
send_curvilinear_to_cartesian(ind_start:ind_stop)%send_to_proc=iip
do i=1,3
call mpiwait(ireq2D(iter,i))
call mpiwait(ireq2D_xyz(iter,i))
enddo
do i=ind_start,ind_stop
indices_global = ijk_bufi(i,:)
send_curvilinear_to_cartesian(i)%i_global_neighbour=indices_global
send_curvilinear_to_cartesian(i)%xyz=xyz_bufi(i,:)
call ind_global_to_local_curv(indices_global, &
send_curvilinear_to_cartesian(i)%i_near_neighbour,lcheck_init_interpolation)
enddo
call mpiwait(ireq1D(iter))
send_curvilinear_to_cartesian(ind_start:ind_stop)%ip_id=id_bufi(ind_start:ind_stop)
ind_start=ind_stop+1
enddo
deallocate(ijk_bufi)
deallocate(xyz_bufi)
deallocate(id_bufi)
deallocate(ijk_bufo)
deallocate(xyz_bufo)
deallocate(id_bufo)
!
! SEND/RECV CARTESIAN TO CURVILINEAR
!
! Build recv buffers for ip_send data
! That is, bufferes that RECIEVE data from processors REQUESTING interpolation points.
! Size of buffers set by n_procs_send** etc., since they will contain the send data SENT
! by this processor during interpolation.
!
ip_send_tot=sum(from_proc_cart_to_curv_glob(:,iproc+1))
allocate(ijk_bufi(ip_send_tot,3))
allocate(id_bufi(ip_send_tot))
!
! Post non-blocking recieves
!
ind_start=1
do iter=1,n_procs_send_cart_to_curv
ind_stop=ind_start+n_ip_to_proc_cart_to_curv(iter)-1
iip=procs_send_cart_to_curv(iter)
buf_size=(/ind_stop-ind_start+1,3/)
do i=1,3
call mpirecv_nonblock_int(ijk_bufi(ind_start:ind_stop,i),buf_size(1),iip,1200+i,ireq2D(iter,i))
enddo
call mpirecv_nonblock_int(id_bufi(ind_start:ind_stop),buf_size(1),iip,1210,ireq1D(iter))
ind_start=ind_stop+1
enddo
!
! Build send buffers for ip_send data and post blocking sends.
! That is, bufferes that SEND data from processors REQUESTING interpolation points.
! Size of buffers set by n_procs_recv** etc., since they will contain the data RECIEVED
! by this processor during interpolation.
!
ip_recv_tot=sum(from_proc_cart_to_curv)
allocate(ijk_bufo(ip_recv_tot,3))
allocate(id_bufo(ip_recv_tot))
ind_start=1
do iter=1,n_procs_recv_cart_to_curv
n_ip_proc=n_ip_recv_proc_cart_to_curv(iter)
ind_stop=ind_start+n_ip_proc-1
iip=procs_recv_cart_to_curv(iter)
ijk_bufo(ind_start:ind_stop,:)=ind_from_proc_cart(iip+1,1:n_ip_proc,:)
id_bufo(ind_start:ind_stop)=ip_id_cart_to_curv(iip+1,1:n_ip_proc)
buf_size=(/ind_stop-ind_start+1,3/)
do i=1,3
call mpisend_int(ijk_bufo(ind_start:ind_stop,i),buf_size(1),iip,1200+i)
enddo
call mpisend_int(id_bufo(ind_start:ind_stop),buf_size(1),iip,1210)
ind_start=ind_stop+1
enddo
!
! Wait for recieved data and build send_curvilinear_to_cartesian data container
!
allocate(send_cartesian_to_curvilinear(ip_send_tot))
ind_start=1
do iter=1,n_procs_send_cart_to_curv
ind_stop=ind_start+n_ip_to_proc_cart_to_curv(iter)-1
iip=procs_send_cart_to_curv(iter)
buf_size=(/ind_stop-ind_start+1,3/)
send_cartesian_to_curvilinear(ind_start:ind_stop)%send_to_proc=iip
do i=1,3
call mpiwait(ireq2D(iter,i))
enddo
do i=ind_start,ind_stop
indices_global=ijk_bufi(i,:)
call ind_global_to_local_cart(indices_global, &
send_cartesian_to_curvilinear(i)%i_near_neighbour,lcheck_init_interpolation)
enddo
call mpiwait(ireq1D(iter))
send_cartesian_to_curvilinear(ind_start:ind_stop)%ip_id=id_bufi(ind_start:ind_stop)
ind_start=ind_stop+1
enddo
deallocate(ijk_bufi)
deallocate(id_bufi)
deallocate(ijk_bufo)
deallocate(id_bufo)
call mpibarrier
endsubroutine initialize_send_ip_points_alt
!***********************************************************************
subroutine ind_global_to_local_curv(i_rthz_global,i_rthz_local,lcheck)
!
! Translate global indices to local indices on the curvilinear grid
!
! 18-apr-17/Jorgen: Coded
!
integer, dimension(3), intent(in) :: i_rthz_global
integer, dimension(3), intent(out) :: i_rthz_local
logical, intent(in) :: lcheck
!
i_rthz_local(1) = i_rthz_global(1) - nx_ogrid*ipx
i_rthz_local(2) = i_rthz_global(2) - ny_ogrid*ipy
i_rthz_local(3) = i_rthz_global(3) - nz_ogrid*ipz
!
if (lcheck) then
if (abs(x_ogrid(i_rthz_local(1))-xglobal_ogrid(i_rthz_global(1)))>1.e-12) &
print*, 'ERROR: incorrect transformation of global to local coordinates in r-direction'
if (abs(y_ogrid(i_rthz_local(2))-yglobal_ogrid(i_rthz_global(2)))>1.e-12) &
print*, 'ERROR: incorrect transformation of global to local coordinates in th-direction'
if (abs(z_ogrid(i_rthz_local(3))-zglobal_ogrid(i_rthz_global(3)))>1.e-12) &
print*, 'ERROR: incorrect transformation of global to local coordinates in z-direction'
endif
!
endsubroutine ind_global_to_local_curv
!***********************************************************************
subroutine ind_global_to_local_cart(i_xyz_global,i_xyz_local,lcheck)
!
! Translate global indices to local indices on the cartesian grid
!
! 18-apr-17/Jorgen: Coded
!
integer, dimension(3), intent(in) :: i_xyz_global
integer, dimension(3), intent(out) :: i_xyz_local
logical, intent(in) :: lcheck
!
i_xyz_local(1) = i_xyz_global(1) - nx*ipx
i_xyz_local(2) = i_xyz_global(2) - ny*ipy
i_xyz_local(3) = i_xyz_global(3) - nz*ipz
if (lcheck) then
if (abs(x(i_xyz_local(1))-xglobal(i_xyz_global(1)))>1.e-12) &
print*, 'ERROR: incorrect transformation of global to local coordinates in r-direction'
if (abs(y(i_xyz_local(2))-yglobal(i_xyz_global(2)))>1.e-12) &
print*, 'ERROR: incorrect transformation of global to local coordinates in th-direction'
if (abs(z(i_xyz_local(3))-zglobal(i_xyz_global(3)))>1.e-12) &
print*, 'ERROR: incorrect transformation of global to local coordinates in z-direction'
endif
!
endsubroutine ind_global_to_local_cart
!!***********************************************************************
subroutine drag_force_pencils(c_dragx,c_dragy)
!
! Compute the total fluid force upon the cylinder
!
! \vec{F}=\vec{F_p}+\vec{F_s}
!
! \vec{F_p}=\int{-p_{r=0} d\vec{A}}\limit_A
! dA=R*H*\Delta\theta
! d\vec{A}=dA\hat{r}
! \vec{F_s}=\int\vec{\tau}dA
! \tau=\nu\rho_{r=0}(\frac{du_{\theta}}{dr})_{r=0}
! \vec{\tau}=\tau\hat{\theta}
!
! F_x=\vec{F}.\hat{x}=F_p\cos{\theta}-F_s\sin{theta}
! F_y=\vec{F}.\hat{y}=F_p\sin{\theta}+F_s\cos{theta}
!
! 10-apr-17/Jorgen: Coded
!
use Viscosity, only: getnu
!
real, intent(inout) :: c_dragx,c_dragy
real :: F_press,F_shear
real :: nu
!
call getnu(nu_input=nu)
!
F_press=-p_ogrid%pp(1)
F_shear=nu*p_ogrid%rho(1)*p_ogrid%uij(1,2,1)
c_dragx=c_dragx+(F_press*cos(y_ogrid(m_ogrid))-F_shear*sin(y_ogrid(m_ogrid)))
c_dragy=c_dragy+(F_press*sin(y_ogrid(m_ogrid))+F_shear*cos(y_ogrid(m_ogrid)))
!
endsubroutine drag_force_pencils
!***********************************************************************
subroutine drag_coeffs(c_dragx,c_dragy)
!
! Sum up the computed drag on root processor.
! Normalization done in the end of the computation.
! Use initial velocity in flow direction and initial density to compute
! drag coefficients. These should be equal to the inlet velocity.
!
! 11-apr-17/Jorgen: Coded
!
use Mpicomm, only: mpireduce_sum
use EquationOfState, only: rho0
!
real, intent(inout) :: c_dragx,c_dragy
real :: c_dragx_all,c_dragy_all
real :: norm
!
norm=dy_ogrid/(nzgrid_ogrid*rho0*init_uu**2)
!
call mpireduce_sum(c_dragx,c_dragx_all)
call mpireduce_sum(c_dragy,c_dragy_all)
!
if (lroot) then
c_dragx=c_dragx_all*norm
c_dragy=c_dragy_all*norm
if (idiag_c_dragx /= 0) fname(idiag_c_dragx)=c_dragx
if (idiag_c_dragy /= 0) fname(idiag_c_dragy)=c_dragy
endif
!
endsubroutine drag_coeffs
!***********************************************************************
subroutine Nusselt_pencils(Nusselt)
!
! Compute the Nusselt number of the cylinder
!
! 23-aug-17/Ewa+Nils: Coded
!
real, intent(inout) :: Nusselt
real :: gradT
!
gradT=p_ogrid%gTT(1,1)
Nusselt = Nusselt - gradT
!
endsubroutine Nusselt_pencils
!***********************************************************************
subroutine Nusselt_coeffs(Nusselt)
!
! Sum up the computed Nusselt number on root processor.
! Normalization done in the end of the computation.
!
! 23-aug-17/Ewa+Nils: Coded
!
use Mpicomm, only: mpireduce_sum
real, intent(inout) :: Nusselt
real :: Nusselt_all
real :: norm
!
norm = 2.*cylinder_radius/(cylinder_temp-T0)/(nzgrid_ogrid*nygrid_ogrid)
!
call mpireduce_sum(Nusselt,Nusselt_all)
!
if (lroot) then
Nusselt=Nusselt_all*norm
if (idiag_Nusselt /= 0) fname(idiag_Nusselt)=Nusselt
endif
!
endsubroutine Nusselt_coeffs
!***********************************************************************
subroutine mdot_C_pencils(mdot_C)
!
! Compute the mean heterogeneous reaction rate
!
real, dimension (3), intent(inout) :: mdot_C
!
mdot_C(1) = mdot_C(1) + heter_reaction_rate(m_ogrid,n_ogrid,nchemspec+1)
mdot_C(2) = mdot_C(2) + heter_reaction_rate(m_ogrid,n_ogrid,ichem_CO2)
mdot_C(3) = mdot_C(3) + heter_reaction_rate(m_ogrid,n_ogrid,ichem_O2)
!
endsubroutine mdot_C_pencils
!***********************************************************************
subroutine mdot_C_coeffs(mdot_C)
!
! Sum up the computed char consumption rates
!
use Mpicomm, only: mpireduce_sum
real, dimension (3), intent(inout) :: mdot_C
real :: mdot_C_all,mdot_CO2_all,mdot_O2_all
!
call mpireduce_sum(mdot_C(1),mdot_C_all)
call mpireduce_sum(mdot_C(2),mdot_CO2_all)
call mpireduce_sum(mdot_C(3),mdot_O2_all)
!
if (lroot) then
!*(-10) to change units from g/cm^2/s to kg/m^2/s and the opposite
! sign is needed for production -> consumption
mdot_C(1)=mdot_C_all/(nzgrid_ogrid*nygrid_ogrid)*(-10)
mdot_C(3)=mdot_O2_all/(nzgrid_ogrid*nygrid_ogrid)*(-10)
mdot_C(2)=mdot_CO2_all/(nzgrid_ogrid*nygrid_ogrid)*(-10)
if (idiag_mdot_C /= 0) fname(idiag_mdot_C)=mdot_C(1)
if (idiag_mdot_O2 /= 0) fname(idiag_mdot_O2)=mdot_C(3)
if (idiag_mdot_CO2 /= 0) fname(idiag_mdot_CO2)=mdot_C(2)
endif
!
endsubroutine mdot_C_coeffs
!***********************************************************************
subroutine dsolid_dt(f,df,p)
!
! Dummy routine
!
real, dimension(mx,my,mz,mfarray), intent(in):: f
real, dimension(mx,my,mz,mvar), intent(in) :: df
type (pencil_case), intent(in) :: p
!
call keep_compiler_quiet(df,f)
call keep_compiler_quiet(p)
!
end subroutine dsolid_dt
!***********************************************************************
subroutine calc_diagnostics_solid(p)
!
type (pencil_case), intent(in) :: p
call keep_compiler_quiet(p)
endsubroutine calc_diagnostics_solid
!***********************************************************************
subroutine dsolid_dt_integrate
!
! Dummy routine
!
end subroutine dsolid_dt_integrate
!***********************************************************************
subroutine rprint_solid_cells(lreset,lwrite)
!
! Reads and registers print parameters relevant for solid cells
!
! mar-2009/kragset: coded
! nov-2010/kragset: generalized to include drag in z-direction
!
use Diagnostics, only: parse_name
use General, only: loptest
!
integer :: iname
logical :: lreset
logical, optional :: lwrite
!
! Dummy variable
!
if (loptest(lwrite)) print*, lwrite
!
! Reset everything in case of reset
!
if (lreset) then
idiag_c_dragx = 0
idiag_c_dragy = 0
idiag_Nusselt = 0
idiag_mdot_C = 0
idiag_mdot_CO2 = 0
idiag_mdot_O2 = 0
endif
!
! check for those quantities that we want to evaluate online
!
do iname = 1,nname
call parse_name(iname,cname(iname),cform(iname),'c_dragx',idiag_c_dragx)
call parse_name(iname,cname(iname),cform(iname),'c_dragy',idiag_c_dragy)
call parse_name(iname,cname(iname),cform(iname),'Nusselt',idiag_Nusselt)
call parse_name(iname,cname(iname),cform(iname),'mdot_C',idiag_mdot_C)
call parse_name(iname,cname(iname),cform(iname),'mdot_CO2',idiag_mdot_CO2)
call parse_name(iname,cname(iname),cform(iname),'mdot_O2',idiag_mdot_O2)
enddo
!
endsubroutine rprint_solid_cells
!***********************************************************************
subroutine update_solid_cells(f)
!
! Dummy routine
!
real, dimension(mx,my,mz,mfarray) :: f
!
call keep_compiler_quiet(f)
!
end subroutine update_solid_cells
!***********************************************************************
subroutine update_solid_cells_pencil(f)
!
! Dummy routine
!
real, dimension(mx,my,mz,mfarray) :: f
!
call keep_compiler_quiet(f)
!
end subroutine update_solid_cells_pencil
!***********************************************************************
subroutine freeze_solid_cells(df)
!
!
! If we are inside the region of interpolation from curvilinear to cartesian
! grid, the comutations of the f-array are frozen, by setting df=0 for all
! variables
!
! 22-feb-17/Jorgen: Coded
!
real, dimension(mx,my,mz,mvar), intent(inout) :: df
integer :: i
!
!
do i=l1,l2
if (radius_ogrid(x(i),y(m)) <= r_int_outer) then
df(i,m,n,:)=0.
endif
enddo
!
endsubroutine freeze_solid_cells
!***********************************************************************
function in_solid_cell(part_pos,part_rad)
!
! Check if the position px,py,pz is within a solid cylinder
!
! 14-feb-17/Jorgen: coded
!
logical :: in_solid_cell
real, dimension(:), intent(in) :: part_pos
real, intent(in) :: part_rad
real :: r_solid_par
!
in_solid_cell = .false.
!
r_solid_par = radius_ogrid(part_pos(1),part_pos(2))
if (r_solid_par<=(xyz0_ogrid(1)+part_rad)) then
in_solid_cell=.true.
endif
!
endfunction in_solid_cell
!***********************************************************************
subroutine pencil_criteria_solid_cells()
!
! Dummy routine
!
endsubroutine pencil_criteria_solid_cells
!***********************************************************************
subroutine solid_cells_clean_up
!
! Dummy routine
!
endsubroutine solid_cells_clean_up
!***********************************************************************
subroutine communicate_ip_cart_to_curv(f_cartesian,ivar1,ivar2)
!
! Send and recieve necessary information to perform interpolation from
! the cartesian to the curvilinear grid.
!
! apr-17/Jorgen: Coded
!
use Mpicomm, only: mpisend_int,mpisend_real,mpirecv_int,mpirecv_real
real, dimension(mx,my,mz,mfarray), intent(in) :: f_cartesian
integer, intent(in) :: ivar1,ivar2
integer, dimension(5) :: nbuf_farr
integer, dimension(max_recv_ip_cart_to_curv) :: id_bufi
real, dimension(inter_len,inter_len,inter_len,ivar2-ivar1+1,max_send_ip_cart_to_curv) :: f_bufo
real, dimension(inter_len,inter_len,inter_len,ivar2-ivar1+1,max_recv_ip_cart_to_curv) :: f_bufi
real, dimension(inter_len,inter_len,inter_len,ivar2-ivar1+1) :: farr
integer :: i,j,k,id,ipq
integer :: ii1,ii2,jj1,jj2,kk1,kk2
integer :: iter, send_to, recv_from
integer, dimension(3) :: inear_loc
integer :: ind_send_first, ind_send_last
integer, dimension(max_send_ip_cart_to_curv) :: ip_bufo
integer :: ind, ipoly
integer :: ipp_int=0, iRR_int=0
!
if (interpolation_method==1) then
nbuf_farr(1:3)=2
ii1=0; ii2=1; jj1=0; jj2=1; kk1=0; kk2=1
elseif (interpolation_method==3) then
nbuf_farr(1:3)=3
ii1=1; ii2=1; jj1=1; jj2=1; kk1=1; kk2=1
elseif (interpolation_method==5) then
nbuf_farr(1:3)=interpol_order_poly
ipoly=floor((interpol_order_poly)*0.5)
ii1=ipoly; ii2=ipoly; jj1=ipoly; jj2=ipoly; kk1=ipoly; kk2=ipoly
elseif (mod(interpolation_method,2)==0) then
nbuf_farr(1:3)=interpolation_method+1
ii1=interpolation_method/2; ii2=ii1; jj1=ii1; jj2=ii1; kk1=ii1; kk2=ii1
endif
nbuf_farr(4)=ivar2-ivar1+1
!
if (lchemistry .and. linterp_pressure) then
ipp_int = mvar-ivar1+2
iRR_int = mvar-ivar1+3
endif
!
! Send to processors with proc > iproc
!
ind_send_first=1
do iter=1,n_procs_send_cart_to_curv
ind_send_last=n_ip_to_proc_cart_to_curv(iter)+ind_send_first-1
send_to=send_cartesian_to_curvilinear(ind_send_last)%send_to_proc
if (send_to>iproc) then
nbuf_farr(5)=ind_send_last-ind_send_first+1
do ipq=1,nbuf_farr(5)
ind=ind_send_first+ipq-1
i=send_cartesian_to_curvilinear(ind)%i_near_neighbour(1)
j=send_cartesian_to_curvilinear(ind)%i_near_neighbour(2)
k=send_cartesian_to_curvilinear(ind)%i_near_neighbour(3)
if (lchemistry .and. linterp_pressure) then
f_bufo(:,:,:,ipp_int,ipq)=f_cartesian(i-ii1:i+ii2,j-jj1:j+jj2,k-kk1:k+kk2,ipp)
f_bufo(:,:,:,iRR_int,ipq)=f_cartesian(i-ii1:i+ii2,j-jj1:j+jj2,k-kk1:k+kk2,iRR)
endif
f_bufo(:,:,:,ivar1:mvar,ipq)=f_cartesian(i-ii1:i+ii2,j-jj1:j+jj2,k-kk1:k+kk2,ivar1:mvar)
enddo
ip_bufo(1:nbuf_farr(5)) = send_cartesian_to_curvilinear(ind_send_first:ind_send_last)%ip_id
call mpisend_int(ip_bufo(1:nbuf_farr(5)),nbuf_farr(5),send_to,send_to)
call mpisend_real(f_bufo(:,:,:,:,1:nbuf_farr(5)),nbuf_farr,send_to,send_to+ncpus)
endif
ind_send_first=ind_send_last+1
enddo
!
! Recieve from processors with proc < iproc
!
do iter=n_procs_recv_cart_to_curv,1,-1
recv_from=procs_recv_cart_to_curv(iter)
if (recv_from<iproc) then
nbuf_farr(5)=n_ip_recv_proc_cart_to_curv(iter)
call mpirecv_int(id_bufi(1:nbuf_farr(5)),nbuf_farr(5),recv_from,iproc)
call mpirecv_real(f_bufi(:,:,:,:,1:nbuf_farr(5)),nbuf_farr,recv_from,iproc+ncpus)
do ipq=1,nbuf_farr(5)
farr = f_bufi(:,:,:,:,ipq)
call interpolate_point_cart_to_curv(id_bufi(ipq),ivar1,ivar2,farr,f_cartesian,ipp_int,iRR_int)
enddo
endif
enddo
!
! Send to processors with proc < iproc
!
ind_send_first=1
do iter=1,n_procs_send_cart_to_curv
ind_send_last=n_ip_to_proc_cart_to_curv(iter)+ind_send_first-1
send_to=send_cartesian_to_curvilinear(ind_send_last)%send_to_proc
if (send_to<iproc) then
nbuf_farr(5)=ind_send_last-ind_send_first+1
do ipq=1,nbuf_farr(5)
ind=ind_send_first+ipq-1
i=send_cartesian_to_curvilinear(ind)%i_near_neighbour(1)
j=send_cartesian_to_curvilinear(ind)%i_near_neighbour(2)
k=send_cartesian_to_curvilinear(ind)%i_near_neighbour(3)
if (lchemistry .and. linterp_pressure) then
f_bufo(:,:,:,ipp_int,ipq)=f_cartesian(i-ii1:i+ii2,j-jj1:j+jj2,k-kk1:k+kk2,ipp)
f_bufo(:,:,:,iRR_int,ipq)=f_cartesian(i-ii1:i+ii2,j-jj1:j+jj2,k-kk1:k+kk2,iRR)
endif
f_bufo(:,:,:,ivar1:mvar,ipq)=f_cartesian(i-ii1:i+ii2,j-jj1:j+jj2,k-kk1:k+kk2,ivar1:mvar)
enddo
ip_bufo(1:nbuf_farr(5)) = send_cartesian_to_curvilinear(ind_send_first:ind_send_last)%ip_id
call mpisend_int(ip_bufo(1:nbuf_farr(5)),nbuf_farr(5),send_to,send_to)
call mpisend_real(f_bufo(:,:,:,:,1:nbuf_farr(5)),nbuf_farr,send_to,send_to+ncpus)
endif
ind_send_first=ind_send_last+1
enddo
!
! Recieve from processors with proc > iproc
!
do iter=n_procs_recv_cart_to_curv,1,-1
recv_from=procs_recv_cart_to_curv(iter)
if (recv_from>iproc) then
nbuf_farr(5)=n_ip_recv_proc_cart_to_curv(iter)
call mpirecv_int(id_bufi(1:nbuf_farr(5)),nbuf_farr(5),recv_from,iproc)
call mpirecv_real(f_bufi(:,:,:,:,1:nbuf_farr(5)),nbuf_farr,recv_from,iproc+ncpus)
do ipq=1,nbuf_farr(5)
farr = f_bufi(:,:,:,:,ipq)
call interpolate_point_cart_to_curv(id_bufi(ipq),ivar1,ivar2,farr,f_cartesian,ipp_int,iRR_int)
enddo
endif
enddo
!
! Interpolate remaining points
!
do id=1,n_ip_cart_to_curv
if (cartesian_to_curvilinear(id)%from_proc==iproc) then
inear_loc=cartesian_to_curvilinear(id)%ind_local_neighbour
if (lchemistry .and. linterp_pressure) then
farr(:,:,:,ipp_int)=f_cartesian(inear_loc(1)-ii1:inear_loc(1)+ii2, &
inear_loc(2)-jj1:inear_loc(2)+jj2,inear_loc(3)-kk1:inear_loc(3)+kk2,ipp)
farr(:,:,:,iRR_int)=f_cartesian(inear_loc(1)-ii1:inear_loc(1)+ii2, &
inear_loc(2)-jj1:inear_loc(2)+jj2,inear_loc(3)-kk1:inear_loc(3)+kk2,iRR)
endif
farr(:,:,:,ivar1:mvar)=f_cartesian(inear_loc(1)-ii1:inear_loc(1)+ii2, &
inear_loc(2)-jj1:inear_loc(2)+jj2,inear_loc(3)-kk1:inear_loc(3)+kk2,ivar1:mvar)
call interpolate_point_cart_to_curv(id,ivar1,ivar2,farr,f_cartesian,ipp_int,iRR_int)
endif
enddo
!
endsubroutine communicate_ip_cart_to_curv
!***********************************************************************
subroutine communicate_ip_curv_to_cart(f_cartesian,ivar1,ivar2)
!
! Send and recieve necessary information to perform interpolation from
! the curvilinear to the cartesian grid.
!
! apr-17/Jorgen: Coded
!
use Mpicomm, only: mpisend_int,mpisend_real,mpirecv_int,mpirecv_real
use EquationOfState, only: lpres_grad
real, dimension(mx,my,mz,mfarray), intent(inout) :: f_cartesian
integer, intent(in) :: ivar1,ivar2
integer, dimension(5) :: nbuf_farr
integer, dimension(max_recv_ip_curv_to_cart) :: id_bufi
real, dimension(inter_len,inter_len,inter_len,ivar2-ivar1+1,max_send_ip_curv_to_cart) :: f_bufo
real, dimension(inter_len,inter_len,inter_len,ivar2-ivar1+1,max_recv_ip_curv_to_cart) :: f_bufi
real, dimension(inter_len,inter_len,inter_len,ivar2-ivar1+1) :: farr
integer :: i,j,k,id,ipq
integer :: ii1,ii2,jj1,jj2,kk1,kk2
integer :: iter, send_to, recv_from
integer, dimension(3) :: inear_loc
integer :: ind_send_first, ind_send_last
integer, dimension(max_send_ip_curv_to_cart) :: ip_bufo
integer :: ind, ipoly
integer :: igpx_int=0, igpy_int=0, ipp_int=0, iRR_int=0
!
if (interpolation_method==1) then
nbuf_farr(1:3)=2
ii1=0; ii2=1; jj1=0; jj2=1; kk1=0; kk2=1
elseif (interpolation_method==3) then
nbuf_farr(1:3)=3
ii1=1; ii2=1; jj1=1; jj2=1; kk1=1; kk2=1
elseif (interpolation_method==5) then
nbuf_farr(1:3)=interpol_order_poly
ipoly=floor((interpol_order_poly)*0.5)
ii1=ipoly; ii2=ipoly; jj1=ipoly; jj2=ipoly; kk1=ipoly; kk2=ipoly
elseif (mod(interpolation_method,2)==0) then
nbuf_farr(1:3)=interpolation_method+1
ii1=interpolation_method/2; ii2=ii1; jj1=ii1; jj2=ii1; kk1=ii1; kk2=ii1
endif
nbuf_farr(4)=ivar2-ivar1+1
!
if (lpres_grad .and. (lchemistry .and. linterp_pressure)) then
igpx_int = mvar-ivar1+2
igpy_int = mvar-ivar1+3
ipp_int = mvar-ivar1+4
iRR_int = mvar-ivar1+5
elseif (lpres_grad) then
igpx_int = mvar-ivar1+2
igpy_int = mvar-ivar1+3
elseif (lchemistry .and. linterp_pressure) then
ipp_int = mvar-ivar1+2
iRR_int = mvar-ivar1+3
endif
!
! Send to proc > iproc
!
ind_send_first=1
do iter=1,n_procs_send_curv_to_cart
ind_send_last=n_ip_to_proc_curv_to_cart(iter)+ind_send_first-1
send_to=send_curvilinear_to_cartesian(ind_send_last)%send_to_proc
if (send_to>iproc) then
nbuf_farr(5)=ind_send_last-ind_send_first+1
do ipq=1,nbuf_farr(5)
ind=ind_send_first+ipq-1
i=send_curvilinear_to_cartesian(ind)%i_near_neighbour(1)
j=send_curvilinear_to_cartesian(ind)%i_near_neighbour(2)
k=send_curvilinear_to_cartesian(ind)%i_near_neighbour(3)
if (lpres_grad) then
f_bufo(:,:,:,igpx_int,ipq)=f_ogrid(i-ii1:i+ii2,j-jj1:j+jj2,k-kk1:k+kk2,igpx)
f_bufo(:,:,:,igpy_int,ipq)=f_ogrid(i-ii1:i+ii2,j-jj1:j+jj2,k-kk1:k+kk2,igpy)
endif
if (lchemistry .and. linterp_pressure) then
f_bufo(:,:,:,ipp_int,ipq)=f_ogrid(i-ii1:i+ii2,j-jj1:j+jj2,k-kk1:k+kk2,ipp)
f_bufo(:,:,:,iRR_int,ipq)=f_ogrid(i-ii1:i+ii2,j-jj1:j+jj2,k-kk1:k+kk2,iRR)
endif
f_bufo(:,:,:,ivar1:mvar,ipq)=f_ogrid(i-ii1:i+ii2,j-jj1:j+jj2,k-kk1:k+kk2,ivar1:mvar)
enddo
ip_bufo(1:nbuf_farr(5)) = send_curvilinear_to_cartesian(ind_send_first:ind_send_last)%ip_id
call mpisend_int(ip_bufo(1:nbuf_farr(5)),nbuf_farr(5),send_to,send_to)
call mpisend_real(f_bufo(:,:,:,:,1:nbuf_farr(5)),nbuf_farr,send_to,send_to+ncpus)
endif
ind_send_first=ind_send_last+1
enddo
!
! Recieve from proc < iproc
!
do iter=n_procs_recv_curv_to_cart,1,-1
recv_from=procs_recv_curv_to_cart(iter)
if (recv_from<iproc) then
nbuf_farr(5)=n_ip_recv_proc_curv_to_cart(iter)
call mpirecv_int(id_bufi(1:nbuf_farr(5)),nbuf_farr(5),recv_from,iproc)
call mpirecv_real(f_bufi(:,:,:,:,1:nbuf_farr(5)),nbuf_farr,recv_from,iproc+ncpus)
do ipq=1,nbuf_farr(5)
farr = f_bufi(:,:,:,:,ipq)
call interpolate_point_curv_to_cart(f_cartesian,id_bufi(ipq),ivar1,ivar2,farr,&
igpx_int,igpy_int,ipp_int,iRR_int)
enddo
endif
enddo
!
! Send to proc < iproc
!
ind_send_first=1
do iter=1,n_procs_send_curv_to_cart
ind_send_last=n_ip_to_proc_curv_to_cart(iter)+ind_send_first-1
send_to=send_curvilinear_to_cartesian(ind_send_last)%send_to_proc
if (send_to<iproc) then
nbuf_farr(5)=ind_send_last-ind_send_first+1
do ipq=1,nbuf_farr(5)
ind=ind_send_first+ipq-1
i=send_curvilinear_to_cartesian(ind)%i_near_neighbour(1)
j=send_curvilinear_to_cartesian(ind)%i_near_neighbour(2)
k=send_curvilinear_to_cartesian(ind)%i_near_neighbour(3)
if (lpres_grad) then
f_bufo(:,:,:,igpx_int,ipq)=f_ogrid(i-ii1:i+ii2,j-jj1:j+jj2,k-kk1:k+kk2,igpx)
f_bufo(:,:,:,igpy_int,ipq)=f_ogrid(i-ii1:i+ii2,j-jj1:j+jj2,k-kk1:k+kk2,igpy)
endif
if (lchemistry .and. linterp_pressure) then
f_bufo(:,:,:,ipp_int,ipq)=f_ogrid(i-ii1:i+ii2,j-jj1:j+jj2,k-kk1:k+kk2,ipp)
f_bufo(:,:,:,iRR_int,ipq)=f_ogrid(i-ii1:i+ii2,j-jj1:j+jj2,k-kk1:k+kk2,iRR)
endif
f_bufo(:,:,:,ivar1:mvar,ipq)=f_ogrid(i-ii1:i+ii2,j-jj1:j+jj2,k-kk1:k+kk2,ivar1:mvar)
enddo
ip_bufo(1:nbuf_farr(5)) = send_curvilinear_to_cartesian(ind_send_first:ind_send_last)%ip_id
call mpisend_int(ip_bufo(1:nbuf_farr(5)),nbuf_farr(5),send_to,send_to)
call mpisend_real(f_bufo(:,:,:,:,1:nbuf_farr(5)),nbuf_farr,send_to,send_to+ncpus)
endif
ind_send_first=ind_send_last+1
enddo
!
! Recieve from proc > iproc
!
do iter=n_procs_recv_curv_to_cart,1,-1
recv_from=procs_recv_curv_to_cart(iter)
if (recv_from>iproc) then
nbuf_farr(5)=n_ip_recv_proc_curv_to_cart(iter)
call mpirecv_int(id_bufi(1:nbuf_farr(5)),nbuf_farr(5),recv_from,iproc)
call mpirecv_real(f_bufi(:,:,:,:,1:nbuf_farr(5)),nbuf_farr,recv_from,iproc+ncpus)
do ipq=1,nbuf_farr(5)
farr = f_bufi(:,:,:,:,ipq)
call interpolate_point_curv_to_cart(f_cartesian,id_bufi(ipq),ivar1,ivar2,farr,&
igpx_int,igpy_int,ipp_int,iRR_int)
enddo
endif
enddo
!
! Interpolate remaining points
!
if (lvideo .and. lwrite_slices) then
do id=1,n_ip_curv_to_cart
! TODO: Make more efficient
if (curvilinear_to_cartesian(id)%from_proc==iproc) then
inear_loc=curvilinear_to_cartesian(id)%ind_local_neighbour
if (lpres_grad) then
farr(:,:,:,igpx_int)=f_ogrid(inear_loc(1)-ii1:inear_loc(1)+ii2, &
inear_loc(2)-jj1:inear_loc(2)+jj2,inear_loc(3)-kk1:inear_loc(3)+kk2,igpx)
farr(:,:,:,igpy_int)=f_ogrid(inear_loc(1)-ii1:inear_loc(1)+ii2, &
inear_loc(2)-jj1:inear_loc(2)+jj2,inear_loc(3)-kk1:inear_loc(3)+kk2,igpy)
endif
if (lchemistry .and. linterp_pressure) then
farr(:,:,:,ipp_int)=f_ogrid(inear_loc(1)-ii1:inear_loc(1)+ii2, &
inear_loc(2)-jj1:inear_loc(2)+jj2,inear_loc(3)-kk1:inear_loc(3)+kk2,ipp)
farr(:,:,:,iRR_int)=f_ogrid(inear_loc(1)-ii1:inear_loc(1)+ii2, &
inear_loc(2)-jj1:inear_loc(2)+jj2,inear_loc(3)-kk1:inear_loc(3)+kk2,iRR)
endif
farr(:,:,:,ivar1:mvar)=f_ogrid(inear_loc(1)-ii1:inear_loc(1)+ii2, &
inear_loc(2)-jj1:inear_loc(2)+jj2,inear_loc(3)-kk1:inear_loc(3)+kk2,ivar1:mvar)
call interpolate_point_curv_to_cart(f_cartesian,id,ivar1,ivar2,farr,&
igpx_int,igpy_int,ipp_int,iRR_int)
endif
enddo
else
do id=1,interpol_max
if (curvilinear_to_cartesian(id)%from_proc==iproc) then
inear_loc=curvilinear_to_cartesian(id)%ind_local_neighbour
if (lpres_grad) then
farr(:,:,:,igpx_int)=f_ogrid(inear_loc(1)-ii1:inear_loc(1)+ii2, &
inear_loc(2)-jj1:inear_loc(2)+jj2,inear_loc(3)-kk1:inear_loc(3)+kk2,igpx)
farr(:,:,:,igpy_int)=f_ogrid(inear_loc(1)-ii1:inear_loc(1)+ii2, &
inear_loc(2)-jj1:inear_loc(2)+jj2,inear_loc(3)-kk1:inear_loc(3)+kk2,igpy)
endif
if (lchemistry .and. linterp_pressure) then
farr(:,:,:,ipp_int)=f_ogrid(inear_loc(1)-ii1:inear_loc(1)+ii2, &
inear_loc(2)-jj1:inear_loc(2)+jj2,inear_loc(3)-kk1:inear_loc(3)+kk2,ipp)
farr(:,:,:,iRR_int)=f_ogrid(inear_loc(1)-ii1:inear_loc(1)+ii2, &
inear_loc(2)-jj1:inear_loc(2)+jj2,inear_loc(3)-kk1:inear_loc(3)+kk2,iRR)
endif
farr(:,:,:,ivar1:mvar)=f_ogrid(inear_loc(1)-ii1:inear_loc(1)+ii2, &
inear_loc(2)-jj1:inear_loc(2)+jj2,inear_loc(3)-kk1:inear_loc(3)+kk2,ivar1:mvar)
call interpolate_point_curv_to_cart(f_cartesian,id,ivar1,ivar2,farr,&
igpx_int,igpy_int,ipp_int,iRR_int)
endif
enddo
endif
!
endsubroutine communicate_ip_curv_to_cart
!***********************************************************************
!***********************************************************************
subroutine interpolate_point_cart_to_curv(id,ivar1,ivar2,farr,f_cartesian,ipp_int,iRR_int)
!
real, dimension(mx,my,mz,mfarray), intent(in) :: f_cartesian
!
! Use linear interpolation routine to interpolate the values on the cartesian
! grid to the interpolation point on the curvilinear grid
!
integer, intent(in) :: id,ivar1,ivar2
real, dimension(inter_len,inter_len,inter_len,ivar2-ivar1+1), intent(in) :: farr
integer :: i,j,k
real, dimension(3) :: xyz_ip
integer, dimension(3) :: inear_glob
real, dimension(ivar2-ivar1+1) :: f_ip
integer :: ii,jj,kk
! real :: cv1
integer, intent(in) :: ipp_int,iRR_int
!
xyz_ip=cartesian_to_curvilinear(id)%xyz
inear_glob=cartesian_to_curvilinear(id)%ind_global_neighbour
!
! Perform interpolation on cartesian grid
!
if (interpolation_method==1) then
if (.not. linear_interpolate_cartesian(farr,ivar1,ivar2,xyz_ip,inear_glob,f_ip,lcheck_interpolation)) then
call fatal_error('linear_interpolate_cartesian','interpolation from cartesian to curvilinear')
endif
elseif (mod(interpolation_method,2)==0) then
if (.not. interp_lagrange(farr,ivar1,ivar2,xyz_ip,inear_glob,f_ip,.true.,.false.,lcheck_interpolation)) then
call fatal_error('interp_lagrange','interpolation from cartesian to curvilinear')
endif
elseif (interpolation_method==3) then
call interpolate_quadratic_spline(farr,ivar1,ivar2,xyz_ip,f_ip,inear_glob)
!call interpolate_quadratic_spline(farr(:,:,:,iux:iuz),iux,iuz,xyz_ip,f_ip(iux:iuz),inear_glob)
! Adjust coordinates, if necessary
if (xglobal(inear_glob(1))>xyz_ip(1)) then
inear_glob(1) = inear_glob(1)-1
ii=1
else
ii=2
endif
if (yglobal(inear_glob(2))>xyz_ip(2)) then
inear_glob(2) = inear_glob(2)-1
jj=1
else
jj=2
endif
if (zglobal(inear_glob(3))>xyz_ip(3)) then
kk=1
inear_glob(3) = inear_glob(3)-1
else
kk=2
endif
if (.not. linear_interpolate_cartesian(farr(ii:ii+1,jj:jj+1,2:3,4),4,4, &
xyz_ip,inear_glob,f_ip(irho),lcheck_interpolation)) then
call fatal_error('linear_interpolate_cartesian','interpolation from cartesian to curvilinear')
endif
elseif (interpolation_method==5) then
call poly_interp_cart(ivar1,ivar2,xyz_ip,f_ip,id,f_cartesian,interpol_order_poly)
endif
!
! Update curvilinear grid with the new data values
!
i=cartesian_to_curvilinear(id)%i_xyz(1)
j=cartesian_to_curvilinear(id)%i_xyz(2)
k=cartesian_to_curvilinear(id)%i_xyz(3)
f_ogrid(i,j,k,iux) = f_ip(iux)*cos(y_ogrid(j)) + f_ip(iuy)*sin(y_ogrid(j))
f_ogrid(i,j,k,iuy) = -f_ip(iux)*sin(y_ogrid(j)) + f_ip(iuy)*cos(y_ogrid(j))
f_ogrid(i,j,k,iuz:ivar2) = f_ip(iuz:mvar)
if (lchemistry .and. linterp_pressure) then
f_ogrid(i,j,k,ipp)=f_ip(ipp_int)
f_ogrid(i,j,k,iRR)=f_ip(iRR_int)
endif
!
! If pressure is interpolated, recover temperature field from eos
!
if (lchemistry .and. linterp_pressure) then
f_ogrid(i,j,k,iTT)=f_ip(ipp_int)/(f_ip(irho)*f_ip(iRR_int))
! does not work when no chemistry
! call get_cv1(cv1)
! f_ogrid(i,j,k,iTT)=f_ip(ipp_int)*cv1/(f_ip(irho)*gamma_m1)
endif
!
endsubroutine interpolate_point_cart_to_curv
!!***********************************************************************
subroutine interpolate_point_curv_to_cart(f_cartesian,id,ivar1,ivar2,farr,igpx_int,igpy_int,ipp_int,iRR_int)
!
! Use linear interpolation routine to interpolate the values on the cartesian
! grid to the interpolation point on the curvilinear grid
!
use EquationOfState, only: lpres_grad
! use Energy, only: lpres_grad
!
real, dimension (mx,my,mz,mfarray), intent(inout) :: f_cartesian
integer, intent(in) :: id,ivar1,ivar2
real, dimension(inter_len,inter_len,inter_len,ivar2-ivar1+1), intent(in) :: farr
integer :: i,j,k
real, dimension(3) :: xyz_ip
integer, dimension(3) :: inear_glob
real, dimension(ivar2-ivar1+1) :: f_ip
integer :: ii,jj,kk
! real :: cv1
integer :: igpx_int,igpy_int,ipp_int,iRR_int
!
xyz_ip=curvilinear_to_cartesian(id)%xyz
inear_glob=curvilinear_to_cartesian(id)%ind_global_neighbour
!
if (interpolation_method==1) then
if (.not. linear_interpolate_curvilinear(farr,ivar1,ivar2,xyz_ip,inear_glob,f_ip,lcheck_interpolation)) then
call fatal_error('linear_interpolate_curvilinear','interpolation from curvilinear to cartesian')
endif
elseif (mod(interpolation_method,2)==0) then
if (.not. interp_lagrange(farr,ivar1,ivar2,xyz_ip,inear_glob,f_ip,.false.,.true.,lcheck_interpolation)) then
call fatal_error('interp_lagrange','interpolation from curvilinear to cartesian')
endif
elseif (interpolation_method==3) then
call interpolate_quadratic_sp_og(farr,ivar1,ivar2,xyz_ip,f_ip,inear_glob)
!call interpolate_quadratic_sp_og(farr(:,:,:,iux:iuz),iux,iuz,xyz_ip,f_ip(iux:iuz),inear_glob)
! Adjust coordinates, if necessary
if (xglobal_ogrid(inear_glob(1))>xyz_ip(1)) then
inear_glob(1) = inear_glob(1)-1
ii=1
else
ii=2
endif
if (yglobal_ogrid(inear_glob(2))>xyz_ip(2)) then
inear_glob(2) = inear_glob(2)-1
jj=1
else
jj=2
endif
if (zglobal_ogrid(inear_glob(3))>xyz_ip(3)) then
inear_glob(3) = inear_glob(3)-1
kk=1
else
kk=2
endif
if (.not. linear_interpolate_curvilinear(farr(ii:ii+1,jj:jj+1,kk:kk+1,irho),irho,irho,&
xyz_ip,inear_glob,f_ip(irho),lcheck_interpolation)) then
call fatal_error('linear_interpolate_curvilinear','interpolation from curvilinear to cartesian ')
endif
elseif (interpolation_method==5) then
if (xyz_ip(1)>=r_int_inner_poly) then
call poly_interp_curv(ivar1,ivar2,xyz_ip,f_ip,id,interpol_order_poly)
else
!
! Use linear inteprolation if too near surface to use high order polynomial
! Preliminary solution to get inear_glob to point to bottom left corner of cell
!
ii=floor(interpol_order_poly*0.5)
jj=floor(interpol_order_poly*0.5)
if (xyz_ip(1)<xglobal_ogrid(inear_glob(1))) then
if (xyz_ip(2)<yglobal_ogrid(inear_glob(2))) then
if (.not. linear_interpolate_curvilinear(farr(ii-1:ii,ii-1:ii,ii:ii+1,:),iux,irho,&
xyz_ip,(/inear_glob(1)-1,inear_glob(2)-1,inear_glob(3)/),f_ip,lcheck_interpolation)) then
call fatal_error('linear_interpolate_curvilinear','interpolation from curvilinear to cartesian ')
endif
else
if (.not. linear_interpolate_curvilinear(farr(ii-1:ii,ii:ii+1,ii:ii+1,:),iux,irho,&
xyz_ip,(/inear_glob(1)-1,inear_glob(2),inear_glob(3)/),f_ip,lcheck_interpolation)) then
call fatal_error('linear_interpolate_curvilinear','interpolation from curvilinear to cartesian ')
endif
endif
else
if (xyz_ip(2)<yglobal_ogrid(inear_glob(2))) then
if (.not. linear_interpolate_curvilinear(farr(ii:ii+1,ii-1:ii,ii:ii+1,:),iux,irho,&
xyz_ip,(/inear_glob(1),inear_glob(2)-1,inear_glob(3)/),f_ip,lcheck_interpolation)) then
call fatal_error('linear_interpolate_curvilinear','interpolation from curvilinear to cartesian ')
endif
else
if (.not. linear_interpolate_curvilinear(farr(ii:ii+1,ii:ii+1,ii:ii+1,:),iux,irho,&
xyz_ip,(/inear_glob(1),inear_glob(2),inear_glob(3)/),f_ip,lcheck_interpolation)) then
call fatal_error('linear_interpolate_curvilinear','interpolation from curvilinear to cartesian ')
endif
endif
endif
endif
endif
!
! Update cartesian grid with the new data values
!
i=curvilinear_to_cartesian(id)%i_xyz(1)
j=curvilinear_to_cartesian(id)%i_xyz(2)
k=curvilinear_to_cartesian(id)%i_xyz(3)
f_cartesian(i,j,k,iux)=f_ip(iux)*cos(xyz_ip(2))-f_ip(iuy)*sin(xyz_ip(2))
f_cartesian(i,j,k,iuy)=f_ip(iux)*sin(xyz_ip(2))+f_ip(iuy)*cos(xyz_ip(2))
if (lchemistry .and. linterp_pressure) then
f_cartesian(i,j,k,ipp)=f_ip(ipp_int)
f_cartesian(i,j,k,iRR)=f_ip(iRR_int)
endif
if (lpres_grad) then
f_cartesian(i,j,k,igpx)=f_ip(igpx_int)*cos(xyz_ip(2))-f_ip(igpy_int)*sin(xyz_ip(2))
f_cartesian(i,j,k,igpy)=f_ip(igpx_int)*sin(xyz_ip(2))+f_ip(igpy_int)*cos(xyz_ip(2))
endif
f_cartesian(i,j,k,iuz:mvar)=f_ip(iuz:mvar)
!
! If pressure is interpolated, recover temperature field from eos
!
if (lchemistry .and. linterp_pressure) then
f_cartesian(i,j,k,iTT)=f_ip(ipp_int)/(f_ip(irho)*f_ip(iRR_int))
! does not work when no chemistry
! call get_cv1(cv1)
! f_cartesian(i,j,k,iTT)=f_ip(ipp_int)*cv1/(f_ip(irho)*gamma_m1)
endif
!
endsubroutine interpolate_point_curv_to_cart
!***********************************************************************
subroutine interp_point_curv_to_cart_alt(xyz_ip,inear_glob,ivar1,ivar2,farr,f_ip)
!
! Use linear interpolation routine to interpolate the values on the curvilinear
! grid to the interpolation point on the cartesian grid
!
real, dimension(3), intent(in) :: xyz_ip
integer, dimension(3), intent(in) :: inear_glob
integer, intent(in) :: ivar1,ivar2
real, dimension(inter_len,inter_len,inter_len,ivar2-ivar1+1), intent(in) :: farr
real, dimension(ivar2-ivar1+1), intent(out) :: f_ip
!
if (interpolation_method==1) then
if (.not. linear_interpolate_curvilinear(farr,ivar1,ivar2,xyz_ip,inear_glob,f_ip,lcheck_interpolation)) then
call fatal_error('linear_interpolate_curvilinear','interpolation from curvilinear to cartesian')
endif
elseif (interpolation_method==3) then
call interpolate_quadratic_sp_og(farr,ivar1,ivar2,xyz_ip,f_ip,inear_glob)
elseif (mod(interpolation_method,2)==0) then
if (.not. interp_lagrange(farr,ivar1,ivar2,xyz_ip,inear_glob,f_ip,.false.,.true.,lcheck_interpolation)) then
call fatal_error('interp_lagrange','interpolation from curvilinear to cartesian')
endif
endif
!
endsubroutine interp_point_curv_to_cart_alt
!***********************************************************************
subroutine transform_curv_to_cart(f_ip,f_cartesian,id,ivar1,ivar2)
!
! Update curvilinear grid with the new data values
!
! 02-okt-17/Jorgen: Coded
!
real, dimension (mx,my,mz,mfarray), intent(inout) :: f_cartesian
integer, intent(in) :: id,ivar1,ivar2
real, dimension(ivar2-ivar1+1), intent(in) :: f_ip
integer :: i,j,k
real, dimension(3) :: xyz_ip
xyz_ip=curvilinear_to_cartesian(id)%xyz
i=curvilinear_to_cartesian(id)%i_xyz(1)
j=curvilinear_to_cartesian(id)%i_xyz(2)
k=curvilinear_to_cartesian(id)%i_xyz(3)
f_cartesian(i,j,k,iux)=f_ip(iux)*cos(xyz_ip(2))-f_ip(iuy)*sin(xyz_ip(2))
f_cartesian(i,j,k,iuy)=f_ip(iux)*sin(xyz_ip(2))+f_ip(iuy)*cos(xyz_ip(2))
f_cartesian(i,j,k,iuz:ivar2)=f_ip(iuz:ivar2)
!
endsubroutine transform_curv_to_cart
!!***********************************************************************
logical function linear_interpolate_ogrid(ivar1,ivar2,rthz,gp,inear,lcheck)
!
! Interpolate the value of g to arbitrary (xp, yp, zp) coordinate on the ogrid
! using the linear interpolation formula
!
! g(x,y,z) = A*x*y*z + B*x*y + C*x*z + D*y*z + E*x + F*y + G*z + H .
!
! The coefficients are determined by the 8 grid points surrounding the
! interpolation point.
!
! 21-feb-17/Jorgen: Adapted from general.f90
!
use Cdata
!
integer :: ivar1, ivar2
real, dimension (3) :: rthz
real, dimension (ivar2-ivar1+1) :: gp
integer, dimension (3) :: inear
!
real, dimension (ivar2-ivar1+1) :: g1, g2, g3, g4, g5, g6, g7, g8
real :: rp0, thp0, zp0
real, save :: dxdydz1, dxdy1, dxdz1, dydz1, dx1, dy1, dz1
integer :: i, ix0, iy0, iz0
logical :: lfirstcall=.true.,lcheck
!
intent(in) :: rthz, ivar1, ivar2, lcheck
intent(out) :: gp
!
! Determine index value of lowest lying corner point of grid box surrounding
! the interpolation point.
!
linear_interpolate_ogrid = .true.
!
ix0=inear(1); iy0=inear(2); iz0=inear(3)
if ( (x_ogrid(ix0)>rthz(1)) .and. nxgrid_ogrid/=1) ix0=ix0-1
if ( (y_ogrid(iy0)>rthz(2)) .and. nygrid_ogrid/=1) iy0=iy0-1
if ( (z_ogrid(iz0)>rthz(3)) .and. nzgrid_ogrid/=1) iz0=iz0-1
!
! Check if the grid point interval is really correct.
!
if ((x_ogrid(ix0)<=rthz(1) .and. x_ogrid(ix0+1)>=rthz(1) .or. nxgrid_ogrid==1) .and. &
(y_ogrid(iy0)<=rthz(2) .and. y_ogrid(iy0+1)>=rthz(2) .or. nygrid_ogrid==1) .and. &
(z_ogrid(iz0)<=rthz(3) .and. z_ogrid(iz0+1)>=rthz(3) .or. nzgrid_ogrid==1)) then
! Everything okay
else
print*, 'linear_interpolate_ogrid: Interpolation point does not ' // &
'lie within the calculated grid point interval.'
print*, 'iproc = ', iproc_world
print*, 'mx_ogrid, x_ogrid(1), x_ogrid(mx_ogrid) = ', mx_ogrid, x_ogrid(1), x_ogrid(mx_ogrid)
print*, 'my_ogrid, y_ogrid(1), y_ogrid(my_ogrid) = ', my_ogrid, y_ogrid(1), y_ogrid(my_ogrid)
print*, 'mz_ogrid, z_ogrid(1), z_ogrid(mz_ogrid) = ', mz_ogrid, z_ogrid(1), z_ogrid(mz_ogrid)
print*, 'ix0, iy0, iz0 = ', ix0, iy0, iz0
print*, 'rp, rp0, rp1 = ', rthz(1), x_ogrid(ix0), x_ogrid(ix0+1)
print*, 'thp, thp0, thp1 = ', rthz(2), y_ogrid(iy0), y_ogrid(iy0+1)
print*, 'zp, zp0, zp1 = ', rthz(3), z_ogrid(iz0), z_ogrid(iz0+1)
linear_interpolate_ogrid = .false.
return
endif
!
! Redefine the interpolation point in coordinates relative to lowest corner.
! Set it equal to 0 for dimensions having 1 grid points; this will make sure
! that the interpolation is bilinear for 2D grids.
!
rp0=0; thp0=0; zp0=0
if (nxgrid/=1) rp0=rthz(1)-x_ogrid(ix0)
if (nygrid/=1) thp0=rthz(2)-y_ogrid(iy0)
if (nzgrid/=1) zp0=rthz(3)-z_ogrid(iz0)
!
! Calculate derived grid spacing parameters needed for interpolation.
! For an equidistant grid we only need to do this at the first call.
!
if (lequidist_ogrid(1)) then
if (lfirstcall) dx1=dx_1_ogrid(ix0) !1/dx
else
dx1=1/(x_ogrid(ix0+1)-x_ogrid(ix0))
endif
!
if (lequidist_ogrid(2)) then
if (lfirstcall) dy1=dy_1_ogrid(iy0)
else
dy1=1/(y_ogrid(iy0+1)-y_ogrid(iy0))
endif
!
if (lequidist_ogrid(3)) then
if (lfirstcall) dz1=dz_1_ogrid(iz0)
else
dz1=1/(z_ogrid(iz0+1)-z_ogrid(iz0))
endif
!
if ( (.not. all(lequidist_ogrid)) .or. lfirstcall) then
dxdy1=dx1*dy1; dxdz1=dx1*dz1; dydz1=dy1*dz1
dxdydz1=dx1*dy1*dz1
endif
!
! Function values at all corners.
!
g1=f_ogrid(ix0 ,iy0 ,iz0 ,ivar1:ivar2)
g2=f_ogrid(ix0+1,iy0 ,iz0 ,ivar1:ivar2)
g3=f_ogrid(ix0 ,iy0+1,iz0 ,ivar1:ivar2)
g4=f_ogrid(ix0+1,iy0+1,iz0 ,ivar1:ivar2)
g5=f_ogrid(ix0 ,iy0 ,iz0+1,ivar1:ivar2)
g6=f_ogrid(ix0+1,iy0 ,iz0+1,ivar1:ivar2)
g7=f_ogrid(ix0 ,iy0+1,iz0+1,ivar1:ivar2)
g8=f_ogrid(ix0+1,iy0+1,iz0+1,ivar1:ivar2)
!
! Interpolation formula.
!
gp = g1 + rp0*dx1*(-g1+g2) + thp0*dy1*(-g1+g3) + zp0*dz1*(-g1+g5) + &
rp0*thp0*dxdy1*(g1-g2-g3+g4) + rp0*zp0*dxdz1*(g1-g2-g5+g6) + &
thp0*zp0*dydz1*(g1-g3-g5+g7) + &
rp0*thp0*zp0*dxdydz1*(-g1+g2+g3-g4+g5-g6-g7+g8)
!
! Do a reality check on the interpolation scheme.
!
if (lcheck) then
do i=1,ivar2-ivar1+1
if (gp(i)>max(g1(i),g2(i),g3(i),g4(i),g5(i),g6(i),g7(i),g8(i))) then
print*, 'linear_interpolate_ogrid: interpolated value is LARGER than'
print*, 'linear_interpolate_ogrid: a values at the corner points!'
print*, 'linear_interpolate_ogrid: xxp=', rthz
print*, 'linear_interpolate_ogrid: r0, th0, z0=', &
x_ogrid(ix0), y_ogrid(iy0), z_ogrid(iz0)
print*, 'linear_interpolate_ogrid: r1, th1, z1=', &
x_ogrid(ix0+1), y_ogrid(iy0+1), z_ogrid(iz0+1)
print*, 'linear_interpolate_ogrid: i, gp(i)=', i, gp(i)
print*, 'linear_interpolate_ogrid: g1...g8=', &
g1(i), g2(i), g3(i), g4(i), g5(i), g6(i), g7(i), g8(i)
print*, '------------------'
endif
if (gp(i)<min(g1(i),g2(i),g3(i),g4(i),g5(i),g6(i),g7(i),g8(i))) then
print*, 'linear_interpolate_ogrid: interpolated value is smaller than'
print*, 'linear_interpolate_ogrid: a values at the corner points!'
print*, 'linear_interpolate_ogrid: xxp=', rthz
print*, 'linear_interpolate_ogrid: x0, y0, z0=', &
x_ogrid(ix0), y_ogrid(iy0), z_ogrid(iz0)
print*, 'linear_interpolate_ogrid: r1, th1, z1=', &
x_ogrid(ix0+1), y_ogrid(iy0+1), z_ogrid(iz0+1)
print*, 'linear_interpolate_ogrid: i, gp(i)=', i, gp(i)
print*, 'linear_interpolate_ogrid: g1...g8=', &
g1(i), g2(i), g3(i), g4(i), g5(i), g6(i), g7(i), g8(i)
print*, '------------------'
endif
enddo
endif
!
if (lfirstcall) lfirstcall=.false.
!
endfunction linear_interpolate_ogrid
!***********************************************************************
logical function linear_interpolate_cartesian(farr,ivar1,ivar2,xxp,inear_glob,fp,lcheck)
!
! Interpolate the value of f to arbitrary (xp, yp, zp) coordinate
! using the linear interpolation formula
!
! g(x,y,z) = A*x*y*z + B*x*y + C*x*z + D*y*z + E*x + F*y + G*z + H .
!
! The coefficients are determined by the 8 grid points surrounding the
! interpolation point.
! Global coordinates are used for the interpolation, to allow interpolation of
! values outside this processors domain.
!
! 21-apr-17/Jorgen: Adapted from linear_interpolate in general.f90
!
integer :: ivar1, ivar2
real, dimension (3) :: xxp
real, dimension (2,2,2,ivar2-ivar1+1) :: farr
real, dimension (ivar2-ivar1+1) :: fp
integer, dimension (3) :: inear_glob
logical :: lcheck
!
real, dimension (ivar2-ivar1+1) :: g1, g2, g3, g4, g5, g6, g7, g8
real :: xp0, yp0, zp0
real, save :: dxdydz1, dxdy1, dxdz1, dydz1, dx1, dy1, dz1
logical :: lfirstcall=.true.
integer :: ix0, iy0, iz0, i
integer :: vari2
!
intent(in) :: farr, ivar1, ivar2, xxp, inear_glob, lcheck
intent(out) :: fp
! Set vari2 /= ivar2 to allow for farr with ivar1>1
vari2=ivar2-ivar1+1
!
! Determine index value of lowest lying corner point of grid box surrounding
! the interpolation point.
!
linear_interpolate_cartesian = .true.
!
ix0=inear_glob(1); iy0=inear_glob(2); iz0=inear_glob(3)
!
! Check if the grid point interval is really correct.
!
if ((xglobal(ix0)<=xxp(1) .and. xglobal(ix0+1)>=xxp(1) .or. nxgrid==1) .and. &
(yglobal(iy0)<=xxp(2) .and. yglobal(iy0+1)>=xxp(2) .or. nygrid==1) .and. &
(zglobal(iz0)<=xxp(3) .and. zglobal(iz0+1)>=xxp(3) .or. nzgrid==1)) then
! Everything okay
else
print*, 'linear_interpolate_cartesian: Global interpolation point does not ' // &
'lie within the calculated grid point interval.'
print*, 'iproc = ', iproc_world
print*, 'mxgrid, xglobal(1), xglobal(mx) = ', mxgrid, xglobal(1), xglobal(mxgrid)
print*, 'mygrid, yglobal(1), yglobal(my) = ', mygrid, yglobal(1), yglobal(mygrid)
print*, 'mzgrid, zglobal(1), zglobal(mz) = ', mzgrid, zglobal(1), zglobal(mzgrid)
print*, 'ix0, iy0, iz0 = ', ix0, iy0, iz0
print*, 'xp, xp0, xp1 = ', xxp(1), xglobal(ix0), xglobal(ix0+1)
print*, 'yp, yp0, yp1 = ', xxp(2), yglobal(iy0), yglobal(iy0+1)
print*, 'zp, zp0, zp1 = ', xxp(3), zglobal(iz0), zglobal(iz0+1)
linear_interpolate_cartesian = .false.
return
endif
!
! Redefine the interpolation point in coordinates relative to lowest corner.
! Set it equal to 0 for dimensions having 1 grid points; this will make sure
! that the interpolation is bilinear for 2D grids.
!
xp0=0; yp0=0; zp0=0
if (nxgrid/=1) xp0=xxp(1)-xglobal(ix0)
if (nygrid/=1) yp0=xxp(2)-yglobal(iy0)
if (nzgrid/=1) zp0=xxp(3)-zglobal(iz0)
!
! Calculate derived grid spacing parameters needed for interpolation.
!
dx1=1/(xglobal(ix0+1)-xglobal(ix0))
dy1=1/(yglobal(iy0+1)-yglobal(iy0))
if (nzgrid/=1) then
dz1=1/(zglobal(iz0+1)-zglobal(iz0))
else
dz1=1
endif
!
dxdy1=dx1*dy1; dxdz1=dx1*dz1; dydz1=dy1*dz1
dxdydz1=dx1*dy1*dz1
!
! Function values at all corners.
!
g1=farr(1,1,1,1:vari2)
g2=farr(2,1,1,1:vari2)
g3=farr(1,2,1,1:vari2)
g4=farr(2,2,1,1:vari2)
g5=farr(1,1,2,1:vari2)
g6=farr(2,1,2,1:vari2)
g7=farr(1,2,2,1:vari2)
g8=farr(2,2,2,1:vari2)
!
! Interpolation formula.
!
fp = g1 + xp0*dx1*(-g1+g2) + yp0*dy1*(-g1+g3) + zp0*dz1*(-g1+g5) + &
xp0*yp0*dxdy1*(g1-g2-g3+g4) + xp0*zp0*dxdz1*(g1-g2-g5+g6) + &
yp0*zp0*dydz1*(g1-g3-g5+g7) + &
xp0*yp0*zp0*dxdydz1*(-g1+g2+g3-g4+g5-g6-g7+g8)
!
! Do a reality check on the interpolation scheme.
!
if (lcheck) then
do i=1,ivar2-ivar1+1
if (fp(i)>max(g1(i),g2(i),g3(i),g4(i),g5(i),g6(i),g7(i),g8(i))) then
print*, 'linear_interpolate_cartesian: interpolated value is LARGER than'
print*, 'linear_interpolate_cartesian: a values at the corner points!'
print*, 'linear_interpolate_cartesian: x0, y0, z0=', &
xglobal(ix0), yglobal(iy0), zglobal(iz0)
print*, 'linear_interpolate_cartesian: i, fp(i)=', i, fp(i)
print*, 'linear_interpolate_cartesian: g1...g8=', &
g1(i), g2(i), g3(i), g4(i), g5(i), g6(i), g7(i), g8(i)
print*, '------------------'
endif
if (fp(i)<min(g1(i),g2(i),g3(i),g4(i),g5(i),g6(i),g7(i),g8(i))) then
print*, 'linear_interpolate_cartesian: interpolated value is smaller than'
print*, 'linear_interpolate_cartesian: a values at the corner points!'
print*, 'linear_interpolate_cartesian: xxp=', xxp
print*, 'linear_interpolate_cartesian: x0, y0, z0=', &
xglobal(ix0), yglobal(iy0), zglobal(iz0)
print*, 'linear_interpolate_cartesian: i, fp(i)=', i, fp(i)
print*, 'linear_interpolate_cartesian: g1...g8=', &
g1(i), g2(i), g3(i), g4(i), g5(i), g6(i), g7(i), g8(i)
print*, '------------------'
endif
if (fp(i)/=fp(i)) then
print*, 'linear_interpolate_cartesian: interpolated value is NaN'
print*, 'linear_interpolate_cartesian: xxp=', xxp
print*, 'linear_interpolate_cartesian: x0, y0, z0=', &
xglobal(ix0), yglobal(iy0), zglobal(iz0)
print*, 'linear_interpolate_cartesian: i, fp(i)=', i, fp(i)
print*, 'linear_interpolate_cartesian: g1...g8=', &
g1(i), g2(i), g3(i), g4(i), g5(i), g6(i), g7(i), g8(i)
print*, '------------------'
linear_interpolate_cartesian=.false.
endif
enddo
endif
!
if (lfirstcall) lfirstcall=.false.
!
endfunction linear_interpolate_cartesian
!***********************************************************************
logical function interp_lagrange(farr_in,ivar1,ivar2,xxp,inear_glob,fp,lcart_to_curv,lcurv_to_cart,lcheck)
!
! Interpolate the value of f to (xp, yp) CURVILINEAR coordinate
! using the Nth-order lagrangian interpolation.
!
! TODO: Extend to 3D
! TODO: Adjust nearest point to be ACTUALLY NEAREST, not bottom left corner
! Needed due to asymetric stencil
!
! The coefficients are determined by the (N+1)x(N+1) grid points surrounding the
! interpolation point.
! Global coordinates are used for the interpolation, to allow interpolation of
! values outside this processors domain.
!
! 1-mar-19/Eva: Coded
!
integer :: ivar1, ivar2, half_order
real, dimension (3) :: xxp
real, dimension (interpolation_method+1,interpolation_method+1,interpolation_method+1,ivar2-ivar1+1) :: farr_in
!TODO
real, dimension (-(interpolation_method/2):(interpolation_method/2),&
-(interpolation_method/2):(interpolation_method/2),ivar2-ivar1+1) :: farr
real, dimension (ivar2-ivar1+1) :: fp
integer, dimension (3) :: inear_glob
logical :: lcart_to_curv, lcurv_to_cart, lcheck
!
intent(in) :: farr_in, ivar1, ivar2, xxp, inear_glob, lcheck, lcart_to_curv, lcurv_to_cart
intent(out) :: fp
real, dimension(-(interpolation_method/2):(interpolation_method/2)) :: xglob, yglob, deltax, deltay, x_i, y_i
real, dimension(-(interpolation_method/2):(interpolation_method/2),&
-(interpolation_method/2):(interpolation_method/2)) :: dx_ij, dy_ij
real, dimension(-(interpolation_method/2):(interpolation_method/2)) :: lag
real, dimension(-(interpolation_method/2):(interpolation_method/2),ivar2-ivar1+1) :: gp
integer :: i,j,ix0,ix1,iy0,iy1
!
interp_lagrange= .true.
farr(:,:,:) = farr_in(:,:,(interpolation_method/2)+1,:)
half_order = interpolation_method/2
!
! Get grid points
!
if (lcart_to_curv) then
xglob(-half_order:half_order) = xglobal(inear_glob(1)-interpolation_method/2:inear_glob(1)+interpolation_method/2)
yglob(-half_order:half_order) = yglobal(inear_glob(2)-interpolation_method/2:inear_glob(2)+interpolation_method/2)
elseif (lcurv_to_cart) then
xglob(-half_order:half_order) = xglobal_ogrid(inear_glob(1)-interpolation_method/2:inear_glob(1)+interpolation_method/2)
yglob(-half_order:half_order) = yglobal_ogrid(inear_glob(2)-interpolation_method/2:inear_glob(2)+interpolation_method/2)
else
print*,'interp_lagrange: Not interpolated to any specific grid!'
interp_lagrange= .false.
return
endif
!
! Compute distance from xxp to surrounding grid points
! Needed for checking that inear_glob is correct, and for lagrange polynomials
!
x_i(:) = xxp(1)
y_i(:) = xxp(2)
deltax = x_i - xglob
deltay = y_i - yglob
!
! Check that inear_glob actually points to the grid point closest to xxp
!
if (lcheck) then
if ((any(abs(deltax)<abs(deltax(0)))) .or. (any(abs(deltay)<abs(deltay(0))))) then
print*, 'interp_lagrange: Interpolation point does not lie closest to center grid point.'
print*, 'ix0, iy0, iz0 = ', inear_glob(1:3)
print*, 'xp, xglob(-3:3) = ', xxp(1), xglob
print*, 'yp, yglob(-3:3) = ', xxp(2), yglob
interp_lagrange = .false.
return
endif
if (lcurv_to_cart .and. any(abs(xglob) > r_ogrid)) then
print*,'Ghost point was used as interpolation point on curv. grid!'
print*,'Shift the interpolation zone inside.'
interp_lagrange = .false.
print*,'xglob',xglob
return
endif
endif
!
! Interpolate in x-direction
!
! Compute distances
!
do i = -half_order,half_order
do j = i+1,half_order
dx_ij(i,j) = xglob(i)-xglob(j)
dx_ij(j,i) = -dx_ij(i,j)
dy_ij(i,j) = yglob(i)-yglob(j)
dy_ij(j,i) = -dy_ij(i,j)
enddo
dx_ij(i,i) = 0
dy_ij(i,i) = 0
enddo
!
! Compute products of x-x_k/(x_i-x_k) for (i!=k)
!
lag(:)=1
do i = -half_order,half_order
do j = -half_order,half_order
if (i .ne. j) then
lag(i) = lag(i)*deltax(j)/dx_ij(i,j)
endif
enddo
enddo
!
! Interpolate points in x-direction
!
gp(:,:) = 0
do i=ivar1,ivar2
do j = -half_order,half_order
gp(:,i) = gp(:,i)+lag(j)*farr(j,:,i)
enddo
enddo
!
! Interpolate in y-direction
!
! Compute distances
!
lag(:)=1
do i = -half_order,half_order
do j = -half_order,half_order
if (i .ne. j) then
lag(i) = lag(i)*deltay(j)/dy_ij(i,j)
endif
enddo
enddo
!
! Interpolate points in y-direction
!
do i=ivar1,ivar2
do j=-half_order,half_order
fp(i) = sum(lag(:)*gp(:,i))
enddo
enddo
if (lcheck) then
do i=1,ivar2-ivar1+1
if ((fp(i)>maxval(farr(:,:,i)).and.i/=3) .or. (fp(i)<minval(farr(:,:,i)).and.i/=3)) then
!
! Compensate for overshoots by linear interpolation
!
ix0=0; ix1=1; iy0=0; iy1=1
if (xglob(0)>xxp(1)) then
ix0=half_order; ix1=half_order+1
else
ix0=half_order+1; ix1=half_order+2
endif
if (yglob(0)>xxp(2)) then
iy0=half_order; iy1=half_order+1
else
iy0=half_order+1; iy1=half_order+2
endif
if (lcart_to_curv) then
interp_lagrange= linear_interpolate_cartesian(farr_in(ix0:ix1,iy0:iy1,half_order+1:half_order+2,i),i,i,xxp, &
(/inear_glob(1)+ix0-(half_order+1),inear_glob(2)+iy0-(half_order+1),inear_glob(3)/),&
gp(0,i),lcheck_interpolation)
else
interp_lagrange= linear_interpolate_curvilinear(farr_in(ix0:ix1,iy0:iy1,half_order+1:half_order+2,i),i,i,xxp, &
(/inear_glob(1)+ix0-(half_order+1),inear_glob(2)+iy0-(half_order+1),inear_glob(3)/),&
gp(0,i),lcheck_interpolation)
endif
!
fp(i)=gp(0,i)
endif
if (fp(i)/=fp(i)) then
print*, 'interp_interpolate: interpolated value is NaN'
print*, 'interp_interpolate: xxp=', xxp
print*, 'interp_interpolate: i, fp(i)=', i, fp(i)
print*, '------------------'
interp_lagrange=.false.
endif
enddo
endif
!
endfunction interp_lagrange
!!***********************************************************************
!!***********************************************************************
logical function linear_interpolate_curvilinear(farr,ivar1,ivar2,xxp,inear_glob,fp,lcheck)
!
! Interpolate the value of f to arbitrary (xp, yp, zp) CURVILINEAR coordinate
! using the linear interpolation formula.
!
! g(x,y,z) = A*x*y*z + B*x*y + C*x*z + D*y*z + E*x + F*y + G*z + H .
!
! The coefficients are determined by the 8 grid points surrounding the
! interpolation point.
! Global coordinates are used for the interpolation, to allow interpolation of
! values outside this processors domain.
!
! 26-apr-17/Jorgen: Adapted from linear_interpolate_cartesian
!
integer :: ivar1, ivar2
real, dimension (3) :: xxp
real, dimension (2,2,2,ivar2-ivar1+1) :: farr
real, dimension (ivar2-ivar1+1) :: fp
integer, dimension (3) :: inear_glob
logical :: lcheck
!
real, dimension (ivar2-ivar1+1) :: g1, g2, g3, g4, g5, g6, g7, g8
real :: xp0, yp0, zp0
real, save :: dxdydz1, dxdy1, dxdz1, dydz1, dx1, dy1, dz1
logical :: lfirstcall=.true.
integer :: ix0, iy0, iz0, i
integer :: vari2
!
intent(in) :: farr, ivar1, ivar2, xxp, inear_glob, lcheck
intent(out) :: fp
!
! Set vari2 /= ivar2 to allow for farr with ivar1>1
vari2 = ivar2-ivar1+1
!
! Determine index value of lowest lying corner point of grid box surrounding
! the interpolation point.
!
linear_interpolate_curvilinear= .true.
!
ix0=inear_glob(1); iy0=inear_glob(2); iz0=inear_glob(3)
!
! Check if the grid point interval is really correct.
!
if ((xglobal_ogrid(ix0)<=xxp(1) .and. xglobal_ogrid(ix0+1)>=xxp(1) .or. nxgrid==1) .and. &
(yglobal_ogrid(iy0)<=xxp(2) .and. yglobal_ogrid(iy0+1)>=xxp(2) .or. nygrid==1) .and. &
(zglobal_ogrid(iz0)<=xxp(3) .and. zglobal_ogrid(iz0+1)>=xxp(3) .or. nzgrid==1)) then
! Everything okay
else
print*, 'linear_interpolate_curvilinear: Global interpolation point does not ' // &
'lie within the calculated grid point interval.'
print*, 'iproc = ', iproc_world
print*, 'mxgrid_ogrid, xglobal_ogrid(1), xglobal_ogrid(mxgrid_ogrid) = ', &
mxgrid_ogrid, xglobal_ogrid(1), xglobal_ogrid(mxgrid_ogrid)
print*, 'mygrid_ogrid, yglobal_ogrid(1), yglobal_ogrid(mygrid_ogrid) = ', &
mygrid_ogrid, yglobal_ogrid(1), yglobal_ogrid(mygrid_ogrid)
print*, 'mzgrid_ogrid, zglobal_ogrid(1), zglobal_ogrid(mzgrid_ogrid) = ', &
mzgrid_ogrid, zglobal_ogrid(1), zglobal_ogrid(mzgrid_ogrid)
print*, 'ix0, iy0, iz0 = ', ix0, iy0, iz0
print*, 'xp, xp0, xp1 = ', xxp(1), xglobal_ogrid(ix0), xglobal_ogrid(ix0+1)
print*, 'yp, yp0, yp1 = ', xxp(2), yglobal_ogrid(iy0), yglobal_ogrid(iy0+1)
print*, 'zp, zp0, zp1 = ', xxp(3), zglobal_ogrid(iz0), zglobal_ogrid(iz0+1)
linear_interpolate_curvilinear= .false.
return
endif
!
! Redefine the interpolation point in coordinates relative to lowest corner.
! Set it equal to 0 for dimensions having 1 grid points; this will make sure
! that the interpolation is bilinear for 2D grids.
!
xp0=0; yp0=0; zp0=0
if (nxgrid_ogrid/=1) xp0=xxp(1)-xglobal_ogrid(ix0)
if (nygrid_ogrid/=1) yp0=xxp(2)-yglobal_ogrid(iy0)
if (nzgrid_ogrid/=1) zp0=xxp(3)-zglobal_ogrid(iz0)
!
! Calculate derived grid spacing parameters needed for interpolation.
!
dx1=1/(xglobal_ogrid(ix0+1)-xglobal_ogrid(ix0))
dy1=1/(yglobal_ogrid(iy0+1)-yglobal_ogrid(iy0))
if (nzgrid/=1) then
dz1=1/(zglobal_ogrid(iz0+1)-zglobal_ogrid(iz0))
else
dz1=1
endif
!
dxdy1=dx1*dy1; dxdz1=dx1*dz1; dydz1=dy1*dz1
dxdydz1=dx1*dy1*dz1
!
! Function values at all corners.
!
g1=farr(1,1,1,1:vari2)
g2=farr(2,1,1,1:vari2)
g3=farr(1,2,1,1:vari2)
g4=farr(2,2,1,1:vari2)
g5=farr(1,1,2,1:vari2)
g6=farr(2,1,2,1:vari2)
g7=farr(1,2,2,1:vari2)
g8=farr(2,2,2,1:vari2)
!
! Interpolation formula.
!
fp = g1 + xp0*dx1*(-g1+g2) + yp0*dy1*(-g1+g3) + zp0*dz1*(-g1+g5) + &
xp0*yp0*dxdy1*(g1-g2-g3+g4) + xp0*zp0*dxdz1*(g1-g2-g5+g6) + &
yp0*zp0*dydz1*(g1-g3-g5+g7) + &
xp0*yp0*zp0*dxdydz1*(-g1+g2+g3-g4+g5-g6-g7+g8)
!
! Do a reality check on the interpolation scheme.
!
if (lcheck) then
do i=1,ivar2-ivar1+1
if (fp(i)>max(g1(i),g2(i),g3(i),g4(i),g5(i),g6(i),g7(i),g8(i))) then
print*, 'linear_interpolate_curvilinear: interpolated value is LARGER than'
print*, 'linear_interpolate_curvilinear: a values at the corner points!'
print*, 'linear_interpolate_curvilinear: x0, y0, z0=', &
xglobal_ogrid(ix0), yglobal_ogrid(iy0), zglobal_ogrid(iz0)
print*, 'linear_interpolate_curvilinear: i, fp(i)=', i, fp(i)
print*, 'linear_interpolate_curvilinear: g1...g8=', &
g1(i), g2(i), g3(i), g4(i), g5(i), g6(i), g7(i), g8(i)
print*, '------------------'
endif
if (fp(i)<min(g1(i),g2(i),g3(i),g4(i),g5(i),g6(i),g7(i),g8(i))) then
print*, 'linear_interpolate_curvilinear: interpolated value is smaller than'
print*, 'linear_interpolate_curvilinear: a values at the corner points!'
print*, 'linear_interpolate_curvilinear: xxp=', xxp
print*, 'linear_interpolate_curvilinear: x0, y0, z0=', &
xglobal_ogrid(ix0), yglobal_ogrid(iy0), zglobal_ogrid(iz0)
print*, 'linear_interpolate_curvilinear: i, fp(i)=', i, fp(i)
print*, 'linear_interpolate_curvilinear: g1...g8=', &
g1(i), g2(i), g3(i), g4(i), g5(i), g6(i), g7(i), g8(i)
print*, '------------------'
endif
if (fp(i)/=fp(i)) then
print*, 'linear_interpolate_curvilinear: interpolated value is NaN'
print*, 'linear_interpolate_curvilinear: xxp=', xxp
print*, 'linear_interpolate_curvilinear: ix0, iy0, iz0=', ix0,iy0,iz0
print*, 'linear_interpolate_curvilinear: x0, y0, z0=', &
xglobal_ogrid(ix0), yglobal_ogrid(iy0), zglobal_ogrid(iz0)
print*, 'linear_interpolate_curvilinear: x0+1, y0+1, z0+1=', &
xglobal_ogrid(ix0+1), yglobal_ogrid(iy0+1), zglobal_ogrid(iz0+1)
print*, 'linear_interpolate_curvilinear: i, fp(i)=', i, fp(i)
print*, 'linear_interpolate_curvilinear: g1...g8=', &
g1(i), g2(i), g3(i), g4(i), g5(i), g6(i), g7(i), g8(i)
print*, '------------------'
linear_interpolate_curvilinear=.false.
endif
enddo
endif
!
if (lfirstcall) lfirstcall=.false.
!
endfunction linear_interpolate_curvilinear
!***********************************************************************
subroutine solid_cells_timestep_first(f)
!
! 08-feb-17/Jorgen: Coded
!
! Only save time, which is the time before timesteps on cartesian grid
! is performed. Will need this to set timestep of ogrid iterations.
!
real, dimension(mx,my,mz,mfarray) :: f
!
call keep_compiler_quiet(f)
!
end subroutine solid_cells_timestep_first
!***********************************************************************
subroutine solid_cells_timestep_second(f,int_dt,int_ds)
!
! Time evolution of solid_cells variables.
!
real, dimension(mx,my,mz,mfarray) :: f
real :: int_dt, int_ds
!
call keep_compiler_quiet(f)
call keep_compiler_quiet(int_dt)
call keep_compiler_quiet(int_ds)
!
endsubroutine solid_cells_timestep_second
!***********************************************************************
subroutine read_solid_cells_init_pars(iostat)
!
use File_io, only: parallel_unit
!
integer, intent(out) :: iostat
!
!read(parallel_unit, NML=solid_cells_init_pars, IOSTAT=iostat)
iostat = 0
read(parallel_unit, NML=solid_cells_init_pars)
!
endsubroutine read_solid_cells_init_pars
!***********************************************************************
subroutine write_solid_cells_init_pars(unit)
!
integer, intent(in) :: unit
!
write(unit, NML=solid_cells_init_pars)
!
endsubroutine write_solid_cells_init_pars
!***********************************************************************
subroutine read_solid_cells_run_pars(iostat)
!
use File_io, only: parallel_unit
!
integer, intent(out) :: iostat
!
read(parallel_unit, NML=solid_cells_run_pars, IOSTAT=iostat)
!
endsubroutine read_solid_cells_run_pars
!***********************************************************************
subroutine write_solid_cells_run_pars(unit)
!
integer, intent(in) :: unit
!
write(unit, NML=solid_cells_run_pars)
!
endsubroutine write_solid_cells_run_pars
!***********************************************************************
subroutine close_interpolation(f,ix0_,iy0_,iz0_,iobj,xxp,f_tmp,fluid_point)
!
real, dimension(:,:,:,:) :: f
integer, intent(in) :: ix0_, iy0_, iz0_, iobj
real, dimension(:), intent(inout) :: f_tmp
real, dimension(3), intent(in) :: xxp
logical, intent(in) :: fluid_point
!
call keep_compiler_quiet(f)
call keep_compiler_quiet(f_tmp)
call keep_compiler_quiet(ix0_,iy0_,iz0_)
call keep_compiler_quiet(fluid_point)
call keep_compiler_quiet(xxp)
call keep_compiler_quiet(iobj)
!
end subroutine close_interpolation
!***********************************************************************
subroutine construct_grid_ogrid
!
! Constructs a non-equidistant cylindrical grid x_ogrid that surrounds the solid cylinder
! and partially overlaps with the cartesian grid x.
! The grid x_ogrid(xi) is constructed from an equidistant grid xi with grid spacing dx=1.
! grid spacing dxi=1. For grid_func_ogrid='linear' this is equivalent to an
! equidistant grid.
!
! Grid is defined as (x_ogrid) = (r,theta,z)
! Must be periodic and equidistant in theta-direction
! Cannot be periodic in r-direction
!
! dx_1_o and dx_tilde_o are the coefficients that enter the formulae for the
! 1st and 2nd derivative:
!
! ``df/dx_o'' = ``df/dxi'' * dx_1_o
! ``d2f/dx2_o'' = ``df2/dxi2'' * dx_1_o**2 + dx_tilde_o * ``df/dxi'' * dx_1_o
!
! These coefficients are also very useful when adapting grid dependend stuff
! such as the timestep. A simple substitution
! 1./dx_o -> dx_1_o
! should suffice in most cases.
!
! 31-jan-17/jorgen: adapted from grid-module
!
use grid, only: grid_profile,find_star,calc_bound_coeffs
real :: Lx_og,Ly_og,Lz_og
real :: x00,y00,z00
real :: x0,y0,z0
real :: xi1lo,xi1up,g1lo,g1up
real :: xi2lo,xi2up,g2lo,g2up
real :: xi3lo,xi3up,g3lo,g3up
real :: xi1star,xi2star,xi3star
!
real, dimension(mx_ogrid) :: g1,g1der1,g1der2,xi1,xprim2_ogrid
real, dimension(my_ogrid) :: g2,g2der1,g2der2,xi2,yprim2_ogrid
real, dimension(mz_ogrid) :: g3,g3der1,g3der2,xi3,zprim2_ogrid
!
real, dimension(0:2*nprocx+1) :: xi1proc,g1proc
real, dimension(0:2*nprocy+1) :: xi2proc,g2proc
real, dimension(0:2*nprocz+1) :: xi3proc,g3proc
!
real :: a
integer :: i
!
lequidist_ogrid=(grid_func_ogrid=='linear')
!
! Abbreviations
!
x0 = xyz0_ogrid(1)
y0 = xyz0_ogrid(2)
z0 = xyz0_ogrid(3)
Lx_og = Lxyz_ogrid(1)
Ly_og = Lxyz_ogrid(2)
Lz_og = Lxyz_ogrid(3)
!
! Set the lower boundary and the grid size.
!
x00 = x0
y00 = y0
z00 = z0
!
dx_ogrid = Lx_og / merge(nxgrid_ogrid, max(nxgrid_ogrid-1,1), .false.)
dy_ogrid = Ly_og / merge(nygrid_ogrid, max(nygrid_ogrid-1,1), .true.)
dz_ogrid = Lz_og / merge(nzgrid_ogrid, max(nzgrid_ogrid-1,1), lperi(3))
!
! Shift the lower boundary if requested, but only for periodic directions.
!
if (lshift_origin_ogrid(1)) x00 = x0 + 0.5 * dx_ogrid
if (lshift_origin_ogrid(2)) y00 = y0 + 0.5 * dy_ogrid
if (lshift_origin_ogrid(3)) z00 = z0 + 0.5 * dz_ogrid
!
! Shift the lower boundary if requested, but only for periodic directions.
! Contrary to the upper case (lshift_origin)
!
if (lshift_origin_lower_ogrid(1)) x00 = x0 - 0.5 * dx_ogrid
if (lshift_origin_lower_ogrid(2)) y00 = y0 - 0.5 * dy_ogrid
if (lshift_origin_lower_ogrid(3)) z00 = z0 - 0.5 * dz_ogrid
!
! Produce index arrays xi1, xi2, and xi3:
! xi = 0, 1, 2, ..., N-1 for non-periodic grid
! xi = 0.5, 1.5, 2.5, ..., N-0.5 for periodic grid
!
do i=1,mx_ogrid; xi1(i)=i-nghost-1+ipx*nx_ogrid; enddo
do i=1,my_ogrid; xi2(i)=i-nghost-1+ipy*ny_ogrid; enddo
do i=1,mz_ogrid; xi3(i)=i-nghost-1+ipz*nz_ogrid; enddo
!
xi2 = xi2 + 0.5
if (lperi(3)) xi3 = xi3 + 0.5
!
! Produce index arrays for processor boundaries, which are needed for
! particle migration (see redist_particles_bounds). The select cases
! should use these arrays to set g{2,3}proc using the grid function.
!
do i=0,nprocx
xi1proc(2*i) =i*nx_ogrid-1
xi1proc(2*i+1)=i*nx_ogrid
enddo
do i=0,nprocy
xi2proc(2*i) =i*ny_ogrid-1
xi2proc(2*i+1)=i*ny_ogrid
enddo
do i=0,nprocz
xi3proc(2*i) =i*nz_ogrid-1
xi3proc(2*i+1)=i*nz_ogrid
enddo
xi2proc = xi2proc + 0.5
if (lperi(3)) xi3proc = xi3proc + 0.5
!
! The following is correct for periodic and non-periodic case
! Periodic: x(xi=0) = x0 and x(xi=N) = x1
! Non-periodic: x(xi=0) = x0 and x(xi=N-1) = x1
!
xi1lo=0.; xi1up=nxgrid_ogrid-merge(0.,1.,.false.)
xi2lo=0.; xi2up=nygrid_ogrid-merge(0.,1.,.true.)
xi3lo=0.; xi3up=nzgrid_ogrid-merge(0.,1.,lperi(3))
!
! Construct nonequidistant grid
!
! x coordinate
!
if (nxgrid_ogrid==1) then
x_ogrid = x00 + 0.5 * dx_ogrid
! hopefully, we will only ever multiply by the following quantities:
xprim_ogrid = 0.
xprim2_ogrid = 0.
dx_1_ogrid = 0.
dx_tilde_ogrid = 0.
g1proc=x00
else
!
select case (grid_func_ogrid(1))
!
case ('linear','sinh')
a=coeff_grid_o(1)*dx_ogrid
xi1star=find_star(a*xi1lo,a*xi1up,x00,x00+Lx_og,xyz_star_ogrid(1),grid_func_ogrid(1))/a
call grid_profile(a*(xi1 -xi1star),grid_func_ogrid(1),g1,g1der1,g1der2)
call grid_profile(a*(xi1lo-xi1star),grid_func_ogrid(1),g1lo)
call grid_profile(a*(xi1up-xi1star),grid_func_ogrid(1),g1up)
!
x_ogrid =x00+Lx_og*(g1 - g1lo)/(g1up-g1lo)
xprim_ogrid = Lx_og*(g1der1*a )/(g1up-g1lo)
xprim2_ogrid= Lx_og*(g1der2*a**2)/(g1up-g1lo)
!
! Since lsolid_cells=True
call grid_profile(a*(xi1proc-xi1star),grid_func_ogrid(1),g1proc)
g1proc=x00+Lx_og*(g1proc - g1lo)/(g1up-g1lo)
!
case default
call fatal_error('construct_grid', &
'No such x grid function - '//grid_func_ogrid(1))
endselect
!
dx2_ogrid=xprim_ogrid**2
dx_1_ogrid=1./xprim_ogrid
dx_tilde_ogrid=-xprim2_ogrid/dx2_ogrid
!
if (lfirst_proc_x) &
dx2_bound_ogrid(-1:-nghost:-1)= 2.*(x_ogrid(l1_ogrid+1:l1_ogrid+nghost)-x_ogrid(l1_ogrid))
if (llast_proc_x) &
dx2_bound_ogrid(nghost:1:-1) = 2.*(x_ogrid(l2_ogrid)-x_ogrid(l2_ogrid-nghost:l2_ogrid-1))
!
call calc_bound_coeffs(x_ogrid,coeffs_1_x_ogrid)
endif
!
! y coordinate
!
if (nygrid_ogrid==1) then
y_ogrid = y00 + 0.5 * dy_ogrid
! hopefully, we will only ever multiply by the following quantities:
yprim_ogrid = 0.
yprim2_ogrid = 0.
dy_1_ogrid = 0.
dy_tilde_ogrid = 0.
g2proc=y00
else
!
select case (grid_func_ogrid(2))
!
case ('linear')
a=coeff_grid_o(2)*dy_ogrid
xi2star=find_star(a*xi2lo,a*xi2up,y00,y00+Ly_og,xyz_star_ogrid(2),grid_func_ogrid(2))/a
call grid_profile(a*(xi2 -xi2star),grid_func_ogrid(2),g2,g2der1,g2der2)
call grid_profile(a*(xi2lo-xi2star),grid_func_ogrid(2),g2lo)
call grid_profile(a*(xi2up-xi2star),grid_func_ogrid(2),g2up)
!
y_ogrid =y00+Ly_og*(g2 - g2lo)/(g2up-g2lo)
yprim_ogrid = Ly_og*(g2der1*a )/(g2up-g2lo)
yprim2_ogrid= Ly_og*(g2der2*a**2)/(g2up-g2lo)
!
! Since lsolid_cells=True
call grid_profile(a*(xi2proc-xi2star),grid_func_ogrid(2),g2proc)
g2proc=y00+Ly_og*(g2proc - g2lo)/(g2up-g2lo)
!
case default
call fatal_error('construct_grid', &
'No such y grid function - '//grid_func_ogrid(2))
endselect
!
! Added parts for spherical coordinates and cylindrical coordinates. ! JORGEN:Removed spherical part
! From now on dy = d\theta but dy_1 = 1/rd\theta and similarly for \phi.
! corresponding r and rsin\theta factors for equ.f90 (where CFL timesteps
! are estimated) are removed.
!
dy2_ogrid=yprim_ogrid**2
dy_1_ogrid=1./yprim_ogrid
dy_tilde_ogrid=-yprim2_ogrid/dy2_ogrid
!
if (lfirst_proc_y) &
dy2_bound_ogrid(-1:-nghost:-1)= 2.*(y_ogrid(m1_ogrid+1:m1_ogrid+nghost)-y_ogrid(m1_ogrid))
if (llast_proc_y) &
dy2_bound_ogrid(nghost:1:-1) = 2.*(y_ogrid(m2_ogrid)-y_ogrid(m2_ogrid-nghost:m2_ogrid-1))
!
call calc_bound_coeffs(y_ogrid,coeffs_1_y_ogrid)
endif
!
! z coordinate
!
if (nzgrid_ogrid==1) then
z_ogrid = z00 + 0.5 * dz_ogrid
! hopefully, we will only ever multiply by the following quantities:
zprim_ogrid = 0.
zprim2_ogrid = 0.
dz_1_ogrid = 0.
dz_tilde_ogrid = 0.
g3proc=z00
else
!
select case (grid_func_ogrid(3))
!
case ('linear','sinh')
a=coeff_grid_o(3)*dz_ogrid
xi3star=find_star(a*xi3lo,a*xi3up,z00,z00+Lz_og,xyz_star_ogrid(3),grid_func_ogrid(3))/a
call grid_profile(a*(xi3 -xi3star),grid_func_ogrid(3),g3,g3der1,g3der2)
call grid_profile(a*(xi3lo-xi3star),grid_func_ogrid(3),g3lo)
call grid_profile(a*(xi3up-xi3star),grid_func_ogrid(3),g3up)
!
z_ogrid =z00+Lz_og*(g3 - g3lo)/(g3up-g3lo)
zprim_ogrid = Lz_og*(g3der1*a )/(g3up-g3lo)
zprim2_ogrid= Lz_og*(g3der2*a**2)/(g3up-g3lo)
!
! Since lsolid_cells is True
call grid_profile(a*(xi3proc-xi3star),grid_func_ogrid(3),g3proc)
g3proc=z00+Lz_og*(g3proc-g3lo)/(g3up-g3lo)
!
case default
call fatal_error('construct_grid', &
'No such z grid function - '//grid_func_ogrid(3))
endselect
!
dz2_ogrid=zprim_ogrid**2
dz_1_ogrid=1./zprim_ogrid
dz_tilde_ogrid=-zprim2_ogrid/dz2_ogrid
!
if (lfirst_proc_z) &
dz2_bound_ogrid(-1:-nghost:-1)= 2.*(z_ogrid(n1_ogrid+1:n1_ogrid+nghost)-z_ogrid(n1_ogrid))
if (llast_proc_z) &
dz2_bound_ogrid(nghost:1:-1) = 2.*(z_ogrid(n2_ogrid)-z_ogrid(n2_ogrid-nghost:n2_ogrid-1))
!
call calc_bound_coeffs(z_ogrid,coeffs_1_z_ogrid)
endif
!
! Compute averages across processor boundaries to calculate the physical
! boundaries
!
do i=0,nprocx
procx_bounds_ogrid(i)=(g1proc(2*i)+g1proc(2*i+1))*0.5
enddo
do i=0,nprocy
procy_bounds_ogrid(i)=(g2proc(2*i)+g2proc(2*i+1))*0.5
enddo
do i=0,nprocz
procz_bounds_ogrid(i)=(g3proc(2*i)+g3proc(2*i+1))*0.5
enddo
!
endsubroutine construct_grid_ogrid
!***********************************************************************
subroutine initialize_grid_ogrid
!
! Coordinate-related issues: nonuniform meshes, different coordinate systems
!
! 31-jan-17/Jorgen: adapted from initialize_grid subroutine in grid.f90
!
use Mpicomm, only: mpiallreduce_min,mpiallreduce_max
!
real :: dxmin_x, dxmin_y, dxmin_z, dxmax_x, dxmax_y, dxmax_z, dxmax_r
real :: Area_xy_ogrid, Area_yz_ogrid, Area_xz_ogrid
!
! CALL TO COORDS_AUX REMOVED, ONLY CYLINDRICAL NEEDED
!
rcyl_mn_ogrid=x_ogrid(l1_ogrid:l2_ogrid)
if (x_ogrid(l1_ogrid)==0.) then
rcyl_mn1_ogrid(2:)=1./x_ogrid(l1_ogrid+1:l2_ogrid)
rcyl_mn1_ogrid(1)=0.
else
rcyl_mn1_ogrid=1./x_ogrid(l1_ogrid:l2_ogrid)
endif
rcyl_mn2_ogrid=rcyl_mn1_ogrid**2
!
! determine global minimum and maximum of grid spacing in any direction
!
if (lequidist_ogrid(1) .or. nxgrid_ogrid <= 1) then
dxmin_x = dx_ogrid
dxmax_x = dx_ogrid
else
dxmin_x = minval(xprim_ogrid(l1_ogrid:l2_ogrid))
dxmax_x = maxval(xprim_ogrid(l1_ogrid:l2_ogrid))
endif
!
if (lequidist_ogrid(2) .or. nygrid_ogrid <= 1) then
dxmin_y = dy_ogrid*minval(x_ogrid(l1_ogrid:l2_ogrid))
dxmax_y = dy_ogrid*maxval(x_ogrid(l1_ogrid:l2_ogrid))
else
dxmin_y = minval(yprim_ogrid(m1_ogrid:m2_ogrid))
dxmax_y = maxval(yprim_ogrid(m1_ogrid:m2_ogrid))
endif
!
if (lequidist_ogrid(3) .or. nzgrid_ogrid <= 1) then
dxmin_z = dz
dxmax_z = dz
else
dxmin_z = minval(zprim_ogrid(n1_ogrid:n2_ogrid))
dxmax_z = maxval(zprim_ogrid(n1_ogrid:n2_ogrid))
endif
!
! Find minimum/maximum grid spacing. Note that
! minval( (/dxmin_x,dxmin_y,dxmin_z/), MASK=((/nxgrid,nygrid,nzgrid/) > 1) )
! will be undefined if all n[xyz]grid==1, so we have to add the fourth
! component with a test that is always true
!
dxmin_ogrid = minval( (/dxmin_x, dxmin_y, dxmin_z, huge(dx_ogrid)/), &
MASK=((/nxgrid_ogrid, nygrid_ogrid, nzgrid_ogrid, 2/) > 1) )
call mpiallreduce_min(dxmin_ogrid,dxmin_x)
dxmin_ogrid=dxmin_x
!
if (dxmin_ogrid == 0) &
call fatal_error ("initialize_grid", "check Lx_og,Ly_og,Lz_og: is one of them 0?", .true.)
!
! Maximum radial grid spacing needed for interpolation region
!
drmax_ogrid=dxmax_x
call mpiallreduce_max(drmax_ogrid,dxmax_r)
drmax_ogrid=dxmax_r
!
dxmax_ogrid = maxval( (/dxmax_x, dxmax_y, dxmax_z, epsilon(dx_ogrid)/), &
MASK=((/nxgrid_ogrid, nygrid_ogrid, nzgrid_ogrid, 2/) > 1) )
!
call mpiallreduce_max(dxmax_ogrid,dxmax_x)
dxmax_ogrid=dxmax_x
!
! Box volume, cylinder symmetrical
!
!TODO: Is this calculation correct? Is it needed?
box_volume_ogrid=1.
if (nxgrid_ogrid/=1) then
box_volume_ogrid = box_volume_ogrid*.5*(r_ogrid**2-xyz0_ogrid(1)**2)
endif
box_volume_ogrid = box_volume_ogrid*2.*pi
if (nzgrid_ogrid/=1) box_volume_ogrid = box_volume_ogrid*Lxyz_ogrid(3)
!
! Volume element and area of coordinate surfaces.
! Note that in the area a factor depending only on the coordinate x_i which defines the surface by x_i=const. is dropped.
!
Area_xy_ogrid=1.; Area_yz_ogrid=1.; Area_xz_ogrid=1.
!
! CARTESIAN AND SPHERICAL REMOVED
!
! Volume element.
!
if (nxgrid_ogrid/=1) then
dVol_x_ogrid=x_ogrid*xprim_ogrid
Area_xy_ogrid=Area_xy_ogrid*1./2.*(r_ogrid**2-xyz0_ogrid(1)**2)
Area_xz_ogrid=Area_xz_ogrid*(r_ogrid**2-xyz0_ogrid(1)**2)
else
dVol_x_ogrid=1./2.*(r_ogrid**2-xyz0_ogrid(1)**2)
Area_xy_ogrid=Area_xy_ogrid*dVol_x_ogrid(1)
Area_xz_ogrid=Area_xz_ogrid*Lxyz_ogrid(1)
endif
!
! theta extent (cylindrically symmetric)
!
if (nygrid/=1) then
dVol_y_ogrid=yprim_ogrid
else
dVol_y_ogrid=2.*pi
endif
Area_xy_ogrid=Area_xy_ogrid*2*pi
Area_yz_ogrid=Area_yz_ogrid*2*pi
!
! z extent (vertically extended)
!
if (nzgrid/=1) then
dVol_z_ogrid=zprim_ogrid
Area_xz_ogrid=Area_xz_ogrid*Lxyz_ogrid(3)
Area_yz_ogrid=Area_yz_ogrid*Lxyz_ogrid(3)
else
dVol_z_ogrid=1.
endif
!
! Trapezoidal rule
!
rcyl_weight_ogrid=rcyl_mn_ogrid
if (lfirst_proc_x) rcyl_weight_ogrid( 1)=.5*rcyl_weight_ogrid( 1)
if (llast_proc_x ) rcyl_weight_ogrid(nx_ogrid)=.5*rcyl_weight_ogrid(nx_ogrid)
!
! Stop if no existing coordinate system is specified
!
! Inverse volume elements
!
dVol1_x_ogrid = 1./dVol_x_ogrid
dVol1_y_ogrid = 1./dVol_y_ogrid
dVol1_z_ogrid = 1./dVol_z_ogrid
!
! For a non-periodic mesh, multiply boundary points by 1/2.
! Do it for each direction in turn.
! If a direction has no extent, it is automatically periodic
! and the corresponding step is therefore not called.
!
if (lfirst_proc_x) dVol_x_ogrid(l1_ogrid)=.5*dVol_x_ogrid(l1_ogrid)
if (llast_proc_x ) dVol_x_ogrid(l2_ogrid)=.5*dVol_x_ogrid(l2_ogrid)
!
if (.not.lperi(3)) then
if (lfirst_proc_z) dVol_z_ogrid(n1_ogrid)=.5*dVol_z_ogrid(n1_ogrid)
if (llast_proc_z ) dVol_z_ogrid(n2_ogrid)=.5*dVol_z_ogrid(n2_ogrid)
endif
!
! Print the value for which output is being produced.
! (Have so far only bothered about single processor output.)
!
if (lroot) then
lpoint_ogrid=min(max(l1_ogrid,lpoint_ogrid),l2_ogrid)
mpoint_ogrid=min(max(m1_ogrid,mpoint_ogrid),m2_ogrid)
npoint_ogrid=min(max(n1_ogrid,npoint_ogrid),n2_ogrid)
lpoint2_ogrid=min(max(l1_ogrid,lpoint2_ogrid),l2_ogrid)
mpoint2_ogrid=min(max(m1_ogrid,mpoint2_ogrid),m2_ogrid)
npoint2_ogrid=min(max(n1_ogrid,npoint2_ogrid),n2_ogrid)
print*,'(x,y,z)_ogrid(point)=',x_ogrid(lpoint_ogrid),y_ogrid(mpoint_ogrid),z_ogrid(npoint_ogrid)
print*,'(x,y,z)_ogrid(point2)=',x_ogrid(lpoint2_ogrid),y_ogrid(mpoint2_ogrid),z_ogrid(npoint2_ogrid)
endif
!
! Set the the serial grid arrays, that contain the coordinate values
! from all processors.
!
call construct_serial_arrays
!
endsubroutine initialize_grid_ogrid
!!***********************************************************************
subroutine calc_pencils_grid_ogrid
!
! Calculate Grid/geometry related pencils.
! Most basic pencils should come first, as others may depend on them.
!
! 31-jan-17/Jorgen: Adapted from calc_pencils_grid in grid.f90
! Only cylindrical coordinates included
!
if (lpencil_ogrid(i_og_x_mn)) &
p_ogrid%x_mn = x_ogrid(l1_ogrid:l2_ogrid)*cos(y_ogrid(m_ogrid))
if (lpencil_ogrid(i_og_y_mn)) &
p_ogrid%y_mn = x_ogrid(l1_ogrid:l2_ogrid)*sin(y_ogrid(m_ogrid))
if (lpencil_ogrid(i_og_z_mn)) &
p_ogrid%z_mn = spread(z_ogrid(n_ogrid),1,nx_ogrid)
if (lpencil_ogrid(i_og_rcyl_mn)) &
p_ogrid%rcyl_mn = x_ogrid(l1_ogrid:l2_ogrid)
if (lpencil_ogrid(i_og_phi_mn)) &
p_ogrid%phi_mn = spread(y_ogrid(m_ogrid),1,nx_ogrid)
if (lpencil_ogrid(i_og_rcyl_mn1)) &
p_ogrid%rcyl_mn1= 1./max(p_ogrid%rcyl_mn,tini)
!
endsubroutine calc_pencils_grid_ogrid
!***********************************************************************
subroutine real_to_index_ogrid(n, x, xi)
!
! Transforms coordinates in real space to those in index space.
!
! 10-sep-15/ccyang: coded.
!
integer, intent(in) :: n
real, dimension(n,3), intent(in) :: x
real, dimension(n,3), intent(out) :: xi
!
real, parameter :: ngp1 = nghost + 1
integer :: i
!
! Work on each direction.
!
nonzero: if (n > 0) then
dir: do i = 1, 3
if (lactive_dimension(i)) then
call inverse_grid_ogrid(i, x(:,i), xi(:,i), local=.true.)
else
xi(:,i) = ngp1
endif
enddo dir
endif nonzero
!
endsubroutine real_to_index_ogrid
!***********************************************************************
subroutine inverse_grid_ogrid(dir, x, xi, local)
!
! Transform the x coordinates in real space to the xi coordinates in
! index space in dir direction, where dir = 1, 2, or, 3.
! If local is present and .true., the index space is with respect to
! the local grid.
!
! 31-jan-17/Jorgen: adapted from inverse_grid in grid.f90
!
use General, only: arcsinh
!
integer, intent(in) :: dir
real, dimension(:), intent(in) :: x
real, dimension(:), intent(out) :: xi
logical, intent(in), optional :: local
!
character(len=linelen) :: msg
logical :: loc
integer :: shift
real :: h, a, b, c
!
! Sanity check.
!
if (any(lshift_origin) .or. any(lshift_origin_lower)) &
call fatal_error('inverse_grid_ogrid', 'lshift_origin and lshift_origin_lower are not supported. ')
!
! Global or local index space?
!
loc = .false.
if (present(local)) loc = local
!
! Check the direction.
!
ckdir: select case (dir)
case (1) ckdir
h = dx_ogrid
if (loc) shift = nx_ogrid * ipx
case (2) ckdir
h = dy_ogrid
if (loc) shift = ny_ogrid * ipy
case (3) ckdir
h = dz_ogrid
if (loc) shift = nz_ogrid * ipz
case default ckdir
write(msg,*) 'unknown direction dir = ', dir
call fatal_error('inverse_grid_ogrid', trim(msg))
endselect ckdir
!
! Make the inversion according to the grid function.
!
func: select case (grid_func_ogrid(dir))
!
case ('linear') func
xi = (x - xyz0_ogrid(dir)) / h
!
case ('sinh') func
a = coeff_grid_o(dir) * Lxyz_ogrid(dir)
b = sinh(a)
c = cosh(a) - 1.0
a = (xyz_star_ogrid(dir) - xyz0_ogrid(dir)) / Lxyz_ogrid(dir)
a = a * b / sqrt(1.0 + 2.0 * a * (1.0 - a) * c)
b = (sqrt(1.0 + a * a) * b - a * c) / Lxyz_ogrid(dir)
xi = (arcsinh(a) + arcsinh(b * (x - xyz0_ogrid(dir)) - a)) / (coeff_grid_o(dir) * h)
!
case default func
call fatal_error('inverse_grid_ogrid', 'unknown grid function ' // trim(grid_func_ogrid(dir)))
!
endselect func
!
! Shift to match the global index space.
!
if (dir==2 .or. (dir==3 .and. lperi(dir))) then
xi = xi + real(nghost) + 0.5
else
xi = xi + real(nghost + 1)
endif
!
! Convert to the local index space if requested.
!
if (loc) xi = xi - real(shift)
!
endsubroutine inverse_grid_ogrid
!***********************************************************************
subroutine construct_serial_arrays
!
! The arrays xyz are local only, yet sometimes the serial array is
! needed. Construct here the serial arrays out of the local ones,
! but gathering them processor-wise and broadcasting the constructed
! array. This is only done in start time, so legibility (3 near-copies
! of the same code) is preferred over code-reusability (one general
! piece of code called three times).
!
! 31-jan-17/Jorgen: Adapted from construct_serial_arrays in grid.f90
!
use General, only: find_proc
use Mpicomm, only: mpisend_real,mpirecv_real,mpibcast_real, mpiallreduce_sum_int
!
real, dimension(nx_ogrid) :: xrecv, x1recv, x2recv
real, dimension(ny_ogrid) :: yrecv, y1recv, y2recv
real, dimension(nz_ogrid) :: zrecv, z1recv, z2recv
integer :: jx,jy,jz,iup,ido,iproc_recv
integer :: iproc_first, iproc_last
!
xrecv=0.; yrecv=0.; zrecv=0.
x1recv=0.; y1recv=0.; z1recv=0.
x2recv=0.; y2recv=0.; z2recv=0.
!
! Serial x array
!
if (iproc/=root) then
!
! All processors of the same row (ipx,ipy or ipz)
! send their array values to the root.
!
if ((ipy==0).and.(ipz==0)) then
call mpisend_real(x_ogrid(l1_ogrid:l2_ogrid),nx_ogrid,root,111)
call mpisend_real(dx_1_ogrid(l1_ogrid:l2_ogrid),nx_ogrid,root,112)
call mpisend_real(dx_tilde_ogrid(l1_ogrid:l2_ogrid),nx_ogrid,root,113)
endif
else
!
! The root processor, in turn, receives the data from the others
!
do jx=0,nprocx-1
!avoid send-to-self
if (jx/=root) then
!
! Formula of the serial processor number:
! iproc=ipx+nprocx*ipy+nprocx*nprocy*ipz
! Since for the x-row ipy=ipz=0, this reduces
! to iproc_recv=jx.
!
iproc_recv=find_proc(jx,0,0)
call mpirecv_real(xrecv,nx_ogrid,iproc_recv,111)
call mpirecv_real(x1recv,nx_ogrid,iproc_recv,112)
call mpirecv_real(x2recv,nx_ogrid,iproc_recv,113)
!
ido=jx *nx_ogrid + 1
iup=(jx+1)*nx_ogrid
xgrid_ogrid(ido:iup)=xrecv
dx1grid_ogrid(ido:iup)=x1recv
dxtgrid_ogrid(ido:iup)=x2recv
else
!the root just copies its value to the serial array
xgrid_ogrid(1:nx_ogrid)=x_ogrid(l1_ogrid:l2_ogrid)
dx1grid_ogrid(1:nx_ogrid)=dx_1_ogrid(l1_ogrid:l2_ogrid)
dxtgrid_ogrid(1:nx_ogrid)=dx_tilde_ogrid(l1_ogrid:l2_ogrid)
endif
enddo
endif
!
! Serial array constructed. Broadcast the result. Repeat the
! procedure for y and z arrays.
!
call mpibcast_real(xgrid_ogrid,nxgrid_ogrid)
call mpibcast_real(dx1grid_ogrid,nxgrid_ogrid)
call mpibcast_real(dxtgrid_ogrid,nxgrid_ogrid)
!
! Serial y-array
!
if (iproc/=root) then
if (ipx==0.and.ipz==0) then
call mpisend_real(y_ogrid(m1_ogrid:m2_ogrid),ny_ogrid,root,221)
call mpisend_real(dy_1_ogrid(m1_ogrid:m2_ogrid),ny_ogrid,root,222)
call mpisend_real(dy_tilde_ogrid(m1_ogrid:m2_ogrid),ny_ogrid,root,223)
endif
else
do jy=0,nprocy-1
if (jy/=root) then
iproc_recv=find_proc(0,jy,0)
call mpirecv_real(yrecv,ny_ogrid,iproc_recv,221)
call mpirecv_real(y1recv,ny_ogrid,iproc_recv,222)
call mpirecv_real(y2recv,ny_ogrid,iproc_recv,223)
ido=jy *ny_ogrid + 1
iup=(jy+1)*ny_ogrid
ygrid_ogrid(ido:iup)=yrecv
dy1grid_ogrid(ido:iup)=y1recv
dytgrid_ogrid(ido:iup)=y2recv
else
ygrid_ogrid(1:ny_ogrid)=y_ogrid(m1_ogrid:m2_ogrid)
dy1grid_ogrid(1:ny_ogrid)=dy_1_ogrid(m1_ogrid:m2_ogrid)
dytgrid_ogrid(1:ny_ogrid)=dy_tilde_ogrid(m1_ogrid:m2_ogrid)
endif
enddo
endif
call mpibcast_real(ygrid_ogrid,nygrid_ogrid)
call mpibcast_real(dy1grid_ogrid,nygrid_ogrid)
call mpibcast_real(dytgrid_ogrid,nygrid_ogrid)
!
! Serial z-array
!
if (iproc/=root) then
if (ipx==0.and.ipy==0) then
call mpisend_real(z_ogrid(n1_ogrid:n2_ogrid),nz_ogrid,root,331)
call mpisend_real(dz_1_ogrid(n1_ogrid:n2_ogrid),nz_ogrid,root,332)
call mpisend_real(dz_tilde_ogrid(n1_ogrid:n2_ogrid),nz_ogrid,root,333)
endif
else
do jz=0,nprocz-1
if (jz/=root) then
iproc_recv=find_proc(0,0,jz)
call mpirecv_real(zrecv,nz_ogrid,iproc_recv,331)
call mpirecv_real(z1recv,nz_ogrid,iproc_recv,332)
call mpirecv_real(z2recv,nz_ogrid,iproc_recv,333)
ido=jz *nz_ogrid + 1
iup=(jz+1)*nz_ogrid
zgrid_ogrid(ido:iup)=zrecv
dz1grid_ogrid(ido:iup)=z1recv
dztgrid_ogrid(ido:iup)=z2recv
else
zgrid_ogrid(1:nz_ogrid)=z_ogrid(n1_ogrid:n2_ogrid)
dz1grid_ogrid(1:nz_ogrid)=dz_1_ogrid(n1_ogrid:n2_ogrid)
dztgrid_ogrid(1:nz_ogrid)=dz_tilde_ogrid(n1_ogrid:n2_ogrid)
endif
enddo
endif
call mpibcast_real(zgrid_ogrid,nzgrid_ogrid)
call mpibcast_real(dz1grid_ogrid,nzgrid_ogrid)
call mpibcast_real(dztgrid_ogrid,nzgrid_ogrid)
!
! Check the first and last processors.
!
iup = 0
if (lfirst_proc_xyz) iup = iproc
ido = 0
if (llast_proc_xyz) ido = iproc
call mpiallreduce_sum_int(iup, iproc_first)
call mpiallreduce_sum_int(ido, iproc_last)
!
! Communicate the ghost cells.
!
xglobal_ogrid(nghost+1:mxgrid_ogrid-nghost) = xgrid_ogrid
yglobal_ogrid(nghost+1:mygrid_ogrid-nghost) = ygrid_ogrid
zglobal_ogrid(nghost+1:mzgrid_ogrid-nghost) = zgrid_ogrid
xglobal_ogrid(1:nghost) = x_ogrid(1:nghost)
yglobal_ogrid(1:nghost) = y_ogrid(1:nghost)
zglobal_ogrid(1:nghost) = z_ogrid(1:nghost)
!
xglobal_ogrid(mxgrid_ogrid-nghost+1:mxgrid_ogrid) = x_ogrid(mx_ogrid-nghost+1:mx_ogrid)
yglobal_ogrid(mygrid_ogrid-nghost+1:mygrid_ogrid) = y_ogrid(my_ogrid-nghost+1:my_ogrid)
zglobal_ogrid(mzgrid_ogrid-nghost+1:mzgrid_ogrid) = z_ogrid(mz_ogrid-nghost+1:mz_ogrid)
!
call mpibcast_real(xglobal_ogrid(1:nghost), nghost, iproc_first)
call mpibcast_real(yglobal_ogrid(1:nghost), nghost, iproc_first)
call mpibcast_real(zglobal_ogrid(1:nghost), nghost, iproc_first)
!
call mpibcast_real(xglobal_ogrid(mxgrid_ogrid-nghost+1:mxgrid_ogrid), nghost, iproc_last)
call mpibcast_real(yglobal_ogrid(mygrid_ogrid-nghost+1:mygrid_ogrid), nghost, iproc_last)
call mpibcast_real(zglobal_ogrid(mzgrid_ogrid-nghost+1:mzgrid_ogrid), nghost, iproc_last)
!
! Do the same for the 1/dx arrays
!
dx1global_ogrid(nghost+1:mxgrid_ogrid-nghost) = dx1grid_ogrid
dy1global_ogrid(nghost+1:mygrid_ogrid-nghost) = dy1grid_ogrid
dz1global_ogrid(nghost+1:mzgrid_ogrid-nghost) = dz1grid_ogrid
!
dx1global_ogrid(1:nghost) = dx_1_ogrid(1:nghost)
dy1global_ogrid(1:nghost) = dy_1_ogrid(1:nghost)
dz1global_ogrid(1:nghost) = dz_1_ogrid(1:nghost)
!
dx1global_ogrid(mxgrid_ogrid-nghost+1:mxgrid_ogrid) = dx_1_ogrid(mx_ogrid-nghost+1:mx_ogrid)
dy1global_ogrid(mygrid_ogrid-nghost+1:mygrid_ogrid) = dy_1_ogrid(my_ogrid-nghost+1:my_ogrid)
dz1global_ogrid(mzgrid_ogrid-nghost+1:mzgrid_ogrid) = dz_1_ogrid(mz_ogrid-nghost+1:mz_ogrid)
!
call mpibcast_real(dx1global_ogrid(1:nghost), nghost, iproc_first)
call mpibcast_real(dy1global_ogrid(1:nghost), nghost, iproc_first)
call mpibcast_real(dz1global_ogrid(1:nghost), nghost, iproc_first)
!
call mpibcast_real(dx1global_ogrid(mxgrid_ogrid-nghost+1:mxgrid_ogrid), nghost, iproc_last)
call mpibcast_real(dy1global_ogrid(mygrid_ogrid-nghost+1:mygrid_ogrid), nghost, iproc_last)
call mpibcast_real(dz1global_ogrid(mzgrid_ogrid-nghost+1:mzgrid_ogrid), nghost, iproc_last)
!
endsubroutine construct_serial_arrays
!***********************************************************************
subroutine get_grid_mn_ogrid()
!
! Gets the geometry of the pencil at each (m,n) in the mn-loop.
!
! 31-jan-17/Jorgen: Adapted from get_grid_mn in grid.f90
dline_1_ogrid(:,1) = dx_1_ogrid(l1_ogrid:l2_ogrid)
dline_1_ogrid(:,2) = rcyl_mn1_ogrid * dy_1_ogrid(m_ogrid)
dline_1_ogrid(:,3) = dz_1_ogrid(n_ogrid)
!
dxmax_pencil_ogrid = 0.
dxmin_pencil_ogrid = 0.
if (nxgrid_ogrid /= 1) then
dxmax_pencil_ogrid = 1.0 / dline_1_ogrid(:,1)
dxmin_pencil_ogrid = 1.0 / dline_1_ogrid(:,1)
endif
if (nygrid_ogrid /= 1) then
dxmax_pencil_ogrid = max(1.0 / dline_1_ogrid(:,2), dxmax_pencil_ogrid)
dxmin_pencil_ogrid = min(1.0 / dline_1_ogrid(:,2), dxmin_pencil_ogrid)
endif
if (nzgrid_ogrid /= 1) then
dxmax_pencil_ogrid = max(1.0 / dline_1_ogrid(:,3), dxmax_pencil_ogrid)
dxmin_pencil_ogrid = min(1.0 / dline_1_ogrid(:,3), dxmin_pencil_ogrid)
endif
!
if (lmaximal_cdtv) then
dxyz_2_ogrid = max(dline_1_ogrid(:,1)**2, dline_1_ogrid(:,2)**2, dline_1_ogrid(:,3)**2)
dxyz_4_ogrid = max(dline_1_ogrid(:,1)**4, dline_1_ogrid(:,2)**4, dline_1_ogrid(:,3)**4)
dxyz_6_ogrid = max(dline_1_ogrid(:,1)**6, dline_1_ogrid(:,2)**6, dline_1_ogrid(:,3)**6)
else
dxyz_2_ogrid = dline_1_ogrid(:,1)**2 + dline_1_ogrid(:,2)**2 + dline_1_ogrid(:,3)**2
dxyz_4_ogrid = dline_1_ogrid(:,1)**4 + dline_1_ogrid(:,2)**4 + dline_1_ogrid(:,3)**4
dxyz_6_ogrid = dline_1_ogrid(:,1)**6 + dline_1_ogrid(:,2)**6 + dline_1_ogrid(:,3)**6
endif
!
dVol_ogrid = dVol_x_ogrid(l1_ogrid:l2_ogrid)*dVol_y_ogrid(m_ogrid)*dVol_z_ogrid(n_ogrid)
!
endsubroutine get_grid_mn_ogrid
!***********************************************************************
subroutine time_step_ogrid(f_cartesian)
!
! Perform time steps on the curvilinear grid, including interpolation of
! flow variables back and forth between the overlapping grids.
! The time iterations should equal to one time step on the cartesian grid
!
! 07-feb-17/Jorgen+Nils: Adapded from timestep.f90
!
use Mpicomm, only: mpifinalize, mpiallreduce_max
use Boundcond, only: update_ghosts
use EquationOfState, only: lpres_grad
! use Energy, only: lpres_grad
!
real, dimension (mx,my,mz,mfarray) :: f_cartesian
real, dimension (mx_ogrid,my_ogrid,mz_ogrid,mvar) :: df_ogrid
real :: dt_ogrid
integer :: tstep_ogrid
integer :: j,jj=0, tss=0
real, dimension(3) :: alpha_ts_ogrid=0.,beta_ts_ogrid=0.,dt_beta_ts_ogrid=0.
!call run_tests_ogrid
if (.not.lrk_tvd) then
!
! Coefficients for up to order 3.
!
if (itorder==1) then
alpha_ts_ogrid=(/ 0.0, 0.0, 0.0 /)
beta_ts_ogrid=(/ 1.0, 0.0, 0.0 /)
elseif (itorder==2) then
alpha_ts_ogrid=(/ 0.0, -1/2.0, 0.0 /)
beta_ts_ogrid=(/ 1/2.0, 1.0, 0.0 /)
elseif (itorder==3) then
! use coefficients of Williamson (1980)
alpha_ts_ogrid=(/ 0.0, -5/9.0 , -153/128.0 /)
beta_ts_ogrid=(/ 1/3.0, 15/16.0, 8/15.0 /)
else
if (lroot) print*,'Not implemented: itorder=',itorder
call mpifinalize
endif
endif
!
! Interpolate data from cartesian to curvilinear grid.
! Before interpolating, necessary points outside this processors domain are
! recieved from appropriate processor
!
call update_ghosts(f_cartesian,1,mvar)
if (lchemistry .and. linterp_pressure) then
call communicate_ip_cart_to_curv(f_cartesian,1,mvar+2)
else
call communicate_ip_cart_to_curv(f_cartesian,1,mvar)
endif
!
dt_ogrid = dt/timestep_factor
!print*, 'dt_ogrid', dt_ogrid
!print*, 'convective timestep', dxmin_ogrid/maxval(f_ogrid(:,:,4,iux:iuy))
!print*, 'viscous timestep', dxmin_ogrid**2/1.e-3
if (.not. lrk_tvd) dt_beta_ts_ogrid=dt_ogrid*beta_ts_ogrid
!
! Perform a number of timestep equal to timestep_factor, such that the
! endtime t_ogrid is equal to t after the timesteps
!
tss = tss + 1
do tstep_ogrid=1,timestep_factor
!
! Set up df for each time sub.
!
df_ogrid=0.0
if (lrk_tvd) then
! First subtimestep
call pde_ogrid(f_ogrid,df_ogrid,dt_ogrid)
do j=1,mvar
f_tmp(l1_ogrid:l2_ogrid,m1_ogrid:m2_ogrid,n1_ogrid:n2_ogrid,j) = &
f_ogrid(l1_ogrid:l2_ogrid,m1_ogrid:m2_ogrid,n1_ogrid:n2_ogrid,j) &
+ dt_ogrid*df_ogrid(l1_ogrid:l2_ogrid,m1_ogrid:m2_ogrid,n1_ogrid:n2_ogrid,j)
enddo
f_tmp(l2_ogrid+1:mx_ogrid,:,:,:)=f_ogrid(l2_ogrid+1:mx_ogrid,:,:,:)
! Second subtimestep
df_ogrid=0.0
call pde_ogrid(f_tmp,df_ogrid,dt_ogrid)
do j=1,mvar
f_tmp(l1_ogrid:l2_ogrid,m1_ogrid:m2_ogrid,n1_ogrid:n2_ogrid,j) = &
(3./4.)*f_ogrid(l1_ogrid:l2_ogrid,m1_ogrid:m2_ogrid,n1_ogrid:n2_ogrid,j) &
+(1./4.)*(f_tmp(l1_ogrid:l2_ogrid,m1_ogrid:m2_ogrid,n1_ogrid:n2_ogrid,j) &
+dt_ogrid*df_ogrid(l1_ogrid:l2_ogrid,m1_ogrid:m2_ogrid,n1_ogrid:n2_ogrid,j))
enddo
! Third subtimestep
llast_ogrid=(tstep_ogrid==timestep_factor)
df_ogrid=0.0
call pde_ogrid(f_tmp,df_ogrid,dt_ogrid)
do j=1,mvar
f_ogrid(l1_ogrid:l2_ogrid,m1_ogrid:m2_ogrid,n1_ogrid:n2_ogrid,j) = &
(1./3.)*f_ogrid(l1_ogrid:l2_ogrid,m1_ogrid:m2_ogrid,n1_ogrid:n2_ogrid,j) &
+(2./3.)*(f_tmp(l1_ogrid:l2_ogrid,m1_ogrid:m2_ogrid,n1_ogrid:n2_ogrid,j) &
+dt_ogrid*df_ogrid(l1_ogrid:l2_ogrid,m1_ogrid:m2_ogrid,n1_ogrid:n2_ogrid,j))
enddo
else
do itsub=1,itorder
df_ogrid=alpha_ts_ogrid(itsub)*df_ogrid
llast_ogrid=(tstep_ogrid==timestep_factor).and.(itsub==itorder)
!
! Change df according to the chosen physics modules.
!
call pde_ogrid(f_ogrid,df_ogrid,dt_ogrid)
!
! Time evolution of grid variables.
!
do j=1,mvar
f_ogrid(l1_ogrid:l2_ogrid,m1_ogrid:m2_ogrid,n1_ogrid:n2_ogrid,j) = &
f_ogrid(l1_ogrid:l2_ogrid,m1_ogrid:m2_ogrid,n1_ogrid:n2_ogrid,j) &
+ dt_beta_ts_ogrid(itsub)*df_ogrid(l1_ogrid:l2_ogrid,m1_ogrid:m2_ogrid,n1_ogrid:n2_ogrid,j)
enddo
enddo
endif
! if (lfilter_solution) then
! call communicate_filter_zones(f_ogrid,f_filterH_lowerx,f_filterH_upperx,f_filterH_lowery,f_filterH_uppery)
! call pade_filter(f_ogrid)
! call update_ghosts_ogrid(f_ogrid)
! endif
enddo
!
! Interpolate data from curvilinear to cartesian grid.
! Before interpolating, necessary points outside this processors domain are
! recieved from appropriate processor
!
call update_ghosts_ogrid(f_ogrid)
!
! Filter solution if this option is set
!
if (mod(tss,filter_frequency)==0 .and. lfilter_solution) then
call communicate_filter_zones(f_ogrid,f_filterH_lowerx,f_filterH_upperx,f_filterH_lowery,f_filterH_uppery)
call pade_filter(f_ogrid)
call update_ghosts_ogrid(f_ogrid)
endif
if (lpres_grad .and. (lchemistry .and. linterp_pressure)) then
call communicate_ip_curv_to_cart(f_cartesian,1,mvar+4)
elseif (lpres_grad .or. (lchemistry .and. linterp_pressure)) then
call communicate_ip_curv_to_cart(f_cartesian,1,mvar+2)
else
call communicate_ip_curv_to_cart(f_cartesian,1,mvar)
endif
!
! !TODO: Should use the particle flow info in the interpolation point
! ! computation above
if (lparticles) call update_ogrid_flow_info(ivar1_part,ivar2_part)
!
call wsnap_ogrid('OGVAR',ENUM=.true.,FLIST='ogvarN.list')
if (llast .and. lwrite_mdotc) call write_reactions(heter_reaction_rate(:,4,:))
!
! Set silly values for f_cartesian inside r_int_inner
!
! for debugging
! do ii=l1,l2
! do jj=m1,m2
! do kk=n1,n2
! if (radius_ogrid(x(ii),y(jj))<(r_int_inner)) then
! f_cartesian(ii,jj,:,:)=huge_real
! endif
! enddo
! enddo
! enddo
endsubroutine time_step_ogrid
!***********************************************************************
subroutine write_reactions(mdots)
!
! write mdot_C in the output file
!
use Mpicomm, only: mpibarrier
character(len=fnlen) :: input_file="./data/mdotc.out"
integer :: file_id=123, i
real, dimension (my_ogrid,6) :: mdots
!
do i=0,ncpus
if (iproc .eq. i) then
open (file_id,file=input_file,POSITION='APPEND',FORM='FORMATTED')
write (file_id,*) 'Proc',iproc
write (file_id,*) 'Mdot_C',mdots(:,nchemspec+1)
write (file_id,*) 'Mdot_CO2',mdots(:,ichem_CO2)
write (file_id,*) 'Mdot_O2',mdots(:,ichem_O2)
write (file_id,*) 'Theta',y_ogrid
close (file_id)
endif
call mpibarrier
enddo
!
endsubroutine write_reactions
!***********************************************************************
subroutine pde_ogrid(f_og,df,dt_ogrid)
!
! 06-feb-17/Jorgen+Nils: Adapded from equ.f90
!
! Call the different evolution equations.
!
real, dimension (mx_ogrid,my_ogrid,mz_ogrid,mvar) :: df
integer :: nyz_ogrid
real, dimension (mx_ogrid, my_ogrid, mz_ogrid,mfarray_ogrid), intent(inout) :: f_og
intent(out) :: df
real :: c_dragx,c_dragy, Nusselt, dt_ogrid
real,dimension (3) :: mdot_C
c_dragx=0.
c_dragy=0.
Nusselt=0.
mdot_C(:) =0.
!
! Initiate communication and do boundary conditions.
!
call boundconds_x_ogrid(f_og)
call update_ghosts_ogrid(f_og)
if (lchemistry) call chemspec_normalization_N2_og(f_og)
!
if (lchemistry) call calc_for_chem_mixture_ogrid(f_og)
!
!------------------------------------------------------------------------------
! Do loop over m and n.
!
nyz_ogrid=ny_ogrid*nz_ogrid
mn_loop: do imn_ogrid=1,nyz_ogrid
n_ogrid=nn_ogrid(imn_ogrid)
m_ogrid=mm_ogrid(imn_ogrid)
!
! Grid spacing. In case of equidistant grid and cartesian coordinates
! this is calculated before the (m,n) loop.
!
call get_grid_mn_ogrid
!
! Calculate grid/geometry related pencils.
!
call calc_pencils_grid_ogrid
!
! Calculate pencils for the pencil_case.
!
call calc_pencils_hydro_ogrid(f_og)
call calc_pencils_density_ogrid(f_og)
if (.not. lchemistry) then
call calc_pencils_eos_ogrid(f_og)
else
call calc_pencils_eos_ogrid_chem(f_og)
endif
call calc_pencils_energy_ogrid(f_og)
call calc_pencils_viscosity_ogrid
if (lchemistry) then
call calc_pencils_chemistry_ogrid(f_og)
if (lreac_heter) call calc_heter_reaction_term(f_og)
endif
!
! --------------------------------------------------------
! NO CALLS MODIFYING PENCIL_CASE PENCILS BEYOND THIS POINT
! --------------------------------------------------------
!
! hydro, density, and entropy evolution
! Note that pressure gradient is added in denergy_dt of noentropy to momentum,
! even if lentropy=.false.
!
call duu_dt_ogrid(df)
call dlnrho_dt_ogrid(df)
call denergy_dt_ogrid(df,f_og)
if (lchemistry) call dYk_dt_ogrid(f_og,df,dt_ogrid)
!
! Compute drag and lift coefficient, if this is the last sub-timestep
!
if (llast_ogrid.and.lfirst_proc_x) then
if ((idiag_c_dragx/=0).or.(idiag_c_dragy/=0)) then
call drag_force_pencils(c_dragx,c_dragy)
endif
if (idiag_Nusselt/=0) then
call Nusselt_pencils(Nusselt)
endif
if (lchemistry .and. lreac_heter .and. idiag_mdot_C/=0) then
call mdot_C_pencils(mdot_C)
endif
endif
!
! End of loops over m and n.
!
enddo mn_loop
!
if (llast_ogrid) then
if ((idiag_c_dragx/=0).or.(idiag_c_dragy/=0)) then
call drag_coeffs(c_dragx,c_dragy)
endif
if (idiag_Nusselt/=0) then
call Nusselt_coeffs(Nusselt)
endif
if (lchemistry .and. lreac_heter .and. idiag_mdot_C/=0) then
call mdot_C_coeffs(mdot_C)
endif
endif
!
! -------------------------------------------------------------
! NO CALLS MODIFYING DF BEYOND THIS POINT (APART FROM FREEZING)
! -------------------------------------------------------------
! Frerzing must be done after the full (m,n) loop, as df may be modified
! outside of the considered pencil.
!
! Freezing boundary conditions in x (radial direction), only on points
! at the surface
!
if (lfirst_proc_x) then
do imn_ogrid=1,nyz_ogrid
n_ogrid=nn_ogrid(imn_ogrid)
m_ogrid=mm_ogrid(imn_ogrid)
df(l1_ogrid,m_ogrid,n_ogrid,iux:iuz) = 0.
if (lexpl_rho) df(l1_ogrid,m_ogrid,n_ogrid,irho) = 0.
if (iTT .gt. 0) df(l1_ogrid,m_ogrid,n_ogrid,iTT) = 0.
if (lchemistry) &
df(l1_ogrid,m_ogrid,n_ogrid,ichemspec(1):ichemspec(nchemspec)) = 0.
enddo
endif
!
endsubroutine pde_ogrid
!***********************************************************************
subroutine duu_dt_ogrid(df)
!
! velocity evolution
! calculate du/dt = - u.gradu - 2Omega x u + grav + Fvisc
! pressure gradient force added in density and entropy modules.
!
real, dimension (mx_ogrid,my_ogrid,mz_ogrid,mvar) :: df
intent(inout) :: df
!
! Advection term.
!
df(l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,iux:iuz) = df(l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,iux:iuz)-p_ogrid%ugu
!
! Viscous term
!
df(l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,iux:iuz) = df(l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,iux:iuz) + p_ogrid%fvisc
!
endsubroutine duu_dt_ogrid
!***********************************************************************
subroutine dlnrho_dt_ogrid(df)
!
! Continuity equation.
! Calculate dlnrho/dt = - u.gradlnrho - divu
!
real, dimension (mx_ogrid,my_ogrid,mz_ogrid,mvar) :: df
intent(inout) :: df
!
real, dimension (nx_ogrid) :: density_rhs
!
! Continuity equation.
!
density_rhs= - p_ogrid%ugrho - p_ogrid%rho*p_ogrid%divu
!
! Add the continuity equation terms to the RHS of the density df.
!
df(l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,irho) = df(l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,irho) + density_rhs
!
endsubroutine dlnrho_dt_ogrid
!***********************************************************************
subroutine denergy_dt_ogrid(df,f_og)
!
! Calculate pressure gradient term for isothermal/polytropic equation
! of state.
!
real, dimension(mx_ogrid,my_ogrid,mz_ogrid,mfarray_ogrid), intent(in) :: f_og
real, dimension (mx_ogrid,my_ogrid,mz_ogrid,mvar) :: df
integer :: j
intent(inout) :: df
!
! Add isothermal/polytropic pressure term in momentum equation.
!
! if (.not. lchemistry) then
df(l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,iux:iuz)= &
df(l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,iux:iuz)+p_ogrid%fpres
! else
! TODO: pressure gradient term when chemistry
! df(l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,iux:iuz)= &
! df(l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,iux:iuz)-p_ogrid%rho1gpp
! endif
!
! Solve Energy equation (in case of non-isothermal equation of state)
!
if (iTT .ne. 0) then
!
! Advection term and PdV-work.
!
if (ladvection_temperature) then
df(l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,iTT) = &
df(l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,iTT) - p_ogrid%ugTT
endif
!
! Add divu term.
! If lchemistry divu is added in dYk_dt
!
if (ldensity .and. (.not. lchemistry)) then
df(l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,iTT) = &
df(l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,iTT) - &
gamma_m1*p_ogrid%TT*p_ogrid%divu
endif
!
! Calculate viscous contribution to temperature.
!
! if (lviscosity.and.lviscosity_heat) call calc_viscous_heat(df,p,Hmax)
!
! Thermal conduction
!
if (lheatc_chiconst) then
call calc_heatcond_constchi_ogrid(df,p_ogrid)
elseif (lheatc_chemistry) then
call calc_heatcond_chemistry_ogrid(f_og,df)
else
call fatal_error('denergy_dt_ogrid','Must use lheatc_chicons=T or lheatc_chemistry=T')
endif
!
endif
!
endsubroutine denergy_dt_ogrid
!***********************************************************************
subroutine calc_heatcond_constchi_ogrid(df,p_ogrid)
!
! Calculate the radiative diffusion term for constant chi:
! lnTT version: cp*chi*Div(rho*TT*glnTT)/(rho*cv*TT)
! = gamma*chi*(g2.glnTT+g2lnTT) where g2=glnrho+glnTT
! TT version: cp*chi*Div(rho*gTT)/(rho*cv)
! = gamma*chi*(g2.gTT+g2TT) where g2=glnrho
!
! 17-aug-17/ewa+nils: adapted from temperature_idealgas
!
use Diagnostics, only: max_mn_name
use Sub, only: dot
!
real, dimension (mx_ogrid,my_ogrid,mz_ogrid,mvar) :: df
type (pencil_case_ogrid) :: p_ogrid
real, dimension (nx_ogrid) :: g2
!
intent(in) :: p_ogrid
intent(inout) :: df
!
call dot(p_ogrid%glnrho,p_ogrid%gTT,g2)
g2=g2+p_ogrid%del2TT
!
! Add heat conduction to RHS of temperature equation.
!
df(l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,iTT) = &
df(l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,iTT) + gamma*chi*g2
!
endsubroutine calc_heatcond_constchi_ogrid
!***********************************************************************
subroutine calc_pencils_hydro_ogrid(f_og)
!
! Calculate Hydro pencils.
! Most basic pencils should come first, as others may depend on them.
!
! Pencils: uu, u2, uij, divu, sij, sij2, ugu, ugu2, del2u
!
real, dimension (mx_ogrid, my_ogrid, mz_ogrid,mfarray_ogrid), intent(inout) :: f_og
if (lpencil_ogrid(i_og_uu)) p_ogrid%uu=f_og (l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,iux:iuz)
if (lpencil_ogrid(i_og_u2)) call dot2_mn_ogrid(p_ogrid%uu,p_ogrid%u2)
if (lpencil_ogrid(i_og_uij)) call gij_ogrid(f_og ,iuu,p_ogrid%uij)!,1)
if (lpencil_ogrid(i_og_divu)) call div_mn_ogrid(p_ogrid%uij,p_ogrid%divu,p_ogrid%uu)
if (lpencil_ogrid(i_og_sij)) call traceless_strain_ogrid(p_ogrid%uij,p_ogrid%divu,p_ogrid%sij,p_ogrid%uu)
if (lpencil_ogrid(i_og_sij2)) call multm2_sym_mn_ogrid(p_ogrid%sij,p_ogrid%sij2)
if (lpencil_ogrid(i_og_ugu)) call u_dot_grad_ogrid(f_og ,iuu,p_ogrid%uij,p_ogrid%uu,p_ogrid%ugu)
if (lpencil_ogrid(i_og_ugu2)) call dot2_mn_ogrid(p_ogrid%ugu,p_ogrid%ugu2)
if (lpencil_ogrid(i_og_graddivu).and.lpencil_ogrid(i_og_del2u)) then
call gij_etc_ogrid(f_og ,iuu,p_ogrid%uu,p_ogrid%uij,DEL2=p_ogrid%del2u,GRADDIV=p_ogrid%graddivu)
elseif (lpencil_ogrid(i_og_graddivu)) then
call gij_etc_ogrid(f_og ,iuu,p_ogrid%uu,p_ogrid%uij,GRADDIV=p_ogrid%graddivu)
elseif (lpencil_ogrid(i_og_del2u)) then
call gij_etc_ogrid(f_og ,iuu,p_ogrid%uu,p_ogrid%uij,DEL2=p_ogrid%del2u)
endif
!
endsubroutine calc_pencils_hydro_ogrid
!***********************************************************************
subroutine calc_pencils_density_ogrid(f_og)
!
! Calculate Density pencils for linear density.
! Most basic pencils should come first, as others may depend on them.
!
! 10-feb-17/Jorgen+Nils: Adapted from calc_pencils_linear_density in density.f90
!
use density, only:lupw_lnrho
!
integer :: i
real, dimension (mx_ogrid, my_ogrid, mz_ogrid,mfarray_ogrid), intent(inout) :: f_og
!
! Pencils: rho, rho1, lnrho, glnrho, grho, ugrho, sglnrho
!
p_ogrid%rho=f_og (l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,irho)
if (lpencil_ogrid(i_og_rho1)) p_ogrid%rho1=1.0/p_ogrid%rho
if (lpencil_ogrid(i_og_lnrho)) p_ogrid%lnrho=log(p_ogrid%rho)
if (lpencil_ogrid(i_og_glnrho)) then
call grad_ogrid(f_og ,irho,p_ogrid%grho)
do i=1,3
p_ogrid%glnrho(:,i)=p_ogrid%rho1*p_ogrid%grho(:,i)
enddo
endif
if (lpencil_ogrid(i_og_ugrho)) call u_dot_grad_ogrid(f_og ,irho,p_ogrid%grho,p_ogrid%uu,p_ogrid%ugrho,UPWIND=lupw_lnrho)
if (lpencil_ogrid(i_og_sglnrho)) call multmv_mn_ogrid(p_ogrid%sij,p_ogrid%glnrho,p_ogrid%sglnrho)
!
endsubroutine calc_pencils_density_ogrid
!***********************************************************************
subroutine calc_pencils_eos_ogrid(f_og)
!
! Calculate EquationOfState pencils.
! Most basic pencils should come first, as others may depend on them.
!
! 10-feb-17/Jorgen+Nils: Adapted from calc_pencils_eos_pencpar in eos_idealgas.f90
!
use EquationOfState, only: cs20,lnrho0
!
real :: cv1
real, dimension (mx_ogrid, my_ogrid, mz_ogrid,mfarray_ogrid), intent(inout) :: f_og
cv1=1./cv
!
if (iTT .ne. 0) then
if (lpencil_ogrid(i_og_TT)) &
p_ogrid%TT=f_og (l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,iTT)
if (lpencil_ogrid(i_og_lnTT)) &
p_ogrid%lnTT=log(f_og (l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,iTT))
if (lpencil_ogrid(i_og_gTT)) call grad_ogrid(f_og ,iTT,p_ogrid%gTT)
if (lpencil_ogrid(i_og_cs2)) &
p_ogrid%cs2=cp*gamma_m1*f_og (l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,iTT)
if (lpencil_ogrid(i_og_pp)) p_ogrid%pp=cv*gamma_m1*p_ogrid%rho*p_ogrid%TT
if (lpencil_ogrid(i_og_del2TT)) call del2_ogrid(f_og ,iTT,p_ogrid%del2TT)
else
if (leos_isentropic) then
if (lpencil_ogrid(i_og_ss)) p_ogrid%ss=0.0
if (lpencil_ogrid(i_og_cs2)) &
p_ogrid%cs2=cs20*exp(gamma_m1*(p_ogrid%lnrho-lnrho0))
if (lpencil_ogrid(i_og_lnTT)) &
p_ogrid%lnTT=lnTT0+cv1*p_ogrid%ss+gamma_m1*(p_ogrid%lnrho-lnrho0)
if (lpencil_ogrid(i_og_pp)) &
p_ogrid%pp=(cp-cv)*exp(p_ogrid%lnTT+p_ogrid%lnrho)
elseif (leos_isothermal) then
if (lpencil_ogrid(i_og_ss)) p_ogrid%ss=-(cp-cv)*(p_ogrid%lnrho-lnrho0)
if (lpencil_ogrid(i_og_cs2)) p_ogrid%cs2=cs20
if (lpencil_ogrid(i_og_pp)) p_ogrid%pp=p_ogrid%cs2*p_ogrid%rho
endif
endif
! if (linterp_pressure) then
! f_og(l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,ipp) = p_ogrid%pp
! endif
endsubroutine calc_pencils_eos_ogrid
!***********************************************************************
subroutine calc_pencils_energy_ogrid(f_og)
!
! Calculate Energy pencils.
! Most basic pencils should come first, as others may depend on them.
!
use EquationOfState, only: lpres_grad
! use Energy, only: lpres_grad
!
integer :: j
real, dimension (mx_ogrid, my_ogrid, mz_ogrid,mfarray_ogrid), intent(inout) :: f_og
!
! Pencils: fpres (=pressure gradient force)
!
if (iTT .ne. 0) then
if (lpencil_ogrid(i_og_ugTT)) then
call u_dot_grad_ogrid(f_og ,iTT,p_ogrid%gTT,p_ogrid%uu,&
p_ogrid%ugTT,UPWIND=lupw_lnTT)
endif
if ((lpencil_ogrid(i_og_fpres)) .and. (.not. lchemistry)) then
do j=1,3
p_ogrid%fpres(:,j)=-gamma1*p_ogrid%cs2*&
(p_ogrid%glnrho(:,j)+p_ogrid%gTT(:,j)/p_ogrid%TT)
enddo
endif
else
if (lpencil_ogrid(i_og_fpres)) then
do j=1,3
p_ogrid%fpres(:,j)=-p_ogrid%cs2*p_ogrid%glnrho(:,j)
enddo
endif
endif
!
! Store pressure gradient as auxillary if requsted (this is done elswhere
! for cases with chemistry).
!
if (lpres_grad .and. (.not. lchemistry)) then
if (igpx == 0 .or. igpy == 0) then
call fatal_error('calc_pencils_energy_ogrid',&
'igpx and igpy must be non-zero.')
endif
f_og(l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,igpx) = &
-p_ogrid%fpres(:,1)*p_ogrid%rho
f_og(l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,igpy) = &
-p_ogrid%fpres(:,2)*p_ogrid%rho
endif
!
endsubroutine calc_pencils_energy_ogrid
!***********************************************************************
subroutine calc_pencils_viscosity_ogrid
!
! Calculate Viscosity pencils.
! Most basic pencils should come first, as others may depend on them.
!
! 10-feb-17/Jorgen+Nils: Adapted from rountine in viscosity.f90
!
use viscosity, only:getnu
real :: nu
integer :: j
real, dimension (nx_ogrid,3) :: sgradnu
!
! Viscous force and viscous heating are calculated here (for later use).
!
p_ogrid%fvisc=0.0
!
if (.not. lchemistry) then
call getnu(nu_input=nu)
do j=1,3
p_ogrid%fvisc(:,j) = p_ogrid%fvisc(:,j) + nu*(2*p_ogrid%sglnrho(:,j)+p_ogrid%del2u(:,j) &
+ 1./3.*p_ogrid%graddivu(:,j))
!p_ogrid%fvisc(:,j) = p_ogrid%fvisc(:,j) + nu*(p_ogrid%del2u(:,j))
enddo
else
call multmv_mn_ogrid(p_ogrid%sij,p_ogrid%gradnu,sgradnu)
do j=1,3
p_ogrid%fvisc(:,j)=p_ogrid%nu*(p_ogrid%del2u(:,j)+1./3.*p_ogrid%graddivu(:,j)) + 2.*sgradnu(:,j)
enddo
if (ldensity) then
do j=1,3
p_ogrid%fvisc(:,j)=p_ogrid%fvisc(:,j) + 2.*p_ogrid%nu*p_ogrid%sglnrho(:,j)
enddo
endif
!
! Viscous heating and time step.
!
! if (lpencil(i_visc_heat)) p%visc_heat=p%visc_heat+2*p%nu*p%sij2
! if (lupdate_courant_dt) p%diffus_total=p%diffus_total+p%nu
!
endif
!
end subroutine calc_pencils_viscosity_ogrid
!***********************************************************************
! FROM BOUNDCOND.F90
!***********************************************************************
! ROUTINES
! boundconds_x_ogrid
! boundconds_y_ogrid
! boundconds_z_ogrid
!***********************************************************************
subroutine boundconds_x_ogrid(f_og)
!
! Boundary conditions at the cylinder surface in the radial direction (xdir).
! For ogrids, only boundary conditions at cylinder surface is set. The BC on
! the 'top' is set by interpolation from cartesian grid, outside the timestep.
! Only need to compute boundary value for the density, using stencil that
! satisfies the SBP energy conservation. No-slip on the surface is respected
! automatically since we set df(l1_ogrid,:,:,:)=0 after the mn-loop (freeze).
! If SBP is not used, the grid ponts inside the surface are computed using
! one-sided differences. Note that these do not guarantee stability!
!
! Remark: boundconds_x() needs to be called before communicating (because we
! communicate the x-ghost points), boundconds_[yz] after communication
! has finished (they need some of the data communicated for the edges
! (yz-'corners').
!
! 06-feb-17/Jorgen: Adapted from boundcond.f90 to be used for ogrids
! 06-apr-17/Jorgen: Cleanup and working with SBP property
!
! Only set cylinder boundary here, not processor boundaries
!
use density, only:lupw_lnrho
real, dimension (mx_ogrid, my_ogrid, mz_ogrid,mfarray_ogrid), intent(inout) :: f_og
integer :: k
!
if (lfirst_proc_x) then
if (SBP) then
! chemistry BCs are taken care of here
call bval_from_neumann_SBP(f_og)
elseif (BDRY5) then
call bval_from_neumann_bdry5(f_og)
if (lchemistry .and. lreac_heter) call fatal_error('boundconds_x_ogrid', &
'chemistry BCs with heterogeneous reactions set correctly only when SBP=T')
else
!TODO set f_og as input
call set_ghosts_onesided_ogrid(iux)
call set_ghosts_onesided_ogrid(iuy)
call set_ghosts_onesided_ogrid(iuz)
if (iTT .ne. 0) then
call set_ghosts_onesided_ogrid(iTT)
endif
call bval_from_neumann_arr_ogrid
call set_ghosts_onesided_ogrid(irho)
if (lchemistry) then
do k = 1,nchemspec
call set_ghosts_onesided_ogrid(ichemspec(k))
enddo
endif
! if (lreac_heter) call fatal_error('boundconds_x_ogrid', &
! 'chemistry BCs set correctly only when SBP=T')
endif
!if (lupw_lnrho) then
! if (lexpl_rho) call bval_from_neumann_upw_ogrid
! call set_ghosts_onesided_upw_ogrid(irho)
!endif
endif
!
endsubroutine boundconds_x_ogrid
!***********************************************************************
subroutine boundconds_y_ogrid(f_og)
!
! Periodic boundary condition for runs with a single processor in y-direction
!
! 06-feb-17/Jorgen: Adapted from boundcond.f90 to be used for ogrids where the
! y-dir is always periodic
!
integer :: ivar1, ivar2, j
integer :: m1i_ogrid=m1_ogrid+nghost-1
integer :: m2i_ogrid=my_ogrid-2*nghost+1
real, dimension (mx_ogrid, my_ogrid, mz_ogrid,mfarray_ogrid), intent(inout) :: f_og
!
! JONAS i did this change
!
ivar1=1; ivar2=min(mcom,size(f_og,4))
!
! Boundary conditions in y
! Periodic, with y being the theta direction for the cylindrical grid
!
do j=ivar1,ivar2
! Bottom boundary
f_og (:,1:m1_ogrid-1,:,j) = f_og (:,m2i_ogrid:m2_ogrid,:,j)
! Top boundary
f_og (:,m2_ogrid+1:,:,j) = f_og (:,m1_ogrid:m1i_ogrid,:,j)
enddo
!
if (lchemistry .and. linterp_pressure) then
f_og (:,1:m1_ogrid-1,:,ipp) = f_og (:,m2i_ogrid:m2_ogrid,:,ipp)
f_og (:,m2_ogrid+1:,:,ipp) = f_og (:,m1_ogrid:m1i_ogrid,:,ipp)
if (lchemistry) then
f_og (:,1:m1_ogrid-1,:,iRR) = f_og (:,m2i_ogrid:m2_ogrid,:,iRR)
f_og (:,m2_ogrid+1:,:,iRR) = f_og (:,m1_ogrid:m1i_ogrid,:,iRR)
endif
endif
endsubroutine boundconds_y_ogrid
!***********************************************************************
subroutine boundconds_z_ogrid(f_og)
!
! Periodic boundary condition for 3D-runs with a single processor in z-direction
!
! 06-feb-17/Jorgen: Adapted from boundcond.f90 to be used for ogrids where the
! z-dir is always periodic as long as nzgrid=/1
!
integer :: ivar1, ivar2, j
integer :: n1i_ogrid=n1_ogrid+nghost-1
integer :: n2i_ogrid=mz_ogrid-2*nghost+1
real, dimension (mx_ogrid, my_ogrid, mz_ogrid,mfarray_ogrid), intent(inout) :: f_og
!
ivar1=1; ivar2=min(mcom,size(f_og,4))
!
! Boundary conditions in z
!
do j=ivar1,ivar2
! Bottom boundary
f_og (:,:,1:n1_ogrid-1,j) = f_og (:,:,n2i_ogrid:n2_ogrid,j)
! Top boundary
f_og (:,:,n2_ogrid+1:,j) = f_og (:,:,n1_ogrid:n1i_ogrid,j)
enddo
!
if (lchemistry .and. linterp_pressure) then
f_og (:,:,1:n1_ogrid-1,ipp) = f_og (:,:,n2i_ogrid:n2_ogrid,ipp)
f_og (:,:,n2_ogrid+1:,ipp) = f_og (:,:,n1_ogrid:n1i_ogrid,ipp)
if (lchemistry) then
f_og (:,:,1:n1_ogrid-1,iRR) = f_og (:,:,n2i_ogrid:n2_ogrid,iRR)
f_og (:,:,n2_ogrid+1:,iRR) = f_og (:,:,n1_ogrid:n1i_ogrid,iRR)
endif
endif
!
endsubroutine boundconds_z_ogrid
!***********************************************************************
subroutine boundconds_y_filter(f_og,f_Hloy,f_Hupy,Hsize)
!
! Periodic boundary condition for runs with a single processor in y-direction
! Extended ghosts zones used if filtering is on
!
! 29-feb-17/Jorgen: Coded
!
integer :: ivar1, ivar2, j
integer :: m1i_ogrid=m1_ogrid+nghost-1
integer :: m2i_ogrid=my_ogrid-2*nghost+1
integer, intent(in) :: Hsize
real, dimension (mx_ogrid, my_ogrid, mz_ogrid,mfarray_ogrid) :: f_og
real, dimension (mx_ogrid,filter_Hsize,nz_ogrid,mfarray_ogrid) :: f_Hloy,f_Hupy
intent(in) :: f_og
intent(inout) :: f_Hloy,f_Hupy
!
ivar1=1; ivar2=min(mcom,size(f_og,4))
!
! Boundary conditions in y
! Periodic, with y being the theta direction for the cylindrical grid
!
do j=ivar1,ivar2
! Bottom boundary
f_Hloy(l1_ogrid:l2_ogrid,:,:,j) = f_og(l1_ogrid:l2_ogrid,m2i_ogrid-Hsize:m2i_ogrid-1,n1_ogrid:n2_ogrid,j)
! Top boundary
f_Hupy(l1_ogrid:l2_ogrid,:,:,j) = f_og(l1_ogrid:l2_ogrid,m1i_ogrid+1:m1i_ogrid+Hsize,n1_ogrid:n2_ogrid,j)
enddo
if (lchemistry .and. linterp_pressure) then
f_Hloy(l1_ogrid:l2_ogrid,:,:,ipp) = f_og(l1_ogrid:l2_ogrid,m2i_ogrid-Hsize:m2i_ogrid-1,n1_ogrid:n2_ogrid,ipp)
f_Hupy(l1_ogrid:l2_ogrid,:,:,ipp) = f_og(l1_ogrid:l2_ogrid,m1i_ogrid+1:m1i_ogrid+Hsize,n1_ogrid:n2_ogrid,ipp)
if (lchemistry) then
f_Hloy(l1_ogrid:l2_ogrid,:,:,iRR) = f_og(l1_ogrid:l2_ogrid,m2i_ogrid-Hsize:m2i_ogrid-1,n1_ogrid:n2_ogrid,iRR)
f_Hupy(l1_ogrid:l2_ogrid,:,:,iRR) = f_og(l1_ogrid:l2_ogrid,m1i_ogrid+1:m1i_ogrid+Hsize,n1_ogrid:n2_ogrid,iRR)
endif
endif
endsubroutine boundconds_y_filter
!***********************************************************************
subroutine gaunoise_ogrid(ampl,i1,i2)
!
! Add Gaussian noise (= normally distributed) white noise for variables i1:i2
!
! 13-feb-17/Jorgen: Adapted from gaunoise_vect in initcond.f90
!
use General, only: random_number_wrapper
real :: ampl
integer :: i1,i2
!
real, dimension (mx_ogrid) :: r,p,tmp
integer :: i
!
intent(in) :: ampl,i1,i2
!
! set gaussian random noise vector
!
if (ampl==0) then
if (lroot) print*,'gaunoise_ogrid: ampl=0 for i1,i2=',i1,i2
else
if ((ip<=8).and.lroot) print*,'gaunoise_ogrid: i1,i2=',i1,i2
do n=1,mz_ogrid; do m=1,my_ogrid
do i=i1,i2
if (lroot.and.m==1.and.n==1) print*,'gaunoise_ogrid: variable i=',i
if (modulo(i-i1,2)==0) then
call random_number_wrapper(r)
call random_number_wrapper(p)
tmp=sqrt(-2*log(r))*sin(2*pi*p)
else
tmp=sqrt(-2*log(r))*cos(2*pi*p)
endif
f_ogrid(:,m_ogrid,n_ogrid,i)=f_ogrid(:,m_ogrid,n_ogrid,i)+ampl*tmp
enddo
enddo; enddo
endif
!
endsubroutine gaunoise_ogrid
!***********************************************************************
subroutine find_proc_cartesian(xyz,from_proc,incl_gp)
!
! Find the processor that stores the grid points, and return the processor
! id and the grid index of the bottom neighbouring point on a global grid.
! Necessary for interpolation between grids on parallel systems
!
! 13-apr-17/Jorgen: Coded
! 19-apr-18/Jorgen: Added possibility to use ghost points
!
real, dimension(3), intent(in) :: xyz
integer, intent(out) :: from_proc
integer :: i,ishift
logical :: found_proc
logical, optional :: incl_gp
real, parameter :: fDP=1.e-15
!
found_proc=.false.
!
! If ghost points are included, check first current processor for the point
!
if (present(incl_gp)) then
if (interpolation_method==1) then
ishift=0
else
ishift=1
endif
if (incl_gp) then
if ( ((xyz(1)>(x(1+ishift))).and.(xyz(1)<(x(mx-ishift)))) .and. &
((xyz(2)>(y(1+ishift))).and.(xyz(2)<(y(my-ishift)))) .and. &
((xyz(3)>(z(1+ishift))).and.(xyz(3)<(z(mz-ishift)))) ) then
from_proc=iproc
found_proc=.true.
return
endif
endif
endif
do i=1,ncpus
if ( ((xyz(1)>=(xyz0_loc_all(i,1)-fDP)).and.(xyz(1)<=(xyz1_loc_all(i,1)+fDP))) .and. &
((xyz(2)>=(xyz0_loc_all(i,2)-fDP)).and.(xyz(2)<=(xyz1_loc_all(i,2)+fDP))) .and. &
((xyz(3)>=(xyz0_loc_all(i,3)-fDP)).and.(xyz(3)<=(xyz1_loc_all(i,3)+fDP))) ) then
from_proc=i-1
found_proc=.true.
exit
endif
enddo
if (.not.found_proc) then
print*, 'find_proc_cartesian: error when searching for interpolation point'
print*, 'find_proc_cartesian: x,y,z',xyz
print*, 'find_proc_cartesian: x0_loc_all',xyz0_loc_all(:,1)
print*, 'find_proc_cartesian: x1_loc_all',xyz1_loc_all(:,1)
print*, 'find_proc_cartesian: y0_loc_all',xyz0_loc_all(:,2)
print*, 'find_proc_cartesian: y1_loc_all',xyz1_loc_all(:,2)
print*, 'find_proc_cartesian: z0_loc_all',xyz0_loc_all(:,3)
print*, 'find_proc_cartesian: z1_loc_all',xyz1_loc_all(:,3)
call fatal_error('find_proc_cartesian', &
'could not locate interpolation point on any processor!')
endif
!
endsubroutine find_proc_cartesian
!***********************************************************************
subroutine find_proc_curvilinear(rthz,from_proc)
!
! Find the processor that stores the grid points, and return the processor
! id and the grid index of the bottom neighbouring point on a global grid.
! Necessary for interpolation between grids on parallel systems
! and for particle computations
!
! 13-apr-17/Jorgen: Coded
!
real, dimension(3), intent(in) :: rthz
integer, intent(out) :: from_proc
integer :: i
logical :: found_proc
real, parameter :: fDP=1.e-15
!
found_proc=.false.
do i=1,ncpus
if ( ((rthz(1)>=(xyz0_loc_all_ogrid(i,1)-fDP)).and.(rthz(1)<=(xyz1_loc_all_ogrid(i,1)+fDP))) .and. &
((rthz(2)>=(xyz0_loc_all_ogrid(i,2)-fDP)).and.(rthz(2)<=(xyz1_loc_all_ogrid(i,2)+fDP))) .and. &
((rthz(3)>=(xyz0_loc_all_ogrid(i,3)-fDP)).and.(rthz(3)<=(xyz1_loc_all_ogrid(i,3)+fDP))) ) then
from_proc=i-1
found_proc=.true.
exit
endif
enddo
if (.not.found_proc) then
call fatal_error('find_proc_curvilinear', &
'could not locate interpolation point on any processor!')
endif
!
endsubroutine find_proc_curvilinear
!***********************************************************************
subroutine construct_serial_bdry_cartesian
!
! Build arrays containing cartesian corner values of all processors
! The arrays xyz0_loc_all and xyz1_loc_all are accessed by
! (iproc+1,[1,2,3]), where [1,2,3] is [x,y,z] corner.
! Need to use iproc+1 instead of iproc to avoid accessing zeroth element.
!
! 13-apr-17/Jorgen: Coded
!
use Mpicomm, only: mpisend_int, mpisend_real, mpirecv_int, &
mpirecv_real, mpibcast_real
real, dimension(3) :: xyz0_loc_recv
real, dimension(3) :: xyz1_loc_recv
integer, dimension(2) :: nbcast=(/ ncpus,3 /)
integer :: iproc_recv,j
!
if (iproc/=root) then
!
! All processors send their array values to the root.
!
call mpisend_int(iproc,root,990)
call mpisend_real(xyz0_loc,3,root,991)
call mpisend_real(xyz1_loc,3,root,992)
else
!
! The root processor, in turn, receives the data from the others
!
do j=0,ncpus-1
!avoid send-to-self
if (j/=root) then
call mpirecv_int(iproc_recv,j,990)
call mpirecv_real(xyz0_loc_recv,3,iproc_recv,991)
call mpirecv_real(xyz1_loc_recv,3,iproc_recv,992)
!
xyz0_loc_all(iproc_recv+1,:)=xyz0_loc_recv
xyz1_loc_all(iproc_recv+1,:)=xyz1_loc_recv
else
! The root just copies its value to the serial array
xyz0_loc_all(root+1,:)=xyz0_loc
xyz1_loc_all(root+1,:)=xyz1_loc
endif
enddo
endif
!
! Serial array constructed. Broadcast the result.
!
call mpibcast_real(xyz0_loc_all,nbcast)
call mpibcast_real(xyz1_loc_all,nbcast)
endsubroutine construct_serial_bdry_cartesian
!***********************************************************************
subroutine construct_serial_bdry_curv
!
! Build arrays containing curvilinear corner values of all processors
! The arrays xyz0_loc_all and xyz1_loc_all are accessed by
! (iproc+1,[1,2,3]), where [1,2,3] is [x,y,z] corner.
! Need to use iproc+1 instead of iproc to avoid accessing zeroth element.
!
! Unlike the cartesian version of this, we need to first construct the
! local arrays xyz0_loc_ogrid and xyz1_loc_ogrid. This is done in
! start.in/run.in for the cartesian grid.
!
! 13-apr-17/Jorgen: Coded
!
use Mpicomm, only: mpisend_int, mpisend_real, mpirecv_int, &
mpirecv_real, mpibcast_real
real, dimension(3) :: xyz0_loc_recv_ogrid
real, dimension(3) :: xyz1_loc_recv_ogrid
real, dimension(3) :: Lxyz_loc_ogrid
integer, dimension(2) :: nbcast=(/ ncpus,3 /)
integer :: iproc_recv,j
!
! Constructing local arrays, with code copied from run.f90
! Size of box at local processor. The if-statement is for
! backward compatibility.
!
if (lequidist_ogrid(1)) then
Lxyz_loc_ogrid(1) = Lxyz_ogrid(1)/nprocx
xyz0_loc_ogrid(1) = xyz0_ogrid(1)+ipx*Lxyz_loc_ogrid(1)
xyz1_loc_ogrid(1) = xyz0_loc_ogrid(1)+Lxyz_loc_ogrid(1)
else
!
! In the equidistant grid, the processor boundaries (xyz[01]_loc) do NOT
! coincide with the l[mn]1[2] points. Also, xyz0_loc[ipx+1]=xyz1_loc[ipx], i.e.,
! the inner boundary of one is exactly the outer boundary of the other. Reproduce
! this behavior also for non-equidistant grids.
!
if (ipx==0) then
xyz0_loc_ogrid(1) = x_ogrid(l1_ogrid)
else
xyz0_loc_ogrid(1) = x_ogrid(l1_ogrid) - .5/dx_1_ogrid(l1_ogrid)
endif
if (ipx==nprocx-1) then
xyz1_loc_ogrid(1) = x_ogrid(l2_ogrid)
else
xyz1_loc_ogrid(1) = x_ogrid(l2_ogrid+1) - .5/dx_1_ogrid(l2_ogrid+1)
endif
Lxyz_loc_ogrid(1) = xyz1_loc_ogrid(1) - xyz0_loc_ogrid(1)
endif
!
if (lequidist_ogrid(2)) then
Lxyz_loc_ogrid(2) = Lxyz_ogrid(2)/nprocy
xyz0_loc_ogrid(2) = xyz0_ogrid(2)+ipy*Lxyz_loc_ogrid(2)
xyz1_loc_ogrid(2) = xyz0_loc_ogrid(2)+Lxyz_loc_ogrid(2)
else
if (ipy==0) then
xyz0_loc_ogrid(2) = y_ogrid(m1_ogrid)
else
xyz0_loc_ogrid(2) = y_ogrid(m1_ogrid) - .5/dy_1_ogrid(m1_ogrid)
endif
if (ipy==nprocy-1) then
xyz1_loc_ogrid(2) = y_ogrid(m2_ogrid)
else
xyz1_loc_ogrid(2) = y_ogrid(m2_ogrid+1) - .5/dy_1_ogrid(m2_ogrid+1)
endif
Lxyz_loc_ogrid(2) = xyz1_loc_ogrid(2) - xyz0_loc_ogrid(2)
endif
!
if (lequidist_ogrid(3)) then
Lxyz_loc_ogrid(3) = Lxyz_ogrid(3)/nprocz
xyz0_loc_ogrid(3) = xyz0_ogrid(3)+ipz*Lxyz_loc_ogrid(3)
xyz1_loc_ogrid(3) = xyz0_loc_ogrid(3)+Lxyz_loc_ogrid(3)
else
if (ipz==0) then
xyz0_loc_ogrid(3) = z_ogrid(n1_ogrid)
else
xyz0_loc_ogrid(3) = z_ogrid(n1_ogrid) - .5/dz_1_ogrid(n1_ogrid)
endif
if (ipz==nprocz-1) then
xyz1_loc_ogrid(3) = z_ogrid(n2_ogrid)
else
xyz1_loc_ogrid(3) = z_ogrid(n2_ogrid+1) - .5/dz_1_ogrid(n2_ogrid+1)
endif
Lxyz_loc_ogrid(3) = xyz1_loc_ogrid(3) - xyz0_loc_ogrid(3)
endif
!
! Communicate arrays and generate global arrays
!
if (iproc/=root) then
!
! All processors send their array values to the root.
!
call mpisend_int(iproc,root,880)
call mpisend_real(xyz0_loc_ogrid,3,root,881)
call mpisend_real(xyz1_loc_ogrid,3,root,882)
else
!
! The root processor, in turn, receives the data from the others
!
do j=0,ncpus-1
!avoid send-to-self
if (j/=root) then
call mpirecv_int(iproc_recv,j,880)
call mpirecv_real(xyz0_loc_recv_ogrid,3,iproc_recv,881)
call mpirecv_real(xyz1_loc_recv_ogrid,3,iproc_recv,882)
!
xyz0_loc_all_ogrid(iproc_recv+1,:)=xyz0_loc_recv_ogrid
xyz1_loc_all_ogrid(iproc_recv+1,:)=xyz1_loc_recv_ogrid
else
! The root just copies its value to the serial array
xyz0_loc_all_ogrid(root+1,:)=xyz0_loc_ogrid
xyz1_loc_all_ogrid(root+1,:)=xyz1_loc_ogrid
endif
enddo
endif
!
! Serial array constructed. Broadcast the result.
!
call mpibcast_real(xyz0_loc_all_ogrid,nbcast)
call mpibcast_real(xyz1_loc_all_ogrid,nbcast)
endsubroutine construct_serial_bdry_curv
!***********************************************************************
subroutine find_near_ind_local_cart(inear_loc,xxp,lcheck)
!
! Find nearest local indices of point xxp
! Return only indices correponding to low corner of cube containing the point xxp,
! i.e, inear_glob = (/ ix0, iy0, iz0 /), where x(ix0) <= xxp(1) <= x(ix0+1), etc.
!
! 01-aug-17/Jorgen: Coded
!
integer, dimension(3), intent(out) :: inear_loc
real, dimension(3), intent(in) :: xxp
logical, intent(in) :: lcheck
!
integer, dimension(3) :: inear_glob
!
call find_near_ind_global_cart(inear_glob,xxp,lcheck)
call ind_global_to_local_cart(inear_glob,inear_loc,lcheck)
!
endsubroutine find_near_ind_local_cart
!***********************************************************************
subroutine find_near_ind_global_cart(ineargrid,xxp,lcheck)
!
! Find nearest global indices of point xxp
! Return only indices correponding to low corner of cube containing the point xxp,
! i.e, inear_glob = (/ ix0, iy0, iz0 /), where xglobal(ix0) <= xxp(1) <= xglobal(ix0+1), etc.
!
! Find nearest grid point by bisection if the grid is not equidistant.
!
! 01-aug-17/Jorgen: Coded
!
integer, dimension(3), intent(out) :: ineargrid
real, dimension(3), intent(in) :: xxp
logical, intent(in) :: lcheck
integer :: ix0, iy0, iz0
real, save :: dx1, dy1, dz1
logical, save :: lfirstcall=.true.
!
! Default values in case of missing directions.
!
ix0=nghost+1; iy0=nghost+1; iz0=nghost+1
if (lfirstcall) then
dx1=dx_1(l1)
dy1=dy_1(m1)
dz1=dz_1(n1)
lfirstcall=.false.
endif
!
! Find nearest grid point in x-direction.
!
if (nxgrid/=1) then
if (lequidist(1)) then
ix0 = floor((xxp(1)-xglobal(1))*dx1) + 1
else
call find_low_gp_index_bisection(xxp(1),xglobal,ix0)
endif
endif
!
! Find nearest grid point in y-direction.
!
if (nygrid/=1) then
if (lequidist(2)) then
iy0 = floor((xxp(2)-yglobal(1))*dy1) + 1
else
call find_low_gp_index_bisection(xxp(2),yglobal,iy0)
endif
endif
!
! Find nearest grid point in z-direction.
!
if (nzgrid/=1) then
if (lequidist(3)) then
iz0 = floor((xxp(3)-zglobal(1))*dz1) + 1
else
call find_low_gp_index_bisection(xxp(3),zglobal,iz0)
endif
endif
!
ineargrid=(/ ix0,iy0,iz0 /)
!
! If requested, check if the correct grid points are found
!
!if (lcheck) then
! if ((xglobal(ineargrid(1))-xxp(1) )>1.e-14 .or. &
! (xxp(1)-xglobal(ineargrid(1)+1))>1.e-14 .or. &
! (yglobal(ineargrid(2))-xxp(2) )>1.e-14 .or. &
! (xxp(2)-yglobal(ineargrid(2)+1))>1.e-14 .or. &
! (zglobal(ineargrid(3))-xxp(3) )>1.e-14 .or. &
! (xxp(3)-zglobal(ineargrid(3)+1))>1.e-14) then
if (lcheck) then
if ((xglobal(ineargrid(1))-xxp(1) )>0. .or. &
(xxp(1)-xglobal(ineargrid(1)+1))>0. .or. &
(yglobal(ineargrid(2))-xxp(2) )>0. .or. &
(xxp(2)-yglobal(ineargrid(2)+1))>0. .or. &
(zglobal(ineargrid(3))-xxp(3) )>0. .or. &
(xxp(3)-zglobal(ineargrid(3)+1))>0.) then
!
! Try adjusting. Might be needed if there is a very close overlap between grid points
!
if ((xglobal(ineargrid(1))-xxp(1) )>0. .and. &
(xglobal(ineargrid(1))-xxp(1) )<1.e-12) then
ineargrid(1) = ineargrid(1) - 1
elseif ((xxp(1)-xglobal(ineargrid(1)+1))>0. .and. &
(xxp(1)-xglobal(ineargrid(1)+1))<1.e-12) then
ineargrid(1) = ineargrid(1) + 1
endif
if ((yglobal(ineargrid(2))-xxp(2) )>0. .and. &
(yglobal(ineargrid(2))-xxp(2) )<1.e-12) then
ineargrid(2) = ineargrid(2) - 1
elseif ((xxp(2)-yglobal(ineargrid(2)+1))>0. .and. &
(xxp(2)-yglobal(ineargrid(2)+1))<1.e-12) then
ineargrid(2) = ineargrid(2) + 1
endif
if ((zglobal(ineargrid(3))-xxp(3) )>0. .and. &
(zglobal(ineargrid(3))-xxp(3) )<1.e-12) then
ineargrid(3) = ineargrid(3) - 1
elseif ((xxp(3)-zglobal(ineargrid(3)+1))>0. .and. &
(xxp(3)-zglobal(ineargrid(3)+1))<1.e-12) then
ineargrid(3) = ineargrid(3) + 1
endif
!
! If there is still a problem, return an error message
!
if ((xglobal(ineargrid(1))-xxp(1) )>0. .or. &
(xxp(1)-xglobal(ineargrid(1)+1))>0. .or. &
(yglobal(ineargrid(2))-xxp(2) )>0. .or. &
(xxp(2)-yglobal(ineargrid(2)+1))>0. .or. &
(zglobal(ineargrid(3))-xxp(3) )>0. .or. &
(xxp(3)-zglobal(ineargrid(3)+1))>0.) then
print*, 'Information about what went wrong:'
print*, '----------------------------------'
print*, 'ERROR: find nearest grid point, cartesian'
print*, 'Information about what went wrong:'
print*, '----------------------------------'
print*, 'it, itsub, t=', it, itsub, t
print*, 'iproc =', iproc
print*, 'xxp =', xxp
print*, 'ineargrid =', ineargrid(:)
print*, 'xglobal(ix0),xglobal(ix0+1)',xglobal(ineargrid(1)),xglobal(ineargrid(1)+1)
print*, 'yglobal(iy0),yglobal(iy0+1)',yglobal(ineargrid(2)),yglobal(ineargrid(2)+1)
print*, 'zglobal(iz0),zglobal(iz0+1)',zglobal(ineargrid(3)),zglobal(ineargrid(3)+1)
call fatal_error_local('find_near_grid_point_cartesian','')
endif
endif
endif
endsubroutine find_near_ind_global_cart
!***********************************************************************
subroutine find_near_ind_local_curv(inear_loc,xxp,lcheck)
!
! Find nearest local indices of point xxp on curvilinear grid
! Return only indices correponding to low corner of cube containing the point xxp,
! i.e, inear_glob = (/ ix0, iy0, iz0 /), where x_ogrid(ix0) <= xxp(1) <= x_ogrid(ix0+1), etc.
!
! 01-aug-17/Jorgen: Coded
!
integer, dimension(3), intent(out) :: inear_loc
real, dimension(3), intent(in) :: xxp
logical, intent(in) :: lcheck
!
integer, dimension(3) :: inear_glob
!
call find_near_ind_global_curv(inear_glob,xxp,lcheck)
call ind_global_to_local_curv(inear_glob,inear_loc,lcheck)
!
endsubroutine find_near_ind_local_curv
!***********************************************************************
subroutine find_near_ind_global_curv(ineargrid,xxp,lcheck)
!
! Find nearest global indices of point xxp on the curvilinear grid
! Return only indices correponding to low corner of cube containing the point xxp,
! i.e, inear_glob = (/ ix0, iy0, iz0 /), where xglobal_ogrid(ix0) <= xxp(1) <= xglobal_ogrid(ix0+1), etc.
!
! Find nearest grid point by bisection if the grid is not equidistant.
!
! 01-aug-17/Jorgen: Coded
!
integer, dimension(3), intent(out) :: ineargrid
real, dimension(3), intent(in) :: xxp
logical, intent(in) :: lcheck
integer :: ix0, iy0, iz0
real, save :: dx1_ogrid, dy1_ogrid, dz1_ogrid
logical, save :: lfirstcall=.true.
!
! Default values in case of missing directions.
!
ix0=nghost+1; iy0=nghost+1; iz0=nghost+1
!
if (lfirstcall) then
dx1_ogrid=dx_1_ogrid(l1_ogrid)
dy1_ogrid=dy_1_ogrid(m1_ogrid)
dz1_ogrid=dz_1_ogrid(n1_ogrid)
lfirstcall=.false.
endif
!
! Find nearest grid point in x-direction.
!
if (nxgrid_ogrid/=1) then
if (lequidist_ogrid(1)) then
ix0 = floor((xxp(1)-xglobal_ogrid(1))*dx1_ogrid) + 1
else
call find_low_gp_index_bisection(xxp(1),xglobal_ogrid,ix0)
endif
endif
!
! Find nearest grid point in y-direction.
!
if (nygrid_ogrid/=1) then
if (lequidist_ogrid(2)) then
iy0 = floor((xxp(2)-yglobal_ogrid(1))*dy1_ogrid) + 1
else
call find_low_gp_index_bisection(xxp(2),yglobal_ogrid,iy0)
endif
endif
!
! Find nearest grid point in z-direction.
!
if (nzgrid_ogrid/=1) then
if (lequidist_ogrid(3)) then
iz0 = floor((xxp(3)-zglobal_ogrid(1))*dz1_ogrid) + 1
else
call find_low_gp_index_bisection(xxp(3),zglobal_ogrid,iz0)
endif
endif
!
ineargrid=(/ ix0,iy0,iz0 /)
!
! If requested, check if the correct grid points are found
!
if (lcheck) then
if ((xglobal_ogrid(ineargrid(1))-xxp(1) )>0. .or. & !1.e-14 .or. &
(xxp(1)-xglobal_ogrid(ineargrid(1)+1))>0. .or. & !1.e-14 .or. &
(yglobal_ogrid(ineargrid(2))-xxp(2) )>0. .or. & !1.e-14 .or. &
(xxp(2)-yglobal_ogrid(ineargrid(2)+1))>0. .or. & !1.e-14 .or. &
(zglobal_ogrid(ineargrid(3))-xxp(3) )>0. .or. & !1.e-14 .or. &
(xxp(3)-zglobal_ogrid(ineargrid(3)+1))>0.) then !1.e-14) then
!
! Try adjusting. Might be needed if there is a very close overlap between grid points
!
if ((xglobal_ogrid(ineargrid(1))-xxp(1) )>0. .and. &
(xglobal_ogrid(ineargrid(1))-xxp(1) )<1.e-12) then
ineargrid(1) = ineargrid(1) - 1
elseif ((xxp(1)-xglobal_ogrid(ineargrid(1)+1))>0. .and. &
(xxp(1)-xglobal_ogrid(ineargrid(1)+1))<1.e-12) then
ineargrid(1) = ineargrid(1) + 1
endif
if ((yglobal_ogrid(ineargrid(2))-xxp(2) )>0. .and. &
(yglobal_ogrid(ineargrid(2))-xxp(2) )<1.e-12) then
ineargrid(2) = ineargrid(2) - 1
elseif ((xxp(2)-yglobal_ogrid(ineargrid(2)+1))>0. .and. &
(xxp(2)-yglobal_ogrid(ineargrid(2)+1))<1.e-12) then
ineargrid(2) = ineargrid(2) + 1
endif
if ((zglobal_ogrid(ineargrid(3))-xxp(3) )>0. .and. &
(zglobal_ogrid(ineargrid(3))-xxp(3) )<1.e-12) then
ineargrid(3) = ineargrid(3) - 1
elseif ((xxp(3)-zglobal_ogrid(ineargrid(3)+1))>0. .and. &
(xxp(3)-zglobal_ogrid(ineargrid(3)+1))<1.e-12) then
ineargrid(3) = ineargrid(3) + 1
endif
!
! If there is still a problem, return an error message
!
if ((xglobal_ogrid(ineargrid(1))-xxp(1) )>0. .or. &
(xxp(1)-xglobal_ogrid(ineargrid(1)+1))>0. .or. &
(yglobal_ogrid(ineargrid(2))-xxp(2) )>0. .or. &
(xxp(2)-yglobal_ogrid(ineargrid(2)+1))>0. .or. &
(zglobal_ogrid(ineargrid(3))-xxp(3) )>0. .or. &
(xxp(3)-zglobal_ogrid(ineargrid(3)+1))>0.) then
!
print*, 'Information about what went wrong:'
print*, '----------------------------------'
print*, 'ERROR: find nearest grid point, curvilinear'
print*, 'Information about what went wrong:'
print*, '----------------------------------'
print*, 'it, itsub, t=', it, itsub, t
print*, 'iproc =', iproc
print*, 'xxp =', xxp
print*, 'ineargrid =', ineargrid(:)
print*, 'xglobal(ix0),xglobal(ix0+1)',xglobal_ogrid(ineargrid(1)),xglobal_ogrid(ineargrid(1)+1)
print*, 'yglobal(iy0),yglobal(iy0+1)',yglobal_ogrid(ineargrid(2)),yglobal_ogrid(ineargrid(2)+1)
print*, 'zglobal(iz0),zglobal(iz0+1)',zglobal_ogrid(ineargrid(3)),zglobal_ogrid(ineargrid(3)+1)
call fatal_error_local('find_near_ind_global_curvilinear','')
call fatal_error('find_near_ind_global_curv','nearest grid point error')
endif
endif
endif
!
endsubroutine find_near_ind_global_curv
!***********************************************************************
subroutine wsnap_ogrid(chsnap,enum,flist)
!
! Write snapshot file of overlapping grid, labelled consecutively if enum==.true.
! Otherwise just write a snapshot without label (used for var.dat).
!
! 21-feb-17/Jorgen: Adapted from snapsjots.f90
!
use General, only: safe_character_assign
use IO, only: log_filename_to_file
use Sub, only: read_snaptime, update_snaptime
!
character(len=*), intent(in) :: chsnap
character(len=*), intent(in), optional :: flist
logical, intent(in), optional :: enum
!
real, save :: tsnap
integer, save :: nsnap
logical, save :: lfirst_call=.true.
logical :: enum_, lsnap
character (len=fnlen) :: file
character (len=intlen) :: ch
!
if (present(enum)) then
enum_=enum
else
enum_=.false.
endif
!
! Output snapshot with label in 'tsnap' time intervals.
! File keeps the information about number and time of last snapshot.
!
if (enum_) then
call safe_character_assign(file,trim(datadir)//'/ogtsnap.dat')
!
! At first call, need to initialize tsnap.
! tsnap calculated in read_snaptime, but only available to root processor.
!
if (lfirst_call) then
call read_snaptime(file,tsnap,nsnap,dsnap,t)
lfirst_call=.false.
endif
!
! Check whether we want to output snapshot. If so, then
! update ghost zones for var.dat (cheap, since done infrequently).
!
call update_snaptime(file,tsnap,nsnap,dsnap,t,lsnap,ch)
if (lsnap) then
call update_ghosts_ogrid(f_ogrid)
call safe_character_assign(file,trim(chsnap)//ch)
call output_snap_ogrid(f_ogrid,file=file)
if (ip<=10.and.lroot) print*,'wsnap: written snapshot ',file
if (present(flist)) call log_filename_to_file(file,flist)
endif
!
else
!
! Write snapshot without label (typically, var.dat).
!
call update_ghosts_ogrid(f_ogrid)
call safe_character_assign(file,trim(chsnap))
call output_snap_ogrid(f_ogrid,file=file)
if (present(flist)) call log_filename_to_file(file,flist)
endif
!
if (lformat) call output_snap_form_ogrid (file)
!
endsubroutine wsnap_ogrid
!***********************************************************************
subroutine update_ghosts_ogrid(f_og)
!
! Update all ghost zones of f_ogrid.
! Initiate communication and do boundary conditions.
! Required order:
! 1. x-boundaries (x-ghost zones will be communicated)
! 2. communication
! 3. y- and z-boundaries
!
! 21-feb-17/Jorgen: Adapted from boundcond.f90
!
use Solid_Cells_Mpicomm, only: initiate_isendrcv_bdry_ogrid, finalize_isendrcv_bdry_ogrid
real, dimension (mx_ogrid, my_ogrid, mz_ogrid,mfarray_ogrid), intent(inout) :: f_og
!
!call boundconds_x_ogrid
call initiate_isendrcv_bdry_ogrid(f_og)
call finalize_isendrcv_bdry_ogrid(f_og)
if (nprocy==1) call boundconds_y_ogrid(f_og)
if ((nprocz==1).and.(nzgrid>1)) call boundconds_z_ogrid(f_og)
!
endsubroutine update_ghosts_ogrid
!***********************************************************************
subroutine output_snap_ogrid(a,file)
!
! Write snapshot file, always write time and mesh, could add other things.
!
! 21-feb-17/Jorgen: Adapted from io_dist.f90
!
use Mpicomm, only: start_serialize, end_serialize
use IO, only: lun_output
use File_io, only: delete_file
!
real, dimension (:,:,:,:), intent(IN) :: a
character (len=*), optional,intent(IN) :: file
!
real :: t_sp ! t in single precision for backwards compatibility
!
t_sp = t
if (lserial_io) call start_serialize
if (present(file)) then
call delete_file(trim(directory_snap)//'/'//file)
open (lun_output, FILE=trim(directory_snap)//'/'//file, FORM='unformatted', status='new')
endif
!
if (lwrite_2d) then
if (nz_ogrid == 1) then
write (lun_output) a(:,:,n1_ogrid,:)
else
call fatal_error('output_snap_ogrid','lwrite_2d used for simulation with nz_ogri/=1!')
endif
else
write (lun_output) a
endif
write (lun_output) t_sp, x_ogrid(1:size(a,1)), y_ogrid(1:size(a,2)), z_ogrid(1:size(a,3)), dx_ogrid, dy_ogrid, dz_ogrid
!
close (lun_output)
if (lserial_io) call end_serialize
endsubroutine output_snap_ogrid
!***********************************************************************
subroutine output_snap_form_ogrid(file)
!
! Write FORMATTED snapshot file
!
! 21/feb-17/Jorgen: Adapted from snapshot.f90
!
use IO, only: lun_output
!
character (len=*), intent(in) :: file
integer :: i, j, k
!
open(lun_output,FILE=trim(directory_dist)//trim(file)//'.form')
!
if (lwrite_2d) then
if (nz_ogrid==1) then
do i = l1_ogrid, l2_ogrid
do j = m1_ogrid, m2_ogrid
write(lun_output,'(40(f12.5))') x_ogrid(i),y_ogrid(j),z_ogrid(n1), &
dx_ogrid,dy_ogrid,dz_ogrid,f_ogrid(i,j,n1_ogrid,:)
enddo
enddo
else
call fatal_error('output_snap_form_ogrid','lwrite_2d used for simulation with nz_ogri/=1!')
endif
!
else
do i = l1_ogrid, l2_ogrid
do j = m1_ogrid, m2_ogrid
do k = n1_ogrid, n2_ogrid
write(lun_output,'(40(f12.5))') x_ogrid(i),y_ogrid(j),z_ogrid(k), &
dx_ogrid,dy_ogrid,dz_ogrid,f_ogrid(i,j,k,:)
enddo
enddo
enddo
!
endif
!
close(lun_output)
!
endsubroutine output_snap_form_ogrid
!***********************************************************************
subroutine rsnap_ogrid(chsnap,lread_nogrid)
!
! Read snapshot file.
!
! 21-feb-17/Jorgen: Adapted from snapshot.f90
!
use IO, only: lun_input
use Mpicomm, only: end_serialize
!
logical :: lread_nogrid
integer :: mode
character (len=*) :: chsnap
!
! possibility of not reading the mesh data nor the time
! of the snapshot. The mesh information is then taken from
! proc*/mesh.dat
!
if (lread_nogrid) then
mode=0
else
mode=1
endif
!
call input_snap_ogrid(chsnap,f_ogrid,mfarray_ogrid,mode)
close (lun_input)
if (lserial_io) call end_serialize
!
! Read data using lnrho, and now convert to rho.
! This assumes that one is now using ldensity_nolog=T.
!
if (lread_oldsnap_lnrho2rho) then
print*,'convert lnrho -> rho',ilnrho,irho
if (irho>0) &
f_ogrid(:,:,:,irho)=exp(f_ogrid(:,:,:,ilnrho))
endif
!
endsubroutine rsnap_ogrid
!***********************************************************************
subroutine input_snap_ogrid(file,a,nv,mode)
!
! manages reading of snapshot from different precision
!
! 21-feb-17/Jorgen: Adapted from io_dist.f90
!
character (len=*), intent(in) :: file
integer, intent(in) :: nv, mode
real, dimension (mx_ogrid,my_ogrid,mz_ogrid,nv), intent(out) :: a
real(KIND=rkind8), dimension(:,:,:,:), allocatable :: adb
real(KIND=rkind4), dimension(:,:,:,:), allocatable :: asg
real(KIND=rkind8), dimension(:), allocatable :: xdb,ydb,zdb
real(KIND=rkind4), dimension(:), allocatable :: xsg,ysg,zsg
real(KIND=rkind8) :: dxdb,dydb,dzdb,deltaydb
real(KIND=rkind4) :: dxsg,dysg,dzsg,deltaysg
real :: deltay_ogrid
if (lread_from_other_prec) then
if (kind(a)==rkind4) then
allocate(adb(mx_ogrid,my_ogrid,mz_ogrid,nv),xdb(mx_ogrid),ydb(my_ogrid),zdb(mz_ogrid))
call read_snap_ogrid(file,adb,xdb,ydb,zdb,dxdb,dydb,dzdb,deltaydb,nv,mode)
a=adb; x_ogrid=xdb; y_ogrid=ydb; z_ogrid=zdb; dx_ogrid=dxdb; dy_ogrid=dydb; dz_ogrid=dzdb; deltay_ogrid=deltaydb
elseif (kind(a)==rkind8) then
allocate(asg(mx_ogrid,my_ogrid,mz_ogrid,nv),xsg(mx_ogrid),ysg(my_ogrid),zsg(mz_ogrid))
call read_snap_ogrid(file,asg,xsg,ysg,zsg,dxsg,dysg,dzsg,deltaysg,nv,mode)
a=asg; x_ogrid=xsg; y_ogrid=ysg; z_ogrid=zsg; dx_ogrid=dxsg; dy_ogrid=dysg; dz_ogrid=dzsg; deltay_ogrid=deltaysg
endif
else
call read_snap_ogrid(file,a,x_ogrid,y_ogrid,z_ogrid,dx_ogrid,dy_ogrid,dz_ogrid,deltay_ogrid,nv,mode)
endif
endsubroutine input_snap_ogrid
!***********************************************************************
subroutine read_snap_single_ogrid(file,a,x_ogrid,y_ogrid,z_ogrid, &
dx_ogrid,dy_ogrid,dz_ogrid,deltay_ogrid,nv,mode)
!
! Read snapshot file in single precision, possibly with mesh and time (if mode=1).
!
! 21-feb-17/Jorgen: Adapted from io_dist.f90
!
use Mpicomm, only: start_serialize, mpibcast_real, mpiallreduce_or, &
stop_it, mpiallreduce_min, mpiallreduce_max, MPI_COMM_WORLD
use IO, only: lun_input
!
character (len=*), intent(in) :: file
integer, intent(in) :: nv, mode
real(KIND=rkind4), dimension (mx_ogrid,my_ogrid,mz_ogrid,nv), intent(out) :: a
!
real(KIND=rkind4) :: t_sp, t_sgl
real(KIND=rkind4), intent(out) :: dx_ogrid, dy_ogrid, dz_ogrid, deltay_ogrid
real(KIND=rkind4), dimension (mx_ogrid), intent(out) :: x_ogrid
real(KIND=rkind4), dimension (my_ogrid), intent(out) :: y_ogrid
real(KIND=rkind4), dimension (mz_ogrid), intent(out) :: z_ogrid
real :: t_test ! t in single precision for backwards compatibility
logical :: ltest
! set ireset_tstart to 1 or 2 to coordinate divergent timestamp
integer :: MINT=1
integer :: MAXT=2
!
if (lserial_io) call start_serialize
open (lun_input, FILE=trim(directory_snap)//'/'//file, FORM='unformatted', status='old')
if (lwrite_2d) then
if (nz == 1) then
read (lun_input) a(:,:,4,:)
else
call fatal_error ('read_snap_single_ogrid','lwrite_2d used for simulation with nz_ogri/=1!')
endif
else
!
! Possibility of reading data with different numbers of ghost zones.
! In that case, one must regenerate the mesh with luse_oldgrid=T.
!
if (nghost_read_fewer==0) then
read (lun_input) a
elseif (nghost_read_fewer>0) then
read (lun_input) &
a(1+nghost_read_fewer:mx_ogrid-nghost_read_fewer, &
1+nghost_read_fewer:my_ogrid-nghost_read_fewer, &
1+nghost_read_fewer:mz_ogrid-nghost_read_fewer,:)
!
! The following 3 possibilities allow us to replicate 1-D data input
! in x (nghost_read_fewer=-1), y (-2), or z (-3) correspondingly.
!
elseif (nghost_read_fewer==-1) then
read (lun_input) a(:,1:1+nghost*2,1:1+nghost*2,:)
a=spread(spread(a(:,m1_ogrid,n1_ogrid,:),2,my_ogrid),3,mz_ogrid)
elseif (nghost_read_fewer==-2) then
read (lun_input) a(1:1+nghost*2,:,1:1+nghost*2,:)
a=spread(spread(a(l1_ogrid,:,n1_ogrid,:),1,mx_ogrid),3,mz_ogrid)
elseif (nghost_read_fewer==-3) then
read (lun_input) a(1:1+nghost*2,1:1+nghost*2,:,:)
a=spread(spread(a(l1_ogrid,m1_ogrid,:,:),1,mx_ogrid),2,my_ogrid)
else
call fatal_error('read_snap_single_ogrid','nghost_read_fewer must be >=0')
endif
endif
if (mode == 1) then
!
! Check whether we want to read deltay from snapshot.
!
if (lshear) then
read (lun_input) t_sp, x_ogrid, y_ogrid, z_ogrid, dx_ogrid, dy_ogrid, dz_ogrid, deltay_ogrid
else
if (nghost_read_fewer==0) then
read (lun_input) t_sp, x_ogrid, y_ogrid, z_ogrid, dx_ogrid, dy_ogrid, dz_ogrid
elseif (nghost_read_fewer>0) then
read (lun_input) t_sp
endif
endif
!
! Verify consistency of the snapshots regarding their timestamp,
! unless ireset_tstart=T, in which case we reset all times to tstart.
!
if ((ireset_tstart == 0) .or. (tstart == impossible)) then
!
t_test = t_sp
call mpibcast_real(t_test,comm=MPI_COMM_WORLD)
call mpiallreduce_or((t_test /= t_sp) .and. .not. lread_from_other_prec &
.or. (abs(t_test-t_sp) > 1.e-6),ltest,MPI_COMM_WORLD)
!
! If timestamps deviate at any processor
!
if (ltest) then
if (ireset_tstart > 0) then
!
! If reset of tstart enabled and tstart unspecified, use minimum of all t_sp
!
if (ireset_tstart == MINT) then
call mpiallreduce_min(t_sp,t_sgl,MPI_COMM_WORLD)
if (lroot) write (*,*) 'Timestamps in snapshot INCONSISTENT.',&
' Using (min) t=', t_sgl,'with ireset_tstart=', MINT,'.'
elseif (ireset_tstart >= MAXT) then
call mpiallreduce_max(t_sp,t_sgl,MPI_COMM_WORLD)
if (lroot) write (*,*) 'Timestamps in snapshot INCONSISTENT.',&
' Using (max) t=', t_sgl,'with ireset_tstart=', MAXT,'.'
endif
tstart=t_sgl
else
write (*,*) 'ERROR: '//trim(directory_snap)//'/'//trim(file)// &
' IS INCONSISTENT: t=', t_sp
call stop_it('read_snap_single')
endif
else
tstart=t_sp
endif
!
! Setting time is done in main snap reading rountine
! Check that time read from overlapping grids match
!
if (t_sp/=t) then
call fatal_error ('read_snap_single_ogrid', 'time differs for cylindrical and cartesian snapshot')
endif
endif
endif
endsubroutine read_snap_single_ogrid
!***********************************************************************
subroutine read_snap_double_ogrid(file,a,x_ogrid,y_ogrid,z_ogrid, &
dx_ogrid,dy_ogrid,dz_ogrid,deltay_ogrid,nv,mode)
!
! Read snapshot file in double precision, possibly with mesh and time (if mode=1).
!
! 21-feb-17/Jorgen: Adapted from io_dist.f90
!
use Mpicomm, only: start_serialize, mpibcast_real, mpiallreduce_or, &
stop_it, mpiallreduce_min, mpiallreduce_max, MPI_COMM_WORLD
use IO, only: lun_input
!
character (len=*), intent(in) :: file
integer, intent(in) :: nv, mode
real(KIND=rkind8), dimension (mx_ogrid,my_ogrid,mz_ogrid,nv), intent(out) :: a
!
real(KIND=rkind8) :: t_sp, t_dbl
real(KIND=rkind8), intent(out) :: dx_ogrid, dy_ogrid, dz_ogrid, deltay_ogrid
real(KIND=rkind8), dimension (mx_ogrid), intent(out) :: x_ogrid
real(KIND=rkind8), dimension (my_ogrid), intent(out) :: y_ogrid
real(KIND=rkind8), dimension (mz_ogrid), intent(out) :: z_ogrid
real :: t_test ! t in single precision for backwards compatibility
logical :: ltest
! set ireset_tstart to 1 or 2 to coordinate divergent timestamp
integer :: MINT=1
integer :: MAXT=2
!
if (lserial_io) call start_serialize
open (lun_input, FILE=trim(directory_snap)//'/'//file, FORM='unformatted', status='old')
if (lwrite_2d) then
if (nz_ogrid == 1) then
read (lun_input) a(:,:,4,:)
else
call fatal_error ('read_snap_double_ogrid','lwrite_2d used for simulation with nz_ogri/=1!')
endif
else
!
! Possibility of reading data with different numbers of ghost zones.
! In that case, one must regenerate the mesh with luse_oldgrid=T.
!
if (nghost_read_fewer==0) then
read (lun_input) a
elseif (nghost_read_fewer>0) then
read (lun_input) &
a(1+nghost_read_fewer:mx_ogrid-nghost_read_fewer, &
1+nghost_read_fewer:my_ogrid-nghost_read_fewer, &
1+nghost_read_fewer:mz_ogrid-nghost_read_fewer,:)
!
! The following 3 possibilities allow us to replicate 1-D data input
! in x (nghost_read_fewer=-1), y (-2), or z (-3) correspondingly.
!
elseif (nghost_read_fewer==-1) then
read (lun_input) a(:,1:1+nghost*2,1:1+nghost*2,:)
a=spread(spread(a(:,m1_ogrid,n1_ogrid,:),2,my_ogrid),3,mz_ogrid)
elseif (nghost_read_fewer==-2) then
read (lun_input) a(1:1+nghost*2,:,1:1+nghost*2,:)
a=spread(spread(a(l1_ogrid,:,n1_ogrid,:),1,mx_ogrid),3,mz_ogrid)
elseif (nghost_read_fewer==-3) then
read (lun_input) a(1:1+nghost*2,1:1+nghost*2,:,:)
a=spread(spread(a(l1_ogrid,m1_ogrid,:,:),1,mx_ogrid),2,my_ogrid)
else
call fatal_error('read_snap_double','nghost_read_fewer must be >=0')
endif
endif
if (ip <= 8) print *, 'read_snap: read ', file
if (mode == 1) then
!
! Check whether we want to read deltay from snapshot.
!
if (lshear) then
read (lun_input) t_sp, x_ogrid, y_ogrid, z_ogrid, dx_ogrid, dy_ogrid, dz_ogrid, deltay_ogrid
else
if (nghost_read_fewer==0) then
read (lun_input) t_sp, x_ogrid, y_ogrid, z_ogrid, dx_ogrid, dy_ogrid, dz_ogrid
elseif (nghost_read_fewer>0) then
read (lun_input) t_sp
endif
endif
!
! Verify consistency of the snapshots regarding their timestamp,
! unless ireset_tstart=T, in which case we reset all times to tstart.
!
if ((ireset_tstart == 0) .or. (tstart == impossible)) then
!
t_test = t_sp
call mpibcast_real(t_test,comm=MPI_COMM_WORLD)
call mpiallreduce_or((t_test /= t_sp) .and. .not. lread_from_other_prec &
.or. (abs(t_test-t_sp) > 1.e-6),ltest, MPI_COMM_WORLD)
!
! If timestamp deviates at any processor
!
if (ltest) then
if (ireset_tstart > 0) then
!
! If reset of tstart enabled and tstart unspecified, use minimum of all t_sp
!
if (ireset_tstart == MINT) then
call mpiallreduce_min(t_sp,t_dbl,MPI_COMM_WORLD)
if (lroot) write (*,*) 'Timestamps in snapshot INCONSISTENT.',&
' Using (min) t=', t_dbl,'with ireset_tstart=', MINT,'.'
elseif (ireset_tstart >= MAXT) then
call mpiallreduce_max(t_sp,t_dbl,MPI_COMM_WORLD)
if (lroot) write (*,*) 'Timestamps in snapshot INCONSISTENT.',&
' Using (max) t=', t_dbl,'with ireset_tstart=', MAXT,'.'
endif
tstart=t_dbl
if (lroot) write (*,*) 'Timestamps in snapshot INCONSISTENT. Using t=', tstart, '.'
else
write (*,*) 'ERROR: '//trim(directory_snap)//'/'//trim(file)// &
' IS INCONSISTENT: t=', t_sp
call stop_it('read_snap_double')
endif
else
tstart=t_sp
endif
!
! Setting time is done in main snap reading rountine
! Check that time read from overlapping grids match
!
if (t_sp/=t) then
call fatal_error ('read_snap_double_ogrid', 'time differs for cylindrical and cartesian snapshot')
endif
endif
endif
!
endsubroutine read_snap_double_ogrid
!***********************************************************************
subroutine setup_mm_nn_ogrid
!
! Produce index-array for the sequence of points to be worked through:
! Before the communication has been completed, the nghost=3 layers next
! to the processor boundary (m1, m2, n1, or n2) cannot be used yet.
! In the mean time we can calculate the interior points sufficiently far
! away from the boundary points. Here we calculate the order in which
! m and n are executed. At one point, necessary(imn)=.true., which is
! the moment when all communication must be completed.
!
! 24-feb-17/Jorgen: Adapted from general.f90
!
integer :: min_m1i_m2,max_m2i_m1
integer :: n1i_ogrid=n1_ogrid+nghost-1
integer :: n2i_ogrid=mz_ogrid-2*nghost+1
integer :: m1i_ogrid=m1_ogrid+nghost-1
integer :: m2i_ogrid=my_ogrid-2*nghost+1
!
! For non-parallel runs simply go through m and n from bottom left to to right.
!
imn_array_ogrid=0
if (ncpus==1) then
imn_ogrid=1
necessary_ogrid(1)=.true.
do n_ogrid=n1_ogrid,n2_ogrid
do m_ogrid=m1_ogrid,m2_ogrid
mm_ogrid(imn_ogrid)=m_ogrid
nn_ogrid(imn_ogrid)=n_ogrid
imn_array_ogrid(m_ogrid,n_ogrid)=imn_ogrid
imn_ogrid=imn_ogrid+1
enddo
enddo
else
imn_ogrid=1
do n_ogrid=n1i_ogrid+2,n2i_ogrid-2
do m_ogrid=m1i_ogrid+2,m2i_ogrid-2
if (imn_array_ogrid(m_ogrid,n_ogrid) == 0) then
mm_ogrid(imn_ogrid)=m_ogrid
nn_ogrid(imn_ogrid)=n_ogrid
imn_array_ogrid(m_ogrid,n_ogrid)=imn_ogrid
imn_ogrid=imn_ogrid+1
endif
enddo
enddo
necessary_ogrid(imn_ogrid)=.true.
!
! Do the upper stripe in the n-direction.
!
do n_ogrid=max(n2i_ogrid-1,n1_ogrid+1),n2_ogrid
do m_ogrid=m1i_ogrid+2,m2i_ogrid-2
if (imn_array_ogrid(m_ogrid,n_ogrid) == 0) then
mm_ogrid(imn_ogrid)=m_ogrid
nn_ogrid(imn_ogrid)=n_ogrid
imn_array_ogrid(m_ogrid,n_ogrid)=imn_ogrid
imn_ogrid=imn_ogrid+1
endif
enddo
enddo
!
! Do the lower stripe in the n-direction.
!
do n_ogrid=n1_ogrid,min(n1i_ogrid+1,n2_ogrid)
do m_ogrid=m1i_ogrid+2,m2i_ogrid-2
if (imn_array_ogrid(m_ogrid,n_ogrid) == 0) then
mm_ogrid(imn_ogrid)=m_ogrid
nn_ogrid(imn_ogrid)=n_ogrid
imn_array_ogrid(m_ogrid,n_ogrid)=imn_ogrid
imn_ogrid=imn_ogrid+1
endif
enddo
enddo
!
! Left and right hand boxes.
! NOTE: need to have min(m1i,m2) instead of just m1i, and max(m2i,m1)
! instead of just m2i, to make sure the case ny=1 works ok, and
! also that the same m is not set in both loops.
! ALSO: need to make sure the second loop starts not before the
! first one ends; therefore max_m2i_m1+1=max(m2i,min_m1i_m2+1).
!
min_m1i_m2=min(m1i_ogrid+1,m2_ogrid)
max_m2i_m1=max(m2i_ogrid-1,min_m1i_m2+1)
!
do n_ogrid=n1_ogrid,n2_ogrid
do m_ogrid=m1_ogrid,min_m1i_m2
if (imn_array_ogrid(m_ogrid,n_ogrid) == 0) then
mm_ogrid(imn_ogrid)=m_ogrid
nn_ogrid(imn_ogrid)=n_ogrid
imn_array_ogrid(m_ogrid,n_ogrid)=imn_ogrid
imn_ogrid=imn_ogrid+1
endif
enddo
do m_ogrid=max_m2i_m1,m2_ogrid
if (imn_array_ogrid(m_ogrid,n_ogrid) == 0) then
mm_ogrid(imn_ogrid)=m_ogrid
nn_ogrid(imn_ogrid)=n_ogrid
imn_array_ogrid(m_ogrid,n_ogrid)=imn_ogrid
imn_ogrid=imn_ogrid+1
endif
enddo
enddo
endif
!
endsubroutine setup_mm_nn_ogrid
!***********************************************************************
subroutine map_nearest_grid_ogrid(xxp,ineargridproc_ogrid,rthz)
!
! Find index (ix0, iy0, iz0) of nearest grid point of particle in global
! coordinates.
!
! jul/aug-17/Jorgen: Adapted from map_nearest_grid in particles_sub
! to work for overlapping grid
!
real, dimension (3) :: xxp, rthz
integer, dimension (4) :: ineargridproc_ogrid
!
intent(in) :: xxp
intent(out) :: ineargridproc_ogrid,rthz
!
call get_polar_coords(xxp,rthz)
call find_near_ind_global_curv(ineargridproc_ogrid(1:3),rthz,lcheck_interpolation)
call find_proc_curvilinear(rthz,ineargridproc_ogrid(4))
!
endsubroutine map_nearest_grid_ogrid
!***********************************************************************
subroutine find_low_gp_index_bisection(qp,q,iq0)
!
! Find nearest local indices of point qp on grid q by bisecting the interval.
! Its main use is for non-equidistant grids.
! Return only indices correponding lower point on line containing qp
! i.e, q(iq0) <= qp <= q(iq0+1), etc.
!
! 01-aug-17/Jorgen: Adapted from particles_mpicomm
!
real, dimension (:) :: q
real :: qp
integer :: iq0,jl,ju,jm
!
intent (in) :: qp,q
intent (out) :: iq0
!
jl=1+nghost
ju=size(q)-nghost
!
do while((ju-jl)>1)
jm=(ju+jl)/2
if (qp > q(jm)) then
jl=jm
else
ju=jm
endif
enddo
iq0=jl
!
endsubroutine find_low_gp_index_bisection
!***********************************************************************
subroutine initialize_particles_ogrid(ivar1,ivar2)
!
! Set up f_ogrid_procs, that sends information about ogrid to the appropriate
! processor that needs this for computation of particle properties (velocity,
! temperature, etc.)
!
! 07-jul-17/Jorgen: Coded
!
use Mpicomm, only: mpirecv_logical, mpisend_logical, mpibcast_logical
use Viscosity, only: getnu
!
integer, intent(in) :: ivar1,ivar2
integer :: i,j,k,iip
real :: rr
logical, dimension(ncpus) :: linside_proc = .false.
real, dimension(3) :: rthz
integer :: from_proc
integer :: procs_needed
logical, dimension(ncpus,ncpus) :: part_data_comm_glob
real :: nu
!
! Check if any points on the cartesian grid on this processor is inside the part of
! the ogrid that is used in computing the flow
!
do i=l1,l2
do j=m1,m2
rr = radius_ogrid(x(i),y(j))
if (rr<=r_int_outer .and. rr>=cylinder_radius) then
do k=n1,n2
call get_polar_coords(x(i),y(j),z(k),rthz)
call find_proc_curvilinear(rthz,from_proc)
linside_proc(from_proc+1) = .true.
enddo
endif
enddo
enddo
!
! Initialize arrays of points needed for particle properties
! The ip_proc is needed to transform global coordinates to coordinates local to
! the processor considered in the f_ogrid_procs_arrary
! Procs_pointer is used to point to correct place in ip_proc and f_ogrid_procs
! array when using point from specific processor
!
procs_needed = count(linside_proc)
if (procs_needed>0) then
allocate(f_ogrid_procs(procs_needed,mx_ogrid,my_ogrid,mz_ogrid,ivar2-ivar1+1+maux))
allocate(ip_proc(procs_needed,3))
allocate(recv_part_data_from(procs_needed))
allocate(ip_proc_pointer(ncpus))
ip_proc_pointer = -1
k=1
do iip=0,ncpus-1
if (linside_proc(iip+1)) then
recv_part_data_from(k)=iip
if (lprocz_slowest) then
ip_proc(k,1) = modulo(iip, nprocx)
ip_proc(k,2) = modulo(iip/nprocx, nprocy)
ip_proc(k,3) = iip/nprocxy
else
ip_proc(k,1) = modulo(iip, nprocx)
ip_proc(k,2) = iip/nprocxz
ip_proc(k,3) = modulo(iip/nprocx, nprocz)
endif
ip_proc_pointer(iip+1) = k
k=k+1
endif
enddo
endif
!
! Communicate this to the other processors
!
if (lroot) then
do iip=0,ncpus-1
if (iip/=root) then
call mpirecv_logical(part_data_comm_glob(iip+1,:),ncpus,iip,899)
else
part_data_comm_glob(root+1,:)=linside_proc
endif
enddo
else
call mpisend_logical(linside_proc,ncpus,root,899)
endif
call mpibcast_logical(part_data_comm_glob,(/ncpus,ncpus/))
!
! Determine if this processor must send flow data to any others
! Never send data to onself
!
n_procs_send_part_data = count(part_data_comm_glob(:,iproc+1))
if (part_data_comm_glob(iproc+1,iproc+1)) then
n_procs_send_part_data = n_procs_send_part_data-1
endif
if (n_procs_send_part_data>0) then
allocate(send_part_data_to(n_procs_send_part_data))
k=1
do iip=0,ncpus-1
if (part_data_comm_glob(iip+1,iproc+1)) then
if (iip/=iproc) then
send_part_data_to(k)=iip
k=k+1
endif
endif
enddo
endif
n_procs_recv_part_data = procs_needed
!
! Send/recv information of this timestep (needed if continuing run from previous simulation)
!
call update_ogrid_flow_info(ivar1,ivar2)
!
! Set momentum thickness, may be needed for particle interpolation
! Thickness from Weber et al. 2013
!
! NILS: nu is not known until run. I have therefore simplified the momentum
! NILS: thickness to equal the cylinder radius
!call getnu(nu_input=nu)
!delta_momentum = ((0.20669/sqrt(2.))/sqrt(2.*cylinder_radius*init_uu/nu))&
! *(2*cylinder_radius)+cylinder_radius
delta_momentum = cylinder_radius
! Use only one type of special handling near the surface
if (lspecial_rad_int_mom) lspecial_rad_int=.false.
!
endsubroutine initialize_particles_ogrid
!***********************************************************************
subroutine update_ogrid_flow_info(ivar1,ivar2)
!
! Communicate f_ogrid to the processors that need it for computation of
! particle properties.
!
! 07-jul-17/Jorgen: Coded
!
use Mpicomm, only: mpirecv_real, mpisend_nonblock_real, mpibarrier, mpiwait
!
integer, intent(in) :: ivar1, ivar2
integer :: iter, ivar
integer :: recv_from, send_to
integer, dimension(3) :: flow_buf_size = (/mx_ogrid,my_ogrid,mz_ogrid/)
integer, dimension(n_procs_send_part_data,ivar2-ivar1+1) :: ireq2D
real, dimension(mx_ogrid,my_ogrid,mz_ogrid,ivar2-ivar1+1) :: fbufi
!
! Post non-blocking sends to send flow data to prosessors that need it
! Note that send_to is never iproc, since this item is taken out of send_par_data_to
! during initialization
!
do iter=1,n_procs_send_part_data
send_to = send_part_data_to(iter)
do ivar=ivar1,ivar2
call mpisend_nonblock_real(f_ogrid(:,:,:,ivar),flow_buf_size,send_to,800+ivar,ireq2D(iter,ivar))
enddo
enddo
!
! Post blocking recieves, if this processor recieves any data from other than self
! Use buffer array to avoid creating temporary array at runtime
!
do iter=1,n_procs_recv_part_data
recv_from = recv_part_data_from(iter)
if (recv_from /= iproc) then
do ivar=ivar1,ivar2
call mpirecv_real(fbufi(:,:,:,ivar),flow_buf_size,recv_from,800+ivar)
enddo
f_ogrid_procs(iter,:,:,:,ivar1:ivar2) = fbufi
else
f_ogrid_procs(iter,:,:,:,ivar1:ivar2) = f_ogrid(:,:,:,ivar1:ivar2)
endif
enddo
!
do iter=1,n_procs_send_part_data
do ivar=ivar1,ivar2
call mpiwait(ireq2D(iter,ivar))
enddo
enddo
call mpibarrier
!
endsubroutine update_ogrid_flow_info
!***********************************************************************
subroutine interpolate_particles_ogrid(ivar1,ivar2,xxp,gp,inear_glob)
!
! Use information from the overlapping curvilinear grid to interpolate the velocity
! of the particle. Must transform to cartesian velocity after interpolation.
!
! Use linear interpolation for all flow variables, except the
! radial component of the velocity. Quadratic interpolation is used for this
! components, as this is consistent with how the radial velocity behaves near
! the cylinder.
!
! 31-okt-17/Jorgen: Coded
!
integer :: ivar1, ivar2
real, dimension (3) :: xxp
real, dimension (ivar2-ivar1+1) :: gp
integer, dimension (4) :: inear_glob
real :: tmp
!
intent(in) :: ivar1, ivar2, xxp, inear_glob
intent(out) :: gp
!
if (ivar1==iux) then
if (ivar2/=iuz) call fatal_error('interpolate_particels_ogrid','should not interpolate rho here!')
if (particle_interpolate==1) then
call interpolate_linear_ogrid(ivar1,ivar1+1,xxp,gp(:),inear_glob)
elseif (particle_interpolate==2) then
call interpolate_pseudoquad(ivar1,xxp,gp(iux),inear_glob)
if (lparticle_uradonly) then
call interpolate_linear_ogrid(ivar1+1,ivar1+1,xxp,gp(iux+1),inear_glob)
else
call interpolate_pseudoquad(ivar1+1,xxp,gp(iux+1),inear_glob)
endif
elseif (particle_interpolate==3) then
call interpolate_quad_ogrid(ivar1,xxp,gp(iux),inear_glob)
if (lparticle_uradonly) then
call interpolate_linear_ogrid(ivar1+1,ivar1+1,xxp,gp(iux+1),inear_glob)
else
call interpolate_quad_ogrid(ivar1+1,xxp,gp(iux+1),inear_glob)
endif
elseif (particle_interpolate==4) then
call interpolate_pseudocubic(ivar1,xxp,gp(iux),inear_glob)
call interpolate_pseudocubic(ivar1+1,xxp,gp(iux+1),inear_glob)
endif
!
! Only update z-velocity if 3D run
!
if (nzgrid_ogrid/=1) then
call interpolate_linear_ogrid(ivar2,ivar2,xxp,gp(iuz),inear_glob)
else
gp(iuz)=0.
endif
!
! Override interpolation scheme if special handling for particles very close to the surface
! is activated
!
if (lspecial_rad_int) then
if ((xglobal_ogrid(inear_glob(1))==xyz0_ogrid(1))) then
call interpolate_ogrid_near(iux,iux,xxp,gp(iux),inear_glob)
endif
elseif (lspecial_rad_int_mom) then
if ((xglobal_ogrid(inear_glob(1))<delta_momentum)) then
call interpolate_ogrid_near_mom(iux,iux,xxp,gp(iux),inear_glob)
endif
endif
tmp=gp(iux)
gp(iux)=tmp*cos(xxp(2))-gp(iuy)*sin(xxp(2))
gp(iuy)=tmp*sin(xxp(2))+gp(iuy)*cos(xxp(2))
else
call interpolate_linear_ogrid(ivar1,ivar2,xxp,gp,inear_glob)
if (ivar1<irho) then
call fatal_error('interpolate_particels_ogrid','should not interpolate anything but rho here!')
endif
endif
!
endsubroutine interpolate_particles_ogrid
!***********************************************************************
subroutine interpolate_linear_ogrid(ivar1,ivar2,xxp,gp,inear_glob)
!
! Use information from the overlapping curvilinear grid to interpolate the velocity
! of the particle. Must transform to cartesian velocity after interpolation.
! Interpolate the value of f to arbitrary (xp, yp, zp) curvilinear coordinate
! using the linear interpolation formula.
!
! g(x,y,z) = A*x*y*z + B*x*y + C*x*z + D*y*z + E*x + F*y + G*z + H .
!
! The coefficients are determined by the 8 grid points surrounding the
! interpolation point.
! Global coordinates are used for the interpolation, such that only velocity
! information needs to be communicated between the processors before interpolation.
!
! 06-jul-17/Jorgen: Adapted from linear_interpolate_curvilinear in solid_cells_ogrid.f90
!
integer :: ivar1, ivar2
real, dimension (3) :: xxp
real, dimension (ivar2-ivar1+1) :: gp
integer, dimension (4) :: inear_glob
!
real, dimension (ivar2-ivar1+1) :: g1, g2, g3, g4, g5, g6, g7, g8
real, dimension (ivar2-ivar1+1) :: f0,f1,gp2
real :: xp0, yp0, zp0
real, save :: dxdydz1, dxdy1, dxdz1, dydz1, dx1, dy1, dz1
integer :: ix0, iy0, iz0, i
integer :: ix0_proc, iy0_proc, iz0_proc, proc, ind_proc
!
intent(in) :: ivar1, ivar2, xxp, inear_glob
intent(out) :: gp
!
real :: dxx0,dxx1,dyy0,dyy1
ix0=inear_glob(1); iy0=inear_glob(2); iz0=inear_glob(3); proc=inear_glob(4)
ind_proc = ip_proc_pointer(proc+1)
if (ind_proc<1) then
print*, 'ERROR: Pointing to f_array that does not exist'
print*, 'This can be due to too many processors in parralelization'
endif
!
! Check if the grid point interval is really correct.
!
if ((xglobal_ogrid(ix0)<=xxp(1) .and. xglobal_ogrid(ix0+1)>=xxp(1) .or. nxgrid_ogrid==1) .and. &
(yglobal_ogrid(iy0)<=xxp(2) .and. yglobal_ogrid(iy0+1)>=xxp(2) .or. nygrid_ogrid==1) .and. &
(zglobal_ogrid(iz0)<=xxp(3) .and. zglobal_ogrid(iz0+1)>=xxp(3) .or. nzgrid_ogrid==1)) then
! Everything okay
else
print*, 'interpolate_linear_ogrid: Global interpolation point does not ' // &
'lie within the calculated grid point interval.'
print*, 'iproc = ', iproc
print*, 'ix0, iy0, iz0 = ', ix0, iy0, iz0
print*, 'xp, xp0, xp1 = ', xxp(1), xglobal_ogrid(ix0), xglobal_ogrid(ix0+1)
print*, 'yp, yp0, yp1 = ', xxp(2), yglobal_ogrid(iy0), yglobal_ogrid(iy0+1)
print*, 'zp, zp0, zp1 = ', xxp(3), zglobal_ogrid(iz0), zglobal_ogrid(iz0+1)
call fatal_error('interpolate_linear_ogrid','point outside of interval for particle interpolation')
return
endif
!
! Redefine the interpolation point in coordinates relative to lowest corner.
! Set it equal to 0 for dimensions having 1 grid points; this will make sure
! that the interpolation is bilinear for 2D grids.
!
xp0=0; yp0=0; zp0=0
if (nxgrid_ogrid/=1) xp0=xxp(1)-xglobal_ogrid(ix0)
if (nygrid_ogrid/=1) yp0=xxp(2)-yglobal_ogrid(iy0)
if (nzgrid_ogrid/=1) zp0=xxp(3)-zglobal_ogrid(iz0)
!
! Calculate derived grid spacing parameters needed for interpolation.
!
dx1=1./(xglobal_ogrid(ix0+1)-xglobal_ogrid(ix0))
dy1=1./(yglobal_ogrid(iy0+1)-yglobal_ogrid(iy0))
if (nzgrid_ogrid/=1) then
dz1=1./(zglobal_ogrid(iz0+1)-zglobal_ogrid(iz0))
else
dz1=1.
endif
!
dxdy1=dx1*dy1; dxdz1=dx1*dz1; dydz1=dy1*dz1
!! dxdydz1=dx1*dy1*dz1
dxx0=xxp(1)-xglobal_ogrid(ix0)
dxx1=xxp(1)-xglobal_ogrid(ix0+1)
dyy0=xxp(2)-yglobal_ogrid(iy0)
dyy1=xxp(2)-yglobal_ogrid(iy0+1)
!
! Transform global coordinates to coordinates local to the f_ogrid_procs array
!
ix0_proc=ix0-nx_ogrid*ip_proc(ind_proc,1)
iy0_proc=iy0-ny_ogrid*ip_proc(ind_proc,2)
iz0_proc=iz0-nz_ogrid*ip_proc(ind_proc,3)
!TODO TODO : REMOVE THIS
!if (ivar2>irho) then
!print*, 'Debug', shape(f_ogrid_procs), 'ivars',ivar1,ivar2,irho,iTT
!print*, 'ERROR: Variable not existing on f_ogrid requested'
!endif
!
! Function values at all corners.
!
g1=f_ogrid_procs(ind_proc,ix0_proc ,iy0_proc ,iz0_proc ,ivar1:ivar2)
g2=f_ogrid_procs(ind_proc,ix0_proc+1,iy0_proc ,iz0_proc ,ivar1:ivar2)
g3=f_ogrid_procs(ind_proc,ix0_proc ,iy0_proc+1,iz0_proc ,ivar1:ivar2)
g4=f_ogrid_procs(ind_proc,ix0_proc+1,iy0_proc+1,iz0_proc ,ivar1:ivar2)
!print*, 'ogriddebug', g1,g2,g3,g4
f0=g1*dxx1*(-dx1)+g2*dxx0*dx1
f1=g3*dxx1*(-dx1)+g4*dxx0*dx1
gp=f0*dyy1*(-dy1)+f1*dyy0*dy1
!! gp2 = g1 + xp0*dx1*(-g1+g2) + yp0*dy1*(-g1+g3) + xp0*yp0*dxdy1*(g1-g2-g3+g4)
!! if (gp(1)/=gp2(1)) then
!! print*, 'ERROR IN LINEAR INTERPOLATION'
!! print*, 'gp:',gp
!! print*, 'gp2:',gp2
!! call fatal_error('interpolate_linear_ogrid','particle velocity interpolation error')
!! endif
!! g5=f_ogrid_procs(ind_proc,ix0_proc ,iy0_proc ,iz0_proc+1,ivar1:ivar2)
!! g6=f_ogrid_procs(ind_proc,ix0_proc+1,iy0_proc ,iz0_proc+1,ivar1:ivar2)
!! g7=f_ogrid_procs(ind_proc,ix0_proc ,iy0_proc+1,iz0_proc+1,ivar1:ivar2)
!! g8=f_ogrid_procs(ind_proc,ix0_proc+1,iy0_proc+1,iz0_proc+1,ivar1:ivar2)
!
! Interpolation formula.
!
!! gp = g1 + xp0*dx1*(-g1+g2) + yp0*dy1*(-g1+g3) + zp0*dz1*(-g1+g5) + &
!! xp0*yp0*dxdy1*(g1-g2-g3+g4) + xp0*zp0*dxdz1*(g1-g2-g5+g6) + &
!! yp0*zp0*dydz1*(g1-g3-g5+g7) + &
!! xp0*yp0*zp0*dxdydz1*(-g1+g2+g3-g4+g5-g6-g7+g8)
!
!
! Simplify if only a 2D-run
!
!
! Do a reality check on the interpolation scheme.
!
if (lcheck_interpolation) then
do i=1,ivar2-ivar1+1
if ((gp(i)>max(g1(i),g2(i),g3(i),g4(i),g5(i),g6(i),g7(i),g8(i))) .or. &
(gp(i)<min(g1(i),g2(i),g3(i),g4(i),g5(i),g6(i),g7(i),g8(i))) .or. &
(gp(i)/=gp(i))) then
if (gp(i)>max(g1(i),g2(i),g3(i),g4(i),g5(i),g6(i),g7(i),g8(i))) then
print*, 'interpolate_linear_ogrid: interpolated value is LARGER than'
print*, 'interpolate_linear_ogrid: a values at the corner points!'
elseif (gp(i)<min(g1(i),g2(i),g3(i),g4(i),g5(i),g6(i),g7(i),g8(i))) then
print*, 'interpolate_linear_ogrid: interpolated value is smaller than'
print*, 'interpolate_linear_ogrid: a values at the corner points!'
elseif (gp(i)/=gp(i)) then
print*, 'interpolate_linear_ogrid: interpolated value is NaN'
endif
print*, 'iproc = ', iproc
!print*, 'ipar = ', ipar
print*, 'interpolate_linear_ogrid: xxp=', xxp
print*, 'interpolate_linear_ogrid: x0, y0, z0=', &
xglobal_ogrid(ix0), yglobal_ogrid(iy0), zglobal_ogrid(iz0)
print*, 'interpolate_linear_ogrid: i, gp(i)=', i, gp(i)
print*, 'interpolate_linear_ogrid: g1...g8=', &
g1(i), g2(i), g3(i), g4(i), g5(i), g6(i), g7(i), g8(i)
print*, '------------------'
call fatal_error('interpolate_linear_ogrid','particle velocity interpolation error')
endif
enddo
endif
!
endsubroutine interpolate_linear_ogrid
!***********************************************************************
subroutine interpolate_ogrid_near(ivar1,ivar2,xxp,gp,inear_glob)
!
! Use information from the overlappint curvilinear grid to interpolate the velocity
! of the particle.
! Special handling for particles very close to the surface.
!
! 26-feb-18/Jorgen: Coded
!
integer :: ivar1, ivar2
real, dimension (3) :: xxp
real, dimension (ivar2-ivar1+1) :: gp
integer, dimension (4) :: inear_glob
!
real, dimension (ivar2-ivar1+1) :: g1, g2, g3, g4, f0, f1!g5, g6, g7, g8
real :: xp0, yp0, zp0
real, save :: dxdydz1, dxdy1, dxdz1, dydz1, dx1, dy1, dz1
integer :: ix0, iy0, iz0, i
integer :: ix0_proc, iy0_proc, iz0_proc, proc, ind_proc
!
intent(in) :: ivar1, ivar2, xxp, inear_glob
intent(out) :: gp
!
ix0=inear_glob(1); iy0=inear_glob(2); iz0=inear_glob(3); proc=inear_glob(4)
ind_proc = ip_proc_pointer(proc+1)
if (ind_proc<1) then
print*, 'ERROR: Pointing to f_array that does not exist'
print*, 'This may be due to too many processors in parallel'
endif
!
! Check if the grid point interval is really correct.
!
if ((xglobal_ogrid(ix0)<=xxp(1) .and. xglobal_ogrid(ix0+1)>=xxp(1) .or. nxgrid_ogrid==1) .and. &
(yglobal_ogrid(iy0)<=xxp(2) .and. yglobal_ogrid(iy0+1)>=xxp(2) .or. nygrid_ogrid==1) .and. &
(zglobal_ogrid(iz0)<=xxp(3) .and. zglobal_ogrid(iz0+1)>=xxp(3) .or. nzgrid_ogrid==1)) then
! Everything okay
else
print*, 'interpolate_linear_ogrid: Global interpolation point does not ' // &
'lie within the calculated grid point interval.'
print*, 'iproc = ', iproc
print*, 'ix0, iy0, iz0 = ', ix0, iy0, iz0
print*, 'xp, xp0, xp1 = ', xxp(1), xglobal_ogrid(ix0), xglobal_ogrid(ix0+1)
print*, 'yp, yp0, yp1 = ', xxp(2), yglobal_ogrid(iy0), yglobal_ogrid(iy0+1)
print*, 'zp, zp0, zp1 = ', xxp(3), zglobal_ogrid(iz0), zglobal_ogrid(iz0+1)
call fatal_error('interpolate_linear_ogrid','point outside of interval for particle interpolation')
return
endif
!
! Redefine the interpolation point in coordinates relative to lowest corner.
! Set it equal to 0 for dimensions having 1 grid points; this will make sure
! that the interpolation is bilinear for 2D grids.
!
xp0=0; yp0=0; zp0=0
!if (nxgrid_ogrid/=1) xp0=xxp(1)-xyz0_ogrid(1)
if (nxgrid_ogrid/=1) xp0=xxp(1)-xglobal_ogrid(ix0)
if (nygrid_ogrid/=1) yp0=xxp(2)-yglobal_ogrid(iy0)
if (nzgrid_ogrid/=1) zp0=xxp(3)-zglobal_ogrid(iz0)
!
! Calculate derived grid spacing parameters needed for interpolation.
!
!dx1=1./(xglobal_ogrid(ix0+1)-xyz0_ogrid(1))
dx1=1./(xglobal_ogrid(ix0+1)-xglobal_ogrid(ix0))
dy1=1./(yglobal_ogrid(iy0+1)-yglobal_ogrid(iy0))
if (nzgrid_ogrid/=1) then
dz1=1./(zglobal_ogrid(iz0+1)-zglobal_ogrid(iz0))
else
dz1=1.
endif
!
dxdy1=dx1*dy1; dxdz1=dx1*dz1; dydz1=dy1*dz1
dxdydz1=dx1*dy1*dz1
!
! Transform global coordinates to coordinates local to the f_ogrid_procs array
!
ix0_proc=ix0-nx_ogrid*ip_proc(ind_proc,1)
iy0_proc=iy0-ny_ogrid*ip_proc(ind_proc,2)
iz0_proc=iz0-nz_ogrid*ip_proc(ind_proc,3)
!
! Function values at all corners.
!
g1=f_ogrid_procs(ind_proc,ix0_proc ,iy0_proc ,iz0_proc ,ivar1:ivar2)
g2=f_ogrid_procs(ind_proc,ix0_proc+1,iy0_proc ,iz0_proc ,ivar1:ivar2)
g3=f_ogrid_procs(ind_proc,ix0_proc ,iy0_proc+1,iz0_proc ,ivar1:ivar2)
g4=f_ogrid_procs(ind_proc,ix0_proc+1,iy0_proc+1,iz0_proc ,ivar1:ivar2)
! g5=f_ogrid_procs(ind_proc,ix0_proc ,iy0_proc ,iz0_proc+1,ivar1:ivar2)
! g6=f_ogrid_procs(ind_proc,ix0_proc+1,iy0_proc ,iz0_proc+1,ivar1:ivar2)
! g7=f_ogrid_procs(ind_proc,ix0_proc ,iy0_proc+1,iz0_proc+1,ivar1:ivar2)
! g8=f_ogrid_procs(ind_proc,ix0_proc+1,iy0_proc+1,iz0_proc+1,ivar1:ivar2)
!
! Interpolation formula.
! Linear interpolation along theta(y) and z-direction
!
if (nzgrid_ogrid/=1) then
call fatal_error('interpolate_ogrid_near','not implemented in 3D')
endif
f0 = g1 + yp0*dy1*(-g1+g3)
f1 = g2 + yp0*dy1*(-g2+g4)
if (any(f0/=0.)) then
call fatal_error('interpolate_ogrid_near','interpolated value should be zero at the surface')
endif
gp = f1*xp0*xp0*dx1*dx1
!gp = g1 + xp0*dx1*(-g1+g2) + yp0*dy1*(-g1+g3) + zp0*dz1*(-g1+g5) + &
! xp0*yp0*dxdy1*(g1-g2-g3+g4) + xp0*zp0*dxdz1*(g1-g2-g5+g6) + &
! yp0*zp0*dydz1*(g1-g3-g5+g7) + &
! xp0*yp0*zp0*dxdydz1*(-g1+g2+g3-g4+g5-g6-g7+g8)
!
! Do a reality check on the interpolation scheme.
!
if (lcheck_interpolation) then
do i=1,ivar2-ivar1+1
if ((gp(i)>max(0.,g2(i),g4(i))) .or. &
(gp(i)<min(0.,g2(i),g4(i))) .or. &
(gp(i)/=gp(i))) then
if (gp(i)>max(g1(i),g2(i),g3(i),g4(i))) then
print*, 'interpolate_linear_ogrid: interpolated value is LARGER than'
print*, 'interpolate_linear_ogrid: a values at the corner points!'
elseif (gp(i)<min(g1(i),g2(i),g3(i),g4(i))) then
print*, 'interpolate_linear_ogrid: interpolated value is smaller than'
print*, 'interpolate_linear_ogrid: a values at the corner points!'
elseif (gp(i)/=gp(i)) then
print*, 'interpolate_linear_ogrid: interpolated value is NaN'
endif
print*, 'iproc = ', iproc
!print*, 'ipar = ', ipar
print*, 'interpolate_linear_ogrid: xxp=', xxp
print*, 'interpolate_linear_ogrid: x0, y0, z0=', &
xglobal_ogrid(ix0), yglobal_ogrid(iy0), zglobal_ogrid(iz0)
print*, 'interpolate_linear_ogrid: i, gp(i)=', i, gp(i)
print*, 'interpolate_linear_ogrid: g1...g8=', &
g1(i), g2(i), g3(i), g4(i)
print*, '------------------'
call fatal_error('interpolate_linear_ogrid','particle velocity interpolation error')
endif
enddo
endif
!
endsubroutine interpolate_ogrid_near
!***********************************************************************
subroutine interpolate_ogrid_near_mom(ivar1,ivar2,xxp,gp,inear_glob)
!
! Use information from the overlappint curvilinear grid to interpolate the velocity
! of the particle. Do for all particles within momentum thickness of the
! surface.
! Special handling for particles very close to the surface.
!
! 21-mar-18/Jorgen: Coded
!
integer :: ivar1, ivar2
real, dimension (3) :: xxp
real, dimension (ivar2-ivar1+1) :: gp
integer, dimension (4) :: inear_glob
!
real, dimension (ivar2-ivar1+1) :: g1, g2, g3, g4, f0, f1!g5, g6, g7, g8
real :: xp0, yp0, zp0
real, save :: dxdydz1, dxdy1, dxdz1, dydz1, dx1, dy1, dz1
integer :: ix0, iy0, iz0, i
integer :: ix0_proc, iy0_proc, iz0_proc, proc, ind_proc
!
intent(in) :: ivar1, ivar2, xxp, inear_glob
intent(out) :: gp
!
ix0=inear_glob(1); iy0=inear_glob(2); iz0=inear_glob(3); proc=inear_glob(4)
ind_proc = ip_proc_pointer(proc+1)
if (ind_proc<1) then
print*, 'ERROR: Pointing to f_array that does not exist'
print*, 'This can be due to too many processors in parralelization'
endif
!
! Check if the grid point interval is really correct.
!
if ((xglobal_ogrid(ix0)<=xxp(1) .and. xglobal_ogrid(ix0+1)>=xxp(1) .or. nxgrid_ogrid==1) .and. &
(yglobal_ogrid(iy0)<=xxp(2) .and. yglobal_ogrid(iy0+1)>=xxp(2) .or. nygrid_ogrid==1) .and. &
(zglobal_ogrid(iz0)<=xxp(3) .and. zglobal_ogrid(iz0+1)>=xxp(3) .or. nzgrid_ogrid==1)) then
! Everything okay
else
print*, 'interpolate_linear_ogrid: Global interpolation point does not ' // &
'lie within the calculated grid point interval.'
print*, 'iproc = ', iproc
print*, 'ix0, iy0, iz0 = ', ix0, iy0, iz0
print*, 'xp, xp0, xp1 = ', xxp(1), xglobal_ogrid(ix0), xglobal_ogrid(ix0+1)
print*, 'yp, yp0, yp1 = ', xxp(2), yglobal_ogrid(iy0), yglobal_ogrid(iy0+1)
print*, 'zp, zp0, zp1 = ', xxp(3), zglobal_ogrid(iz0), zglobal_ogrid(iz0+1)
call fatal_error('interpolate_linear_ogrid','point outside of interval for particle interpolation')
return
endif
!
! Redefine the interpolation point in coordinates relative to lowest corner.
! Set it equal to 0 for dimensions having 1 grid points; this will make sure
! that the interpolation is bilinear for 2D grids.
!
xp0=0; yp0=0; zp0=0
if (nxgrid_ogrid/=1) xp0=xxp(1)-xyz0_ogrid(1)
!if (nxgrid_ogrid/=1) xp0=xxp(1)-xglobal_ogrid(ix0)
if (nygrid_ogrid/=1) yp0=xxp(2)-yglobal_ogrid(iy0)
if (nzgrid_ogrid/=1) zp0=xxp(3)-zglobal_ogrid(iz0)
!
! Calculate derived grid spacing parameters needed for interpolation.
!
dx1=1./(xglobal_ogrid(ix0+1)-xyz0_ogrid(1))
!dx1=1./(xglobal_ogrid(ix0+1)-xglobal_ogrid(ix0))
dy1=1./(yglobal_ogrid(iy0+1)-yglobal_ogrid(iy0))
if (nzgrid_ogrid/=1) then
dz1=1./(zglobal_ogrid(iz0+1)-zglobal_ogrid(iz0))
else
dz1=1.
endif
!
dxdy1=dx1*dy1; dxdz1=dx1*dz1; dydz1=dy1*dz1
dxdydz1=dx1*dy1*dz1
!
! Transform global coordinates to coordinates local to the f_ogrid_procs array
!
ix0_proc=ix0-nx_ogrid*ip_proc(ind_proc,1)
iy0_proc=iy0-ny_ogrid*ip_proc(ind_proc,2)
iz0_proc=iz0-nz_ogrid*ip_proc(ind_proc,3)
!
! Function values at all corners.
!
!g1=f_ogrid_procs(ind_proc,ix0_proc ,iy0_proc ,iz0_proc ,ivar1:ivar2)
g2=f_ogrid_procs(ind_proc,ix0_proc+1,iy0_proc ,iz0_proc ,ivar1:ivar2)
!g3=f_ogrid_procs(ind_proc,ix0_proc ,iy0_proc+1,iz0_proc ,ivar1:ivar2)
g4=f_ogrid_procs(ind_proc,ix0_proc+1,iy0_proc+1,iz0_proc ,ivar1:ivar2)
! g5=f_ogrid_procs(ind_proc,ix0_proc ,iy0_proc ,iz0_proc+1,ivar1:ivar2)
! g6=f_ogrid_procs(ind_proc,ix0_proc+1,iy0_proc ,iz0_proc+1,ivar1:ivar2)
! g7=f_ogrid_procs(ind_proc,ix0_proc ,iy0_proc+1,iz0_proc+1,ivar1:ivar2)
! g8=f_ogrid_procs(ind_proc,ix0_proc+1,iy0_proc+1,iz0_proc+1,ivar1:ivar2)
!
! Interpolation formula.
! Linear interpolation along theta(y) and z-direction
!
if (nzgrid_ogrid/=1) then
call fatal_error('interpolate_ogrid_near_mom','not implemented in 3D')
endif
!f0 = g1 + yp0*dy1*(-g1+g3)
f1 = g2 + yp0*dy1*(-g2+g4)
if (any(f0/=0.)) then
call fatal_error('interpolate_ogrid_near_mom','interpolated value should be zero at the surface')
endif
gp = f1*xp0*xp0*dx1*dx1
!gp = g1 + xp0*dx1*(-g1+g2) + yp0*dy1*(-g1+g3) + zp0*dz1*(-g1+g5) + &
! xp0*yp0*dxdy1*(g1-g2-g3+g4) + xp0*zp0*dxdz1*(g1-g2-g5+g6) + &
! yp0*zp0*dydz1*(g1-g3-g5+g7) + &
! xp0*yp0*zp0*dxdydz1*(-g1+g2+g3-g4+g5-g6-g7+g8)
!
! Do a reality check on the interpolation scheme.
!
if (lcheck_interpolation) then
do i=1,ivar2-ivar1+1
if ((gp(i)>max(0.,g2(i),g4(i))) .or. &
(gp(i)<min(0.,g2(i),g4(i))) .or. &
(gp(i)/=gp(i))) then
if (gp(i)>max(g1(i),g2(i),g3(i),g4(i))) then
print*, 'interpolate_linear_ogrid: interpolated value is LARGER than'
print*, 'interpolate_linear_ogrid: a values at the corner points!'
elseif (gp(i)<min(g1(i),g2(i),g3(i),g4(i))) then
print*, 'interpolate_linear_ogrid: interpolated value is smaller than'
print*, 'interpolate_linear_ogrid: a values at the corner points!'
elseif (gp(i)/=gp(i)) then
print*, 'interpolate_linear_ogrid: interpolated value is NaN'
endif
print*, 'iproc = ', iproc
!print*, 'ipar = ', ipar
print*, 'interpolate_linear_ogrid: xxp=', xxp
print*, 'interpolate_linear_ogrid: x0, y0, z0=', &
xglobal_ogrid(ix0), yglobal_ogrid(iy0), zglobal_ogrid(iz0)
print*, 'interpolate_linear_ogrid: i, gp(i)=', i, gp(i)
print*, 'interpolate_linear_ogrid: g1...g8=', &
g1(i), g2(i), g3(i), g4(i)
print*, '------------------'
call fatal_error('interpolate_linear_ogrid','particle velocity interpolation error')
endif
enddo
endif
!
endsubroutine interpolate_ogrid_near_mom
!***********************************************************************
subroutine interpolate_pseudoquad(ivar,xxp,gp,inear_glob)
!
! Use information from the overlappint curvilinear grid to interpolate
! flow quantities to the particle, using quadratic inteprolation only
! for the radial direction.
!
! 31-okt-17/Jorgen: Coded
!
integer :: ivar
real, dimension (3) :: xxp
real :: gp
integer, dimension (4) :: inear_glob
!
integer :: ix0, iy0, iz0, ix1, iy1, iz1, ix2
integer :: ix0_proc, iy0_proc, iz0_proc, proc, ind_proc
real :: dx10_1, dx21_1, dx20_1, dy_1, dz_1
real :: dxx0, dxx1, dxx2, dyy0, dyy1, dzz0, dzz1
real :: g000,g100,g010,g110,g200,g210,g001,g101,g011,g111,g201,g211
real :: f00, f01, f10, f11, h0, h1
intent(in) :: ivar, xxp, inear_glob
intent(out) :: gp
!
ix0=inear_glob(1); iy0=inear_glob(2); iz0=inear_glob(3); proc=inear_glob(4)
ind_proc = ip_proc_pointer(proc+1)
if (ind_proc<1) then
print*, 'ERROR: Pointing to f_array that does not exist'
print*, 'This can be due to too many processors in parralelization'
endif
!
! Check if the grid point interval is really correct.
!
ix1=ix0+1
iy1=iy0+1
iz1=iz0+1
if ((xglobal_ogrid(ix0)<=xxp(1) .and. xglobal_ogrid(ix1)>=xxp(1) .or. nxgrid_ogrid==1) .and. &
(yglobal_ogrid(iy0)<=xxp(2) .and. yglobal_ogrid(iy1)>=xxp(2) .or. nygrid_ogrid==1) .and. &
(zglobal_ogrid(iz0)<=xxp(3) .and. zglobal_ogrid(iz1)>=xxp(3) .or. nzgrid_ogrid==1)) then
! Everything okay
else
print*, 'interpolate_pseudoquad: Global interpolation point does not ' // &
'lie within the calculated grid point interval.'
print*, 'iproc = ', iproc
print*, 'ix0, iy0, iz0 = ', ix0, iy0, iz0
print*, 'xp, xp0, xp1 = ', xxp(1), xglobal_ogrid(ix0), xglobal_ogrid(ix0+1)
print*, 'yp, yp0, yp1 = ', xxp(2), yglobal_ogrid(iy0), yglobal_ogrid(iy0+1)
print*, 'zp, zp0, zp1 = ', xxp(3), zglobal_ogrid(iz0), zglobal_ogrid(iz0+1)
call fatal_error('interpolate_pseudoquad','point outside of interval for particle interpolation')
return
endif
!
! Redefine closes grid point in radial direciton, if necessary
!
dxx0=xxp(1)-xglobal_ogrid(ix0)
dxx1=xxp(1)-xglobal_ogrid(ix1)
if ((abs(dxx0)<abs(dxx1)).and.(xglobal_ogrid(ix0)>xyz0_ogrid(1))) then
ix1=ix0
ix0=ix0-1
dxx0=xxp(1)-xglobal_ogrid(ix0)
dxx1=xxp(1)-xglobal_ogrid(ix1)
endif
ix2=ix0+2
dx10_1=1./(xglobal_ogrid(ix1)-xglobal_ogrid(ix0))
dx21_1=1./(xglobal_ogrid(ix2)-xglobal_ogrid(ix1))
dx20_1=1./(xglobal_ogrid(ix2)-xglobal_ogrid(ix0))
dy_1= 1./(yglobal_ogrid(iy1)-yglobal_ogrid(iy0))
dxx2=xxp(1)-xglobal_ogrid(ix2)
dyy0=xxp(2)-yglobal_ogrid(iy0)
dyy1=xxp(2)-yglobal_ogrid(iy1)
!
ix0_proc=ix0-nx_ogrid*ip_proc(ind_proc,1)
iy0_proc=iy0-ny_ogrid*ip_proc(ind_proc,2)
iz0_proc=iz0-nz_ogrid*ip_proc(ind_proc,3)
g000=f_ogrid_procs(ind_proc,ix0_proc ,iy0_proc ,iz0_proc ,ivar)
g100=f_ogrid_procs(ind_proc,ix0_proc+1,iy0_proc ,iz0_proc ,ivar)
g010=f_ogrid_procs(ind_proc,ix0_proc ,iy0_proc+1,iz0_proc ,ivar)
g110=f_ogrid_procs(ind_proc,ix0_proc+1,iy0_proc+1,iz0_proc ,ivar)
g200=f_ogrid_procs(ind_proc,ix0_proc+2,iy0_proc ,iz0_proc ,ivar)
g210=f_ogrid_procs(ind_proc,ix0_proc+2,iy0_proc+1,iz0_proc ,ivar)
!
! Simplify if only a 2D-run
!
if (nzgrid_ogrid==1) then
f00=g000*dxx1*dxx2*dx10_1*dx20_1+g100*dxx0*dxx2*dx10_1*(-dx21_1)+g200*dxx0*dxx1*dx20_1*dx21_1
f10=g010*dxx1*dxx2*dx10_1*dx20_1+g110*dxx0*dxx2*dx10_1*(-dx21_1)+g210*dxx0*dxx1*dx20_1*dx21_1
gp=f00*dyy1*(-dy_1)+f10*dyy0*dy_1
else
dzz0=xxp(3)-zglobal_ogrid(iz0)
dzz1=xxp(3)-zglobal_ogrid(iz1)
dz_1=1./(zglobal_ogrid(iz1)-zglobal_ogrid(iz0))
!
g001=f_ogrid_procs(ind_proc,ix0_proc ,iy0_proc ,iz0_proc+1,ivar)
g101=f_ogrid_procs(ind_proc,ix0_proc+1,iy0_proc ,iz0_proc+1,ivar)
g011=f_ogrid_procs(ind_proc,ix0_proc ,iy0_proc+1,iz0_proc+1,ivar)
g111=f_ogrid_procs(ind_proc,ix0_proc+1,iy0_proc+1,iz0_proc+1,ivar)
g201=f_ogrid_procs(ind_proc,ix0_proc+2,iy0_proc ,iz0_proc+1,ivar)
g211=f_ogrid_procs(ind_proc,ix0_proc+2,iy0_proc+1,iz0_proc+1,ivar)
!
f00=g000*dxx1*dxx2*dx10_1*dx20_1+g100*dxx0*dxx2*dx10_1*(-dx21_1)+g200*dxx0*dxx1*dx20_1*dx21_1
f10=g010*dxx1*dxx2*dx10_1*dx20_1+g110*dxx0*dxx2*dx10_1*(-dx21_1)+g210*dxx0*dxx1*dx20_1*dx21_1
f01=g001*dxx1*dxx2*dx10_1*dx20_1+g101*dxx0*dxx2*dx10_1*(-dx21_1)+g201*dxx0*dxx1*dx20_1*dx21_1
f11=g011*dxx1*dxx2*dx10_1*dx20_1+g111*dxx0*dxx2*dx10_1*(-dx21_1)+g211*dxx0*dxx1*dx20_1*dx21_1
h0=f00*dyy1*(-dy_1)+f10*dyy0*dy_1
h1=f01*dyy1*(-dy_1)+f11*dyy0*dy_1
gp=h0*dzz1*(-dz_1)+h1*dzz0*dz_1
endif
!
! Do a reality check on the interpolation scheme.
!
if (lcheck_interpolation) then
if ((gp>max(g000,g100,g010,g110,g200,g210)) .or. &
(gp<min(g000,g100,g010,g110,g200,g210)) .or. &
(gp/=gp)) then
if (gp>max(g000,g100,g010,g110,g200,g210)) then
print*, 'interpolate_pseudoquad: interpolated value is LARGER than'
print*, 'interpolate_pseudoquad: a values at the corner points!'
elseif (gp<min(g000,g100,g010,g110,g200,g210)) then
print*, 'interpolate_pseudoquad: interpolated value is smaller than'
print*, 'interpolate_pseudoquad: a values at the corner points!'
elseif (gp/=gp) then
print*, 'interpolate_linear_ogrid: interpolated value is NaN'
endif
print*, 'iproc = ', iproc
!print*, 'ipar = ', ipar
print*, 'interpolate_pseudoquad: xxp=', xxp
print*, 'interpolate_pseudoquad: x0, y0, z0=', &
xglobal_ogrid(ix0), yglobal_ogrid(iy0), zglobal_ogrid(iz0)
print*, 'interpolate_pseudoquad: ivar, gp=', ivar, gp
print*, 'interpolate_pseudoquad: g1...g8=', &
g000,g100,g010,g110,g200,g210
print*, '------------------'
call fatal_error('interpolate_pseudoquad','particle velocity interpolation error')
endif
endif
!
endsubroutine interpolate_pseudoquad
!***********************************************************************
subroutine interpolate_pseudocubic(ivar,xxp,gp,inear_glob)
!
! Use information from the overlappint curvilinear grid to interpolate
! flow quantities to the particle, using quadratic inteprolation only
! for the radial direction.
!
! 31-okt-17/Jorgen: Coded
!
integer :: ivar
real, dimension (3) :: xxp
real :: gp
integer, dimension (4) :: inear_glob
!
integer :: ix0, iy0, iz0, ix1, iy1, iz1, ix2, ix3
integer :: ix0_proc, iy0_proc, iz0_proc, proc, ind_proc
real :: dx10_1, dx21_1, dx20_1, dy_1, dz_1
real :: dxx0, dxx1, dxx2, dyy0, dyy1, dzz0, dzz1
real :: g000,g100,g010,g110,g200,g210,g001,g101,g011,g111,g201,g211
real :: g300,g310,dxx3,dx30_1,dx31_1,dx32_1
real :: f00, f01, f10, f02,f03, f11, h0, h1
intent(in) :: ivar, xxp, inear_glob
intent(out) :: gp
!
ix0=inear_glob(1); iy0=inear_glob(2); iz0=inear_glob(3); proc=inear_glob(4)
ind_proc = ip_proc_pointer(proc+1)
if (ind_proc<1) then
print*, 'ERROR: Pointing to f_array that does not exist'
print*, 'This can be due to too many processors in parralelization'
endif
!
! Check if the grid point interval is really correct.
!
ix1=ix0+1
iy1=iy0+1
iz1=iz0+1
if ((xglobal_ogrid(ix0)<=xxp(1) .and. xglobal_ogrid(ix1)>=xxp(1) .or. nxgrid_ogrid==1) .and. &
(yglobal_ogrid(iy0)<=xxp(2) .and. yglobal_ogrid(iy1)>=xxp(2) .or. nygrid_ogrid==1) .and. &
(zglobal_ogrid(iz0)<=xxp(3) .and. zglobal_ogrid(iz1)>=xxp(3) .or. nzgrid_ogrid==1)) then
! Everything okay
else
print*, 'interpolate_pseudocubic: Global interpolation point does not ' // &
'lie within the calculated grid point interval.'
print*, 'iproc = ', iproc
print*, 'ix0, iy0, iz0 = ', ix0, iy0, iz0
print*, 'xp, xp0, xp1 = ', xxp(1), xglobal_ogrid(ix0), xglobal_ogrid(ix0+1)
print*, 'yp, yp0, yp1 = ', xxp(2), yglobal_ogrid(iy0), yglobal_ogrid(iy0+1)
print*, 'zp, zp0, zp1 = ', xxp(3), zglobal_ogrid(iz0), zglobal_ogrid(iz0+1)
call fatal_error('interpolate_pseudocubic','point outside of interval for particle interpolation')
return
endif
!
! Redefine closes grid point in radial direciton, if necessary
!
dxx0=xxp(1)-xglobal_ogrid(ix0)
dxx1=xxp(1)-xglobal_ogrid(ix1)
if ((abs(dxx0)<abs(dxx1)).and.(xglobal_ogrid(ix0)>xyz0_ogrid(1))) then
ix1=ix0
ix0=ix0-1
dxx0=xxp(1)-xglobal_ogrid(ix0)
dxx1=xxp(1)-xglobal_ogrid(ix1)
endif
ix2=ix0+2
ix3=ix0+3
dx10_1=1./(xglobal_ogrid(ix1)-xglobal_ogrid(ix0))
dx21_1=1./(xglobal_ogrid(ix2)-xglobal_ogrid(ix1))
dx32_1=1./(xglobal_ogrid(ix3)-xglobal_ogrid(ix2))
dx20_1=1./(xglobal_ogrid(ix2)-xglobal_ogrid(ix0))
dx31_1=1./(xglobal_ogrid(ix3)-xglobal_ogrid(ix1))
dx30_1=1./(xglobal_ogrid(ix3)-xglobal_ogrid(ix0))
dy_1= 1./(yglobal_ogrid(iy1)-yglobal_ogrid(iy0))
dxx2=xxp(1)-xglobal_ogrid(ix2)
dxx3=xxp(1)-xglobal_ogrid(ix3)
dyy0=xxp(2)-yglobal_ogrid(iy0)
dyy1=xxp(2)-yglobal_ogrid(iy1)
!
ix0_proc=ix0-nx_ogrid*ip_proc(ind_proc,1)
iy0_proc=iy0-ny_ogrid*ip_proc(ind_proc,2)
iz0_proc=iz0-nz_ogrid*ip_proc(ind_proc,3)
g000=f_ogrid_procs(ind_proc,ix0_proc ,iy0_proc ,iz0_proc ,ivar)
g100=f_ogrid_procs(ind_proc,ix0_proc+1,iy0_proc ,iz0_proc ,ivar)
g010=f_ogrid_procs(ind_proc,ix0_proc ,iy0_proc+1,iz0_proc ,ivar)
g110=f_ogrid_procs(ind_proc,ix0_proc+1,iy0_proc+1,iz0_proc ,ivar)
g200=f_ogrid_procs(ind_proc,ix0_proc+2,iy0_proc ,iz0_proc ,ivar)
g210=f_ogrid_procs(ind_proc,ix0_proc+2,iy0_proc+1,iz0_proc ,ivar)
g300=f_ogrid_procs(ind_proc,ix0_proc+3,iy0_proc ,iz0_proc ,ivar)
g310=f_ogrid_procs(ind_proc,ix0_proc+3,iy0_proc+1,iz0_proc ,ivar)
!
! Simplify if only a 2D-run
!
if (xglobal_ogrid(ix0)<xyz0_ogrid(1)) then
call fatal_error('interpolate_pseudocubic',&
'illegal inteprolation point, inside cylinder')
endif
if (nzgrid_ogrid==1) then
f00=g000*dyy1*(-dy_1)+g010*dyy0*dy_1 !x0
f01=g100*dyy1*(-dy_1)+g110*dyy0*dy_1 !x1
f02=g200*dyy1*(-dy_1)+g210*dyy0*dy_1 !x2
f03=g300*dyy1*(-dy_1)+g310*dyy0*dy_1 !x3
if (xglobal_ogrid(ix0)==xyz0_ogrid(1)) then
gp=f00*dxx1*dxx2*(-dx10_1)*(-dx20_1) + &
f01*dxx0*dxx2*( dx10_1)*(-dx21_1) + &
f02*dxx0*dxx1*( dx20_1)*( dx21_1)
else
gp=f00*dxx1*dxx2*dxx3*(-dx10_1)*(-dx20_1)*(-dx30_1) + &
f01*dxx0*dxx2*dxx3*( dx10_1)*(-dx21_1)*(-dx31_1) + &
f02*dxx0*dxx1*dxx3*( dx20_1)*( dx21_1)*(-dx32_1) + &
f03*dxx0*dxx1*dxx2*( dx30_1)*( dx31_1)*( dx32_1)
endif
! f00=g000*dxx1*dxx2*dx10_1*dx20_1+g100*dxx0*dxx2*dx10_1*(-dx21_1)+g200*dxx0*dxx1*dx20_1*dx21_1
! f10=g010*dxx1*dxx2*dx10_1*dx20_1+g110*dxx0*dxx2*dx10_1*(-dx21_1)+g210*dxx0*dxx1*dx20_1*dx21_1
! gp=f00*dyy1*(-dy_1)+f10*dyy0*dy_1
else
! NOT IMPLEMENTED IN 3D
! dzz0=xxp(3)-zglobal_ogrid(iz0)
! dzz1=xxp(3)-zglobal_ogrid(iz1)
! dz_1=1./(zglobal_ogrid(iz1)-zglobal_ogrid(iz0))
! !
! g001=f_ogrid_procs(ind_proc,ix0_proc ,iy0_proc ,iz0_proc+1,ivar)
! g101=f_ogrid_procs(ind_proc,ix0_proc+1,iy0_proc ,iz0_proc+1,ivar)
! g011=f_ogrid_procs(ind_proc,ix0_proc ,iy0_proc+1,iz0_proc+1,ivar)
! g111=f_ogrid_procs(ind_proc,ix0_proc+1,iy0_proc+1,iz0_proc+1,ivar)
! g201=f_ogrid_procs(ind_proc,ix0_proc+2,iy0_proc ,iz0_proc+1,ivar)
! g211=f_ogrid_procs(ind_proc,ix0_proc+2,iy0_proc+1,iz0_proc+1,ivar)
! !
! f00=g000*dxx1*dxx2*dx10_1*dx20_1+g100*dxx0*dxx2*dx10_1*(-dx21_1)+g200*dxx0*dxx1*dx20_1*dx21_1
! f10=g010*dxx1*dxx2*dx10_1*dx20_1+g110*dxx0*dxx2*dx10_1*(-dx21_1)+g210*dxx0*dxx1*dx20_1*dx21_1
! f01=g001*dxx1*dxx2*dx10_1*dx20_1+g101*dxx0*dxx2*dx10_1*(-dx21_1)+g201*dxx0*dxx1*dx20_1*dx21_1
! f11=g011*dxx1*dxx2*dx10_1*dx20_1+g111*dxx0*dxx2*dx10_1*(-dx21_1)+g211*dxx0*dxx1*dx20_1*dx21_1
!
! h0=f00*dyy1*(-dy_1)+f10*dyy0*dy_1
! h1=f01*dyy1*(-dy_1)+f11*dyy0*dy_1
!
! gp=h0*dzz1*(-dz_1)+h1*dzz0*dz_1
endif
!
! Do a reality check on the interpolation scheme.
!
if (lcheck_interpolation) then
if ((gp>max(g000,g100,g010,g110,g200,g210)) .or. &
(gp<min(g000,g100,g010,g110,g200,g210)) .or. &
(gp/=gp)) then
if (gp>max(g000,g100,g010,g110,g200,g210)) then
print*, 'interpolate_pseudocubic: interpolated value is LARGER than'
print*, 'interpolate_pseudocubic: a values at the corner points!'
elseif (gp<min(g000,g100,g010,g110,g200,g210)) then
print*, 'interpolate_pseudocubic: interpolated value is smaller than'
print*, 'interpolate_pseudocubic: a values at the corner points!'
elseif (gp/=gp) then
print*, 'interpolate_pseudocubic: interpolated value is NaN'
endif
print*, 'iproc = ', iproc
!print*, 'ipar = ', ipar
print*, 'interpolate_pseudocubic: xxp=', xxp
print*, 'interpolate_pseudocubic: x0, y0, z0=', &
xglobal_ogrid(ix0), yglobal_ogrid(iy0), zglobal_ogrid(iz0)
print*, 'interpolate_pseudocubic: ivar, gp=', ivar, gp
print*, 'interpolate_pseudocubic: g1...g8=', &
g000,g100,g010,g110,g200,g210
print*, '------------------'
call fatal_error('interpolate_pseudocubic','particle velocity interpolation error')
endif
endif
!
endsubroutine interpolate_pseudocubic
!***********************************************************************
subroutine interpolate_quad_ogrid(ivar,xxp,gp,inear_glob)
!
! Use information from the overlappint curvilinear grid to interpolate
! flow quantities to the particle, using quadratic inteprolation only
! for the radial direction.
!
! 31-okt-17/Jorgen: Coded
!
integer :: ivar
real, dimension (3) :: xxp
real :: gp
integer, dimension (4) :: inear_glob
!
integer :: ix0, iy0, iz0, ix1, iy1, iz1, ix2
integer :: ix0_proc, iy0_proc, iz0_proc, proc, ind_proc
real :: dx10_1, dx21_1, dx20_1, dy10_1, dy21_1, dy20_1!, dz_1
real :: dxx0, dxx1, dxx2, dyy0, dyy1, dyy2!, dzz0, dzz1
!real :: g000,g100,g010,g110,g200,g210,g001,g101,g011,g111,g201,g211
real, dimension(3,3,2) :: gN
!real :: f00, f01, f10, f11, h0, h1
real, dimension(3,2) :: fN
intent(in) :: ivar, xxp, inear_glob
intent(out) :: gp
!
ix0=inear_glob(1); iy0=inear_glob(2); iz0=inear_glob(3); proc=inear_glob(4)
ind_proc = ip_proc_pointer(proc+1)
if (ind_proc<1) then
print*, 'ERROR: Pointing to f_array that does not exist'
print*, 'This may be due to too many processors in parallel'
endif
!
! Check if the grid point interval is really correct.
!
ix1=ix0+1
iy1=iy0+1
iz1=iz0+1
if ((xglobal_ogrid(ix0)<=xxp(1) .and. xglobal_ogrid(ix1)>=xxp(1) .or. nxgrid_ogrid==1) .and. &
(yglobal_ogrid(iy0)<=xxp(2) .and. yglobal_ogrid(iy1)>=xxp(2) .or. nygrid_ogrid==1) .and. &
(zglobal_ogrid(iz0)<=xxp(3) .and. zglobal_ogrid(iz1)>=xxp(3) .or. nzgrid_ogrid==1)) then
! Everything okay
else
print*, 'interpolate_quad_ogrid: Global interpolation point does not ' // &
'lie within the calculated grid point interval.'
print*, 'iproc = ', iproc
print*, 'ix0, iy0, iz0 = ', ix0, iy0, iz0
print*, 'xp, xp0, xp1 = ', xxp(1), xglobal_ogrid(ix0), xglobal_ogrid(ix0+1)
print*, 'yp, yp0, yp1 = ', xxp(2), yglobal_ogrid(iy0), yglobal_ogrid(iy0+1)
print*, 'zp, zp0, zp1 = ', xxp(3), zglobal_ogrid(iz0), zglobal_ogrid(iz0+1)
call fatal_error('interpolate_quad_ogrid','point outside of interval for particle interpolation')
return
endif
!
! Redefine closes grid point in radial direciton, if necessary
!
dxx0=xxp(1)-xglobal_ogrid(ix0)
dxx1=xxp(1)-xglobal_ogrid(ix1)
if ((abs(dxx0)<abs(dxx1)).and.(xglobal_ogrid(ix0)>xyz0_ogrid(1))) then
ix1=ix0
ix0=ix0-1
dxx0=xxp(1)-xglobal_ogrid(ix0)
dxx1=xxp(1)-xglobal_ogrid(ix1)
endif
ix2=ix0+2
dxx2=xxp(1)-xglobal_ogrid(ix2)
dx10_1=1./(xglobal_ogrid(ix1)-xglobal_ogrid(ix0))
dx21_1=1./(xglobal_ogrid(ix2)-xglobal_ogrid(ix1))
dx20_1=1./(xglobal_ogrid(ix2)-xglobal_ogrid(ix0))
!
dyy0=xxp(2)-yglobal_ogrid(iy0)
dyy1=xxp(2)-yglobal_ogrid(iy1)
if ((abs(dyy0)<abs(dyy1))) then
iy1=iy0
iy0=iy0-1
dyy0=xxp(2)-yglobal_ogrid(iy0)
dyy1=xxp(2)-yglobal_ogrid(iy1)
endif
iy2=iy0+2
dyy2=xxp(2)-yglobal_ogrid(iy2)
dy10_1=1./(yglobal_ogrid(iy1)-yglobal_ogrid(iy0))
dy21_1=1./(yglobal_ogrid(iy2)-yglobal_ogrid(iy1))
dy20_1=1./(yglobal_ogrid(iy2)-yglobal_ogrid(iy0))
!
ix0_proc=ix0-nx_ogrid*ip_proc(ind_proc,1)
iy0_proc=iy0-ny_ogrid*ip_proc(ind_proc,2)
iz0_proc=iz0-nz_ogrid*ip_proc(ind_proc,3)
gN(1,1,1)=f_ogrid_procs(ind_proc,ix0_proc ,iy0_proc ,iz0_proc ,ivar)
gN(2,1,1)=f_ogrid_procs(ind_proc,ix0_proc+1,iy0_proc ,iz0_proc ,ivar)
gN(3,1,1)=f_ogrid_procs(ind_proc,ix0_proc+2,iy0_proc ,iz0_proc ,ivar)
gN(1,2,1)=f_ogrid_procs(ind_proc,ix0_proc ,iy0_proc+1,iz0_proc ,ivar)
gN(2,2,1)=f_ogrid_procs(ind_proc,ix0_proc+1,iy0_proc+1,iz0_proc ,ivar)
gN(3,2,1)=f_ogrid_procs(ind_proc,ix0_proc+2,iy0_proc+1,iz0_proc ,ivar)
gN(1,3,1)=f_ogrid_procs(ind_proc,ix0_proc ,iy0_proc+2,iz0_proc ,ivar)
gN(2,3,1)=f_ogrid_procs(ind_proc,ix0_proc+1,iy0_proc+2,iz0_proc ,ivar)
gN(3,3,1)=f_ogrid_procs(ind_proc,ix0_proc+2,iy0_proc+2,iz0_proc ,ivar)
!
! Simplify if only a 2D-run
!
if (nzgrid_ogrid==1) then
fN(1:3,1)=gN(1,:,1)*dxx1*dxx2*dx10_1*dx20_1+gN(2,:,1)*dxx0*dxx2*dx10_1*(-dx21_1)+gN(3,:,1)*dxx0*dxx1*dx20_1*dx21_1
gp=fN(1,1)*dyy1*dyy2*dy10_1*dy20_1+fN(2,1)*dyy0*dyy2*dy10_1*(-dy21_1)+fN(3,1)*dyy0*dyy1*dy20_1*dy21_1
!f10=g(1,2,1)*dxx1*dxx2*dx10_1*dx20_1+g(2,2,1)*dxx0*dxx2*dx10_1*(-dx21_1)+g(3,2,1)*dxx0*dxx1*dx20_1*dx21_1
!f20=g(1,3,1)*dxx1*dxx2*dx10_1*dx20_1+g(2,3,1)*dxx0*dxx2*dx10_1*(-dx21_1)+g(3,3,1)*dxx0*dxx1*dx20_1*dx21_1
else
print*, 'ERROR: 3D not implementet'
!dzz0=xxp(3)-zglobal_ogrid(iz0)
!dzz1=xxp(3)-zglobal_ogrid(iz1)
!dz_1=1./(zglobal_ogrid(iz1)-zglobal_ogrid(iz0))
!
!g001=f_ogrid_procs(ind_proc,ix0_proc ,iy0_proc ,iz0_proc+1,ivar)
!g101=f_ogrid_procs(ind_proc,ix0_proc+1,iy0_proc ,iz0_proc+1,ivar)
!g011=f_ogrid_procs(ind_proc,ix0_proc ,iy0_proc+1,iz0_proc+1,ivar)
!g111=f_ogrid_procs(ind_proc,ix0_proc+1,iy0_proc+1,iz0_proc+1,ivar)
!g201=f_ogrid_procs(ind_proc,ix0_proc+2,iy0_proc ,iz0_proc+1,ivar)
!g211=f_ogrid_procs(ind_proc,ix0_proc+2,iy0_proc+1,iz0_proc+1,ivar)
!
!f00=g000*dxx1*dxx2*dx10_1*dx20_1+g100*dxx0*dxx2*dx10_1*(-dx21_1)+g200*dxx0*dxx1*dx20_1*dx21_1
!f10=g010*dxx1*dxx2*dx10_1*dx20_1+g110*dxx0*dxx2*dx10_1*(-dx21_1)+g210*dxx0*dxx1*dx20_1*dx21_1
!f01=g001*dxx1*dxx2*dx10_1*dx20_1+g101*dxx0*dxx2*dx10_1*(-dx21_1)+g201*dxx0*dxx1*dx20_1*dx21_1
!f11=g011*dxx1*dxx2*dx10_1*dx20_1+g111*dxx0*dxx2*dx10_1*(-dx21_1)+g211*dxx0*dxx1*dx20_1*dx21_1
!h0=f00*dyy1*(-dy_1)+f10*dyy0*dy_1
!h1=f01*dyy1*(-dy_1)+f11*dyy0*dy_1
!gp=h0*dzz1*(-dz_1)+h1*dzz0*dz_1
endif
!
! Do a reality check on the interpolation scheme.
!
if (lcheck_interpolation) then
if ((gp>maxval(gN(:,:,1))) .or. &
(gp<minval(gN(:,:,1))) .or. &
(gp/=gp)) then
if (gp>maxval(gN(:,:,1))) then
print*, 'interpolate_quad_ogrid: interpolated value is LARGER than'
print*, 'interpolate_quad_ogrid: a values at the corner points!'
elseif (gp<minval(gN(:,:,1))) then
print*, 'interpolate_quad_ogrid: interpolated value is smaller than'
print*, 'interpolate_quad_ogrid: a values at the corner points!'
elseif (gp/=gp) then
print*, 'interpolate_quad_ogrid: interpolated value is NaN'
endif
print*, 'iproc = ', iproc
!print*, 'ipar = ', ipar
print*, 'interpolate_quad_ogrid: xxp=', xxp
print*, 'interpolate_quad_ogrid: x0, y0, z0=', &
xglobal_ogrid(ix0), yglobal_ogrid(iy0), zglobal_ogrid(iz0)
print*, 'interpolate_quad_ogrid: x1, y1=', &
xglobal_ogrid(ix0+1), yglobal_ogrid(iy0+1)
print*, 'interpolate_quad_ogrid: x2, y2=', &
xglobal_ogrid(ix0+2), yglobal_ogrid(iy0+2)
print*, 'interpolate_quad_ogrid: ivar, gp=', ivar, gp
print*, 'g(1,:,1)',gN(1,:,1)
print*, 'g(2,:,1)',gN(2,:,1)
print*, 'g(3,:,1)',gN(3,:,1)
print*, '------------------'
call fatal_error('interpolate_quad_ogrid','particle velocity interpolation error')
endif
endif
!
endsubroutine interpolate_quad_ogrid
!***********************************************************************
!***********************************************************************
subroutine interpolate_quadratic_spline(farr,ivar1,ivar2,xxp,gp,inear)
!
! Quadratic spline interpolation of the function g to the point xxp=(xp,yp,zp).
!
! 10-jun-06/anders: coded
!
real, dimension (:,:,:,:) :: farr
integer, intent(in) :: ivar1, ivar2
real, dimension (3) :: xxp
real, dimension (ivar2-ivar1+1) :: gp
integer, dimension (3), intent(in) :: inear
!
!TODO
real, dimension(inear(1)-1:inear(1)+1,inear(2)-1:inear(2)+1,inear(3)-1:inear(3)+1,ivar2-ivar1+1) :: f
real :: fac_x_m1, fac_x_00, fac_x_p1
real :: fac_y_m1, fac_y_00, fac_y_p1
real :: fac_z_m1, fac_z_00, fac_z_p1
real :: dxp0, dyp0, dzp0
integer :: ix0, iy0, iz0
!
intent(in) :: farr, xxp
intent(out) :: gp
!TODO
integer :: i
f(:,:,:,:)=farr(:,:,:,:)
!
! Redefine the interpolation point in coordinates relative to nearest grid
! point and normalize with the cell size.
!
ix0=inear(1); iy0=inear(2); iz0=inear(3)
dxp0=(xxp(1)-xglobal(ix0))*dx1grid(ix0-nghost)
dyp0=(xxp(2)-yglobal(iy0))*dy1grid(iy0-nghost)
dzp0=(xxp(3)-zglobal(iz0))*dz1grid(iz0-nghost)
!
! Interpolation formulae.
!
if (dimensionality==0) then
gp=f(ix0,iy0,iz0,ivar1:ivar2)
elseif (dimensionality==1) then
if (nxgrid/=1) then
gp = 0.5*(0.5-dxp0)**2*f(ix0-1,iy0,iz0,ivar1:ivar2) + &
(0.75-dxp0**2)*f(ix0 ,iy0,iz0,ivar1:ivar2) + &
0.5*(0.5+dxp0)**2*f(ix0+1,iy0,iz0,ivar1:ivar2)
endif
if (nygrid/=1) then
gp = 0.5*(0.5-dyp0)**2*f(ix0,iy0-1,iz0,ivar1:ivar2) + &
(0.75-dyp0**2)*f(ix0,iy0 ,iz0,ivar1:ivar2) + &
0.5*(0.5+dyp0)**2*f(ix0,iy0+1,iz0,ivar1:ivar2)
endif
if (nzgrid/=1) then
gp = 0.5*(0.5-dzp0)**2*f(ix0,iy0,iz0-1,ivar1:ivar2) + &
(0.75-dzp0**2)*f(ix0,iy0,iz0 ,ivar1:ivar2) + &
0.5*(0.5+dzp0)**2*f(ix0,iy0,iz0+1,ivar1:ivar2)
endif
elseif (dimensionality==2) then
if (nxgrid==1) then
fac_y_m1 = 0.5*(0.5-dyp0)**2
fac_y_00 = 0.75-dyp0**2
fac_y_p1 = 0.5*(0.5+dyp0)**2
fac_z_m1 = 0.5*(0.5-dzp0)**2
fac_z_00 = 0.75-dzp0**2
fac_z_p1 = 0.5*(0.5+dzp0)**2
!
gp= fac_y_00*fac_z_00*f(ix0,iy0,iz0,ivar1:ivar2) + &
fac_y_00*( f(ix0,iy0 ,iz0+1,ivar1:ivar2)*fac_z_p1 + &
f(ix0,iy0 ,iz0-1,ivar1:ivar2)*fac_z_m1 ) + &
fac_z_00*( f(ix0,iy0+1,iz0 ,ivar1:ivar2)*fac_y_p1 + &
f(ix0,iy0-1,iz0 ,ivar1:ivar2)*fac_y_m1 ) + &
fac_y_p1*( f(ix0,iy0+1,iz0+1,ivar1:ivar2)*fac_z_p1 + &
f(ix0,iy0+1,iz0-1,ivar1:ivar2)*fac_z_m1 ) + &
fac_y_m1*( f(ix0,iy0-1,iz0+1,ivar1:ivar2)*fac_z_p1 + &
f(ix0,iy0-1,iz0-1,ivar1:ivar2)*fac_z_m1 )
elseif (nygrid==1) then
fac_x_m1 = 0.5*(0.5-dxp0)**2
fac_x_00 = 0.75-dxp0**2
fac_x_p1 = 0.5*(0.5+dxp0)**2
fac_z_m1 = 0.5*(0.5-dzp0)**2
fac_z_00 = 0.75-dzp0**2
fac_z_p1 = 0.5*(0.5+dzp0)**2
!
gp= fac_x_00*fac_z_00*f(ix0,iy0,iz0,ivar1:ivar2) + &
fac_x_00*( f(ix0 ,iy0,iz0+1,ivar1:ivar2)*fac_z_p1 + &
f(ix0 ,iy0,iz0-1,ivar1:ivar2)*fac_z_m1 ) + &
fac_z_00*( f(ix0+1,iy0,iz0 ,ivar1:ivar2)*fac_x_p1 + &
f(ix0-1,iy0,iz0 ,ivar1:ivar2)*fac_x_m1 ) + &
fac_x_p1*( f(ix0+1,iy0,iz0+1,ivar1:ivar2)*fac_z_p1 + &
f(ix0+1,iy0,iz0-1,ivar1:ivar2)*fac_z_m1 ) + &
fac_x_m1*( f(ix0-1,iy0,iz0+1,ivar1:ivar2)*fac_z_p1 + &
f(ix0-1,iy0,iz0-1,ivar1:ivar2)*fac_z_m1 )
elseif (nzgrid==1) then
fac_x_m1 = 0.5*(0.5-dxp0)**2
fac_x_00 = 0.75-dxp0**2
fac_x_p1 = 0.5*(0.5+dxp0)**2
fac_y_m1 = 0.5*(0.5-dyp0)**2
fac_y_00 = 0.75-dyp0**2
fac_y_p1 = 0.5*(0.5+dyp0)**2
!
gp= fac_x_00*fac_y_00*f(ix0,iy0,iz0,ivar1:ivar2) + &
fac_x_00*( f(ix0 ,iy0+1,iz0,ivar1:ivar2)*fac_y_p1 + &
f(ix0 ,iy0-1,iz0,ivar1:ivar2)*fac_y_m1 ) + &
fac_y_00*( f(ix0+1,iy0 ,iz0,ivar1:ivar2)*fac_x_p1 + &
f(ix0-1,iy0 ,iz0,ivar1:ivar2)*fac_x_m1 ) + &
fac_x_p1*( f(ix0+1,iy0+1,iz0,ivar1:ivar2)*fac_y_p1 + &
f(ix0+1,iy0-1,iz0,ivar1:ivar2)*fac_y_m1 ) + &
fac_x_m1*( f(ix0-1,iy0+1,iz0,ivar1:ivar2)*fac_y_p1 + &
f(ix0-1,iy0-1,iz0,ivar1:ivar2)*fac_y_m1 )
endif
elseif (dimensionality==3) then
fac_x_m1 = 0.5*(0.5-dxp0)**2
fac_x_00 = 0.75-dxp0**2
fac_x_p1 = 0.5*(0.5+dxp0)**2
fac_y_m1 = 0.5*(0.5-dyp0)**2
fac_y_00 = 0.75-dyp0**2
fac_y_p1 = 0.5*(0.5+dyp0)**2
fac_z_m1 = 0.5*(0.5-dzp0)**2
fac_z_00 = 0.75-dzp0**2
fac_z_p1 = 0.5*(0.5+dzp0)**2
!
gp= fac_x_00*fac_y_00*fac_z_00*f(ix0,iy0,iz0,ivar1:ivar2) + &
fac_x_00*fac_y_00*( f(ix0 ,iy0 ,iz0+1,ivar1:ivar2)*fac_z_p1 + &
f(ix0 ,iy0 ,iz0-1,ivar1:ivar2)*fac_z_m1 ) + &
fac_x_00*fac_z_00*( f(ix0 ,iy0+1,iz0 ,ivar1:ivar2)*fac_y_p1 + &
f(ix0 ,iy0-1,iz0 ,ivar1:ivar2)*fac_y_m1 ) + &
fac_y_00*fac_z_00*( f(ix0+1,iy0 ,iz0 ,ivar1:ivar2)*fac_x_p1 + &
f(ix0-1,iy0 ,iz0 ,ivar1:ivar2)*fac_x_m1 ) + &
fac_x_p1*fac_y_p1*( f(ix0+1,iy0+1,iz0+1,ivar1:ivar2)*fac_z_p1 + &
f(ix0+1,iy0+1,iz0-1,ivar1:ivar2)*fac_z_m1 ) + &
fac_x_p1*fac_y_m1*( f(ix0+1,iy0-1,iz0+1,ivar1:ivar2)*fac_z_p1 + &
f(ix0+1,iy0-1,iz0-1,ivar1:ivar2)*fac_z_m1 ) + &
fac_x_m1*fac_y_p1*( f(ix0-1,iy0+1,iz0+1,ivar1:ivar2)*fac_z_p1 + &
f(ix0-1,iy0+1,iz0-1,ivar1:ivar2)*fac_z_m1 ) + &
fac_x_m1*fac_y_m1*( f(ix0-1,iy0-1,iz0+1,ivar1:ivar2)*fac_z_p1 + &
f(ix0-1,iy0-1,iz0-1,ivar1:ivar2)*fac_z_m1 ) + &
fac_x_00*fac_y_p1*( f(ix0 ,iy0+1,iz0+1,ivar1:ivar2)*fac_z_p1 + &
f(ix0 ,iy0+1,iz0-1,ivar1:ivar2)*fac_z_m1 ) + &
fac_x_00*fac_y_m1*( f(ix0 ,iy0-1,iz0+1,ivar1:ivar2)*fac_z_p1 + &
f(ix0 ,iy0-1,iz0-1,ivar1:ivar2)*fac_z_m1 ) + &
fac_y_00*fac_z_p1*( f(ix0+1,iy0 ,iz0+1,ivar1:ivar2)*fac_x_p1 + &
f(ix0-1,iy0 ,iz0+1,ivar1:ivar2)*fac_x_m1 ) + &
fac_y_00*fac_z_m1*( f(ix0+1,iy0 ,iz0-1,ivar1:ivar2)*fac_x_p1 + &
f(ix0-1,iy0 ,iz0-1,ivar1:ivar2)*fac_x_m1 ) + &
fac_z_00*fac_x_p1*( f(ix0+1,iy0+1,iz0 ,ivar1:ivar2)*fac_y_p1 + &
f(ix0+1,iy0-1,iz0 ,ivar1:ivar2)*fac_y_m1 ) + &
fac_z_00*fac_x_m1*( f(ix0-1,iy0+1,iz0 ,ivar1:ivar2)*fac_y_p1 + &
f(ix0-1,iy0-1,iz0 ,ivar1:ivar2)*fac_y_m1 )
endif
!
if (lcheck_interpolation) then
do i=1,ivar2-ivar1+1
if ((gp(i)>maxval(f(:,:,4,i))) .or. &
(gp(i)<minval(f(:,:,4,i))) .or. &
(gp(i)/=gp(i))) then
if (gp(i)>maxval(f(:,:,4,i))) then
print*, 'interpolate_quadratic_spline: interpolated value is LARGER than'
print*, 'interpolate_quadratic_spline: values at the corner points!'
elseif (gp(i)<minval(f(:,:,4,i))) then
print*, 'interpolate_quadratic_spline: interpolated value is SMALLER than'
print*, 'interpolate_quadratic_spline: values at the corner points!'
elseif (gp(i)/=gp(i)) then
print*, 'interpolate_quadratic_spline: interpolated value is NaN'
endif
print*, 'iproc = ', iproc
print*, 'dimensionality = ',dimensionality
print*, 'interpolate_quadratic_spline: xxp=', xxp
print*, 'interpolate_quadratic_spline: i, gp(i)=', i, gp(i)
print*, 'Nearest neighbours: xglobal - ', xglobal(ix0-1:ix0+1)
print*, 'Nearest neighbours: yglobal - ', yglobal(iy0-1:iy0+1)
!print*, 'interpolate_quadratic_spline: x0, y0, z0=', &
!xglobal_ogrid(ix0), yglobal_ogrid(iy0), zglobal_ogrid(iz0)
print*, 'interpolate_quadratic_spline: f(ix0-1,iy0-1:iy0+1,4,i)=', f(ix0-1,iy0-1:iy0+1,4,i)
print*, 'interpolate_quadratic_spline: f(ix0 ,iy0-1:iy0+1,4,i)=', f(ix0 ,iy0-1:iy0+1,4,i)
print*, 'interpolate_quadratic_spline: f(ix0+1,iy0-1:iy0+1,4,i)=', f(ix0+1,iy0-1:iy0+1,4,i)
print*, '------------------'
! Commented out the line below for the moment since it is too sensitive when lchemistry
! call fatal_error('interpolate_quadratic_spline','interpolation error, quadratic spline')
endif
enddo
endif
endsubroutine interpolate_quadratic_spline
!***********************************************************************
subroutine interpolate_quadratic_sp_og(farr,ivar1,ivar2,xxp,gp,inear)
!
! Quadratic spline interpolation of the function g to the point xxp=(xp,yp,zp).
!
! 10-jun-06/anders: coded
!
real, dimension (:,:,:,:) :: farr
integer, intent(in) :: ivar1, ivar2
real, dimension (3) :: xxp
real, dimension (ivar2-ivar1+1) :: gp
integer, dimension (3), intent(in) :: inear
!TODO
real, dimension(inear(1)-1:inear(1)+1,inear(2)-1:inear(2)+1,inear(3)-1:inear(3)+1,ivar2-ivar1+1) :: f
real :: fac_x_m1, fac_x_00, fac_x_p1
real :: fac_y_m1, fac_y_00, fac_y_p1
real :: fac_z_m1, fac_z_00, fac_z_p1
real :: dxp0, dyp0, dzp0
integer :: ix0, iy0, iz0
!
intent(in) :: farr, xxp
intent(out) :: gp
f(:,:,:,:)=farr(:,:,:,:)
!
! Redefine the interpolation point in coordinates relative to nearest grid
! point and normalize with the cell size.
!
ix0=inear(1); iy0=inear(2); iz0=inear(3)
dxp0=(xxp(1)-xglobal_ogrid(ix0))*dx1global_ogrid(ix0)
dyp0=(xxp(2)-yglobal_ogrid(iy0))*dy1global_ogrid(iy0)
dzp0=(xxp(3)-zglobal_ogrid(iz0))*dz1global_ogrid(iz0)
!
! Interpolation formulae.
!
if (dimensionality==0) then
gp=f(ix0,iy0,iz0,ivar1:ivar2)
elseif (dimensionality==1) then
if (nxgrid_ogrid/=1) then
gp = 0.5*(0.5-dxp0)**2*f(ix0-1,iy0,iz0,ivar1:ivar2) + &
(0.75-dxp0**2)*f(ix0 ,iy0,iz0,ivar1:ivar2) + &
0.5*(0.5+dxp0)**2*f(ix0+1,iy0,iz0,ivar1:ivar2)
endif
if (nygrid_ogrid/=1) then
gp = 0.5*(0.5-dyp0)**2*f(ix0,iy0-1,iz0,ivar1:ivar2) + &
(0.75-dyp0**2)*f(ix0,iy0 ,iz0,ivar1:ivar2) + &
0.5*(0.5+dyp0)**2*f(ix0,iy0+1,iz0,ivar1:ivar2)
endif
if (nzgrid_ogrid/=1) then
gp = 0.5*(0.5-dzp0)**2*f(ix0,iy0,iz0-1,ivar1:ivar2) + &
(0.75-dzp0**2)*f(ix0,iy0,iz0 ,ivar1:ivar2) + &
0.5*(0.5+dzp0)**2*f(ix0,iy0,iz0+1,ivar1:ivar2)
endif
elseif (dimensionality==2) then
if (nxgrid_ogrid==1) then
fac_y_m1 = 0.5*(0.5-dyp0)**2
fac_y_00 = 0.75-dyp0**2
fac_y_p1 = 0.5*(0.5+dyp0)**2
fac_z_m1 = 0.5*(0.5-dzp0)**2
fac_z_00 = 0.75-dzp0**2
fac_z_p1 = 0.5*(0.5+dzp0)**2
!
gp= fac_y_00*fac_z_00*f(ix0,iy0,iz0,ivar1:ivar2) + &
fac_y_00*( f(ix0,iy0 ,iz0+1,ivar1:ivar2)*fac_z_p1 + &
f(ix0,iy0 ,iz0-1,ivar1:ivar2)*fac_z_m1 ) + &
fac_z_00*( f(ix0,iy0+1,iz0 ,ivar1:ivar2)*fac_y_p1 + &
f(ix0,iy0-1,iz0 ,ivar1:ivar2)*fac_y_m1 ) + &
fac_y_p1*( f(ix0,iy0+1,iz0+1,ivar1:ivar2)*fac_z_p1 + &
f(ix0,iy0+1,iz0-1,ivar1:ivar2)*fac_z_m1 ) + &
fac_y_m1*( f(ix0,iy0-1,iz0+1,ivar1:ivar2)*fac_z_p1 + &
f(ix0,iy0-1,iz0-1,ivar1:ivar2)*fac_z_m1 )
elseif (nygrid_ogrid==1) then
fac_x_m1 = 0.5*(0.5-dxp0)**2
fac_x_00 = 0.75-dxp0**2
fac_x_p1 = 0.5*(0.5+dxp0)**2
fac_z_m1 = 0.5*(0.5-dzp0)**2
fac_z_00 = 0.75-dzp0**2
fac_z_p1 = 0.5*(0.5+dzp0)**2
!
gp= fac_x_00*fac_z_00*f(ix0,iy0,iz0,ivar1:ivar2) + &
fac_x_00*( f(ix0 ,iy0,iz0+1,ivar1:ivar2)*fac_z_p1 + &
f(ix0 ,iy0,iz0-1,ivar1:ivar2)*fac_z_m1 ) + &
fac_z_00*( f(ix0+1,iy0,iz0 ,ivar1:ivar2)*fac_x_p1 + &
f(ix0-1,iy0,iz0 ,ivar1:ivar2)*fac_x_m1 ) + &
fac_x_p1*( f(ix0+1,iy0,iz0+1,ivar1:ivar2)*fac_z_p1 + &
f(ix0+1,iy0,iz0-1,ivar1:ivar2)*fac_z_m1 ) + &
fac_x_m1*( f(ix0-1,iy0,iz0+1,ivar1:ivar2)*fac_z_p1 + &
f(ix0-1,iy0,iz0-1,ivar1:ivar2)*fac_z_m1 )
elseif (nzgrid_ogrid==1) then
fac_x_m1 = 0.5*(0.5-dxp0)**2
fac_x_00 = 0.75-dxp0**2
fac_x_p1 = 0.5*(0.5+dxp0)**2
fac_y_m1 = 0.5*(0.5-dyp0)**2
fac_y_00 = 0.75-dyp0**2
fac_y_p1 = 0.5*(0.5+dyp0)**2
!
gp= fac_x_00*fac_y_00*f(ix0,iy0,iz0,ivar1:ivar2) + &
fac_x_00*( f(ix0 ,iy0+1,iz0,ivar1:ivar2)*fac_y_p1 + &
f(ix0 ,iy0-1,iz0,ivar1:ivar2)*fac_y_m1 ) + &
fac_y_00*( f(ix0+1,iy0 ,iz0,ivar1:ivar2)*fac_x_p1 + &
f(ix0-1,iy0 ,iz0,ivar1:ivar2)*fac_x_m1 ) + &
fac_x_p1*( f(ix0+1,iy0+1,iz0,ivar1:ivar2)*fac_y_p1 + &
f(ix0+1,iy0-1,iz0,ivar1:ivar2)*fac_y_m1 ) + &
fac_x_m1*( f(ix0-1,iy0+1,iz0,ivar1:ivar2)*fac_y_p1 + &
f(ix0-1,iy0-1,iz0,ivar1:ivar2)*fac_y_m1 )
endif
elseif (dimensionality==3) then
fac_x_m1 = 0.5*(0.5-dxp0)**2
fac_x_00 = 0.75-dxp0**2
fac_x_p1 = 0.5*(0.5+dxp0)**2
fac_y_m1 = 0.5*(0.5-dyp0)**2
fac_y_00 = 0.75-dyp0**2
fac_y_p1 = 0.5*(0.5+dyp0)**2
fac_z_m1 = 0.5*(0.5-dzp0)**2
fac_z_00 = 0.75-dzp0**2
fac_z_p1 = 0.5*(0.5+dzp0)**2
!
gp= fac_x_00*fac_y_00*fac_z_00*f(ix0,iy0,iz0,ivar1:ivar2) + &
fac_x_00*fac_y_00*( f(ix0 ,iy0 ,iz0+1,ivar1:ivar2)*fac_z_p1 + &
f(ix0 ,iy0 ,iz0-1,ivar1:ivar2)*fac_z_m1 ) + &
fac_x_00*fac_z_00*( f(ix0 ,iy0+1,iz0 ,ivar1:ivar2)*fac_y_p1 + &
f(ix0 ,iy0-1,iz0 ,ivar1:ivar2)*fac_y_m1 ) + &
fac_y_00*fac_z_00*( f(ix0+1,iy0 ,iz0 ,ivar1:ivar2)*fac_x_p1 + &
f(ix0-1,iy0 ,iz0 ,ivar1:ivar2)*fac_x_m1 ) + &
fac_x_p1*fac_y_p1*( f(ix0+1,iy0+1,iz0+1,ivar1:ivar2)*fac_z_p1 + &
f(ix0+1,iy0+1,iz0-1,ivar1:ivar2)*fac_z_m1 ) + &
fac_x_p1*fac_y_m1*( f(ix0+1,iy0-1,iz0+1,ivar1:ivar2)*fac_z_p1 + &
f(ix0+1,iy0-1,iz0-1,ivar1:ivar2)*fac_z_m1 ) + &
fac_x_m1*fac_y_p1*( f(ix0-1,iy0+1,iz0+1,ivar1:ivar2)*fac_z_p1 + &
f(ix0-1,iy0+1,iz0-1,ivar1:ivar2)*fac_z_m1 ) + &
fac_x_m1*fac_y_m1*( f(ix0-1,iy0-1,iz0+1,ivar1:ivar2)*fac_z_p1 + &
f(ix0-1,iy0-1,iz0-1,ivar1:ivar2)*fac_z_m1 ) + &
fac_x_00*fac_y_p1*( f(ix0 ,iy0+1,iz0+1,ivar1:ivar2)*fac_z_p1 + &
f(ix0 ,iy0+1,iz0-1,ivar1:ivar2)*fac_z_m1 ) + &
fac_x_00*fac_y_m1*( f(ix0 ,iy0-1,iz0+1,ivar1:ivar2)*fac_z_p1 + &
f(ix0 ,iy0-1,iz0-1,ivar1:ivar2)*fac_z_m1 ) + &
fac_y_00*fac_z_p1*( f(ix0+1,iy0 ,iz0+1,ivar1:ivar2)*fac_x_p1 + &
f(ix0-1,iy0 ,iz0+1,ivar1:ivar2)*fac_x_m1 ) + &
fac_y_00*fac_z_m1*( f(ix0+1,iy0 ,iz0-1,ivar1:ivar2)*fac_x_p1 + &
f(ix0-1,iy0 ,iz0-1,ivar1:ivar2)*fac_x_m1 ) + &
fac_z_00*fac_x_p1*( f(ix0+1,iy0+1,iz0 ,ivar1:ivar2)*fac_y_p1 + &
f(ix0+1,iy0-1,iz0 ,ivar1:ivar2)*fac_y_m1 ) + &
fac_z_00*fac_x_m1*( f(ix0-1,iy0+1,iz0 ,ivar1:ivar2)*fac_y_p1 + &
f(ix0-1,iy0-1,iz0 ,ivar1:ivar2)*fac_y_m1 )
endif
!
endsubroutine interpolate_quadratic_sp_og
!***********************************************************************
subroutine poly_interp_cart(ivar1,ivar2,xyz_ip,gp,id,f_cartesian,order)
use General, only: polynomial_interpolation
real, dimension(mx,my,mz,mfarray), intent(in) :: f_cartesian
real, dimension(3), intent(in) :: xyz_ip
integer, intent(in) :: id
integer, intent(in) :: ivar1,ivar2
integer, intent(in) :: order
real, dimension(ivar2-ivar1+1), intent(out) :: gp
real, dimension(order) :: xa1,xa2,ya
real, dimension(order,order-1) :: up
real, dimension(ivar2-ivar1+1,order-1) :: gpp
integer :: ix0,iy0,ivar,j,jj,ii1,ii2
ix0=cartesian_to_curvilinear(id)%ind_local_neighbour(1)
iy0=cartesian_to_curvilinear(id)%ind_local_neighbour(2)
do j=1,order
jj=-floor(order*0.5)+j-1
xa1(j)=xglobal(ix0+jj)
xa2(j)=yglobal(iy0+jj)
enddo
ii1=-floor(order*0.5)+1-1
ii2=-floor(order*0.5)+order-1
!print*, 'xyz[:,',id,0,']=[',xa1(1),',',xa1(2),',',xa1(3),',',xa1(4),',',xa1(5),']'
!print*, 'xyz[:,',id,1,']=[',xa2(1),',',xa2(2),',',xa2(3),',',xa2(4),',',xa2(5),']'
!!print*, 'cartesian:xa2',xa2
!print*, 'rthp[',id,',:]=[',xyz_ip(1),',',xyz_ip(2),']'
do ivar=ivar1,ivar2
do j=1,order
jj=-floor(order*0.5)+j-1
ya=f_cartesian(ix0+ii1:ix0+ii2,iy0+jj,4,ivar)
call polynomial_interpolation(xa1, ya, xyz_ip(1), up(j,:))
enddo
ya=up(:,order-1)
call polynomial_interpolation(xa2, ya, xyz_ip(2), gpp(ivar,:))
enddo
gp=gpp(:,order-1)
endsubroutine poly_interp_cart
!***********************************************************************
subroutine poly_interp_curv(ivar1,ivar2,xyz_ip,gp,id,order)
use General, only: polynomial_interpolation
real, dimension(3), intent(in) :: xyz_ip
integer, intent(in) :: id
integer, intent(in) :: ivar1,ivar2
integer, intent(in) :: order
real, dimension(ivar2-ivar1+1), intent(out) :: gp
real, dimension(order) :: xa1,xa2,ya
real, dimension(order,order-1) :: up
real, dimension(ivar2-ivar1+1,order-1) :: gpp
integer :: ix0,iy0,ivar,j,jj,ii1,ii2
ix0=curvilinear_to_cartesian(id)%ind_local_neighbour(1)
iy0=curvilinear_to_cartesian(id)%ind_local_neighbour(2)
do j=1,order
jj=-floor(order*0.5)+j-1
xa1(j)=xglobal_ogrid(ix0+jj)
xa2(j)=yglobal_ogrid(iy0+jj)
enddo
ii1=-floor(order*0.5)+1-1
ii2=-floor(order*0.5)+order-1
do ivar=ivar1,ivar2
do j=1,order
jj=-floor(order*0.5)+j-1
ya=f_ogrid(ix0+ii1:ix0+ii2,iy0+jj,4,ivar)
call polynomial_interpolation(xa1, ya, xyz_ip(1), up(j,:))
enddo
ya=up(:,order-1)
call polynomial_interpolation(xa2, ya, xyz_ip(2), gpp(ivar,:))
enddo
gp=gpp(:,order-1)
endsubroutine poly_interp_curv
!***********************************************************************
real function radius_ogrid(xp,yp)
!
! Transform cartesian coordinates xxp to polar coordinates on the cylindrical ogrid
! Only return r-direction.
! Input coordinates xxp can be two- or three-dimensional
!
! 02-aug-17/Jorgen: Coded
!
real, intent(in) :: xp, yp
!
radius_ogrid = sqrt((xp-xorigo_ogrid(1))**2 + (yp-xorigo_ogrid(2))**2)
!
endfunction radius_ogrid
!***********************************************************************
subroutine get_polar_coords_2D(xxp,rad,theta)
!
! Transform cartesian coordinates xxp to polar coordinates on the cylindrical ogrid
! Only return two-dimensional array
! Input coordinates xxp can be two- or three-dimensional
!
! 02-aug-17/Jorgen: Coded
!
real, dimension(:), intent(in) :: xxp
real, intent(out) :: rad, theta
!
real :: xr, yr
!
xr=xxp(1)-xorigo_ogrid(1)
yr=xxp(2)-xorigo_ogrid(2)
rad=sqrt(xr**2+yr**2)
theta=atan2(yr,xr)
!
endsubroutine get_polar_coords_2D
!***********************************************************************
subroutine get_polar_coords_3D(xxp,rthz)
!
! Transform cartesian coordinates xxp to polar coordinates on the cylindrical ogrid
! Input coordinates must be three-dimensional
!
! 02-aug-17/Jorgen: Coded
!
real, dimension(3), intent(in) :: xxp
real, dimension(3), intent(out) :: rthz
!
call get_polar_coords_2D(xxp,rthz(1),rthz(2))
rthz(3) = xxp(3)
!
endsubroutine get_polar_coords_3D
!***********************************************************************
subroutine get_polar_coords_3D_alt(xp,yp,zp,rthz)
!
! Transform cartesian coordinates xxp to polar coordinates on the cylindrical ogrid
! Input coordinates must be three-dimensional
!
! 02-aug-17/Jorgen: Coded
!
real, intent(in) :: xp, yp, zp
real, dimension(3), intent(out) :: rthz
real :: xr,yr
!
xr=xp-xorigo_ogrid(1)
yr=yp-xorigo_ogrid(2)
rthz=(/ sqrt(xr**2+yr**2),atan2(yr,xr),zp /)
!
endsubroutine get_polar_coords_3D_alt
!***********************************************************************
subroutine adjust_inear_cart(inear,xxp)
!
! Adjust inear coordinates to guarantee that they point to the CLOSEST point to xxp,
! not to the bottom left corner of the cell that contains xxp.
! Necessary for interpolation with asymmetric stencils (e.g., quadratic spline)
!
! 07-sep-17/Jorgen: Coded
!
integer, dimension(3),intent(inout) :: inear
real, dimension(3), intent(in) :: xxp
!
if ((xxp(1)-x(inear(1)))>(x(inear(1)+1)-xxp(1))) inear(1) = inear(1)+1
if ((xxp(2)-y(inear(2)))>(y(inear(2)+1)-xxp(2))) inear(2) = inear(2)+1
if (nzgrid_ogrid>1) then
if ((xxp(3)-z(inear(3)))>(z(inear(3)+1)-xxp(3))) inear(3) = inear(3)+1
endif
!
endsubroutine adjust_inear_cart
!***********************************************************************
subroutine adjust_inear_curv(inear,xxp)
!
! Adjust inear coordinates to guarantee that they point to the CLOSEST point to xxp,
! not to the bottom left corner of the cell that contains xxp.
! Necessary for interpolation with asymmetric stencils (e.g., quadratic spline)
!
! 07-sep-17/Jorgen: Coded
!
integer, dimension(3),intent(inout) :: inear
real, dimension(3), intent(in) :: xxp
!
if ((xxp(1)-x_ogrid(inear(1)))>(x_ogrid(inear(1)+1)-xxp(1))) inear(1) = inear(1)+1
if ((xxp(2)-y_ogrid(inear(2)))>(y_ogrid(inear(2)+1)-xxp(2))) inear(2) = inear(2)+1
if (nzgrid_ogrid>1) then
if ((xxp(3)-z_ogrid(inear(3)))>(z_ogrid(inear(3)+1)-xxp(3))) inear(3) = inear(3)+1
endif
!
endsubroutine adjust_inear_curv
!***********************************************************************
subroutine adjust_inear_cart_glob(inear_glob,xxp)
!
! Adjust inear GLOBAL coordinates to guarantee that they point to the CLOSEST point to xxp,
! not to the bottom left corner of the cell that contains xxp.
! Necessary for interpolation with asymmetric stencils (e.g., quadratic spline)
!
! 14-sep-17/Jorgen: Coded
!
integer, dimension(3),intent(inout) :: inear_glob
real, dimension(3), intent(in) :: xxp
!
if ((xxp(1)-xglobal(inear_glob(1)))>(xglobal(inear_glob(1)+1)-xxp(1))) inear_glob(1) = inear_glob(1)+1
if ((xxp(2)-yglobal(inear_glob(2)))>(yglobal(inear_glob(2)+1)-xxp(2))) inear_glob(2) = inear_glob(2)+1
if (nzgrid>1) then
if ((xxp(3)-zglobal(inear_glob(3)))>(zglobal(inear_glob(3)+1)-xxp(3))) inear_glob(3) = inear_glob(3)+1
endif
!
endsubroutine adjust_inear_cart_glob
!***********************************************************************
subroutine adjust_inear_curv_glob(inear_glob,xxp)
!
! Adjust inear GLOBAL coordinates to guarantee that they point to the CLOSEST point to xxp,
! not to the bottom left corner of the cell that contains xxp.
! Necessary for interpolation with asymmetric stencils (e.g., quadratic spline)
!
! 14-sep-17/Jorgen: Coded
!
integer, dimension(3),intent(inout) :: inear_glob
real, dimension(3), intent(in) :: xxp
!
if ((xxp(1)-xglobal_ogrid(inear_glob(1)))>(xglobal_ogrid(inear_glob(1)+1)-xxp(1))) inear_glob(1) = inear_glob(1)+1
if ((xxp(2)-yglobal_ogrid(inear_glob(2)))>(yglobal_ogrid(inear_glob(2)+1)-xxp(2))) inear_glob(2) = inear_glob(2)+1
if (nzgrid_ogrid>1) then
if ((xxp(3)-zglobal_ogrid(inear_glob(3)))>(zglobal_ogrid(inear_glob(3)+1)-xxp(3))) inear_glob(3) = inear_glob(3)+1
endif
!
endsubroutine adjust_inear_curv_glob
!***********************************************************************
subroutine set_interpolation_limits
!
! Set interpolation zone for curvilinear to cartesian grid
! Make sure that no points outside x_ogrid(l2_ogrid) are used
!
use mpicomm, only: mpibcast_real
real :: dx_outer, tmp_rad, min_rad, min_tmp_rad
integer :: ii,jj,i3,j3
if (lroot) then
dx_outer = 1./dx1grid_ogrid(nxgrid_ogrid)
if (interpolation_method==1) then
r_int_outer=r_ogrid-dx_outer*0.01-dx_outer*interp_shift
elseif (interpolation_method==3 .or. interpolation_method==5) then
r_int_outer=r_ogrid-dx_outer*0.51-dx_outer*interp_shift
if ((xgrid_ogrid(nxgrid_ogrid)-r_int_outer)<(r_int_outer-xgrid_ogrid(nxgrid_ogrid-1))) then
print*, 'WARNING: An error occured when setting interpolation zone.'
print*, ' Zone adjusted.'
print*, 'iproc, r_int_outer first, r_int_outer second',&
iproc,r_int_outer,r_ogrid-dx_outer*1.01
r_int_outer=r_ogrid-dx_outer*1.01-dx_outer*interp_shift
endif
if (interpolation_method==5) then
print*, 'WARNING: Polynomal interpolation used, you better know what you are doing!'
endif
elseif (mod(interpolation_method,2)==0) then
r_int_outer=r_ogrid-dx_outer*((interpolation_method/2-0.5)+0.01)
! r_int_outer=min(r_ogrid-dx_outer*((interpolation_method/2-0.5)+0.01),&
! r_ogrid+dx_outer-dxmax*((interpolation_method/2+0.5)+0.01))
r_int_outer=r_int_outer-dx_outer*interp_shift
if ((xgrid_ogrid(nxgrid_ogrid-1)-r_int_outer)<(r_int_outer-xgrid_ogrid(nxgrid_ogrid-2))) then
print*, 'WARNING: An error occured when setting interpolation zone.'
print*, ' Zone adjusted.'
r_int_outer=r_ogrid-dx_outer*((interpolation_method/2)+0.01)-dx_outer*interp_shift
endif
else
call fatal_error('initialize_solid_cells','interpolation method does not exist')
endif
endif
!
! Broadcast the value set for r_int_outer
!
call mpibcast_real(r_int_outer)
!
! Set limit of the interpolation zone, r_int_inner
!
if (interpolation_method<5 .or. interpolation_method>5) then
min_rad=r_int_outer
do ii = l1,l2
do jj = m1,m2
tmp_rad = radius_ogrid(x(ii),y(jj))
if (tmp_rad>r_int_outer.and.tmp_rad<(r_int_outer+5*dxmax)) then
do i3=-2,2
do j3=-2,2
min_tmp_rad = radius_ogrid(x(ii+i3),y(jj+j3))
if (min_tmp_rad<min_rad) min_rad=min_tmp_rad
enddo
enddo
endif
enddo
enddo
r_int_inner = min(r_int_outer-dxmax*3,min_rad-0.01*dxmax)
! r_int_inner = r_int_outer-dxmax*(3.01)
else
r_int_inner_poly=x_ogrid(l1_ogrid+floor(interpol_order_poly*0.5))
print*, 'Polynomial integration: r_int_outer, r_int_inner, r_int_inner_poly' &
, r_int_outer, r_int_inner, r_int_inner_poly
print*, 'Polynomial integration: You should no what you are doing...'
endif
endsubroutine set_interpolation_limits
!***********************************************************************
subroutine del2v_etc_ogrid(f,k,del2,graddiv)
!
! Calculates a number of second derivative expressions of a vector
! outputs a number of different vector fields.
! gradcurl is not the vector gradient.
! Surprisingly, calling derij only if graddiv or curlcurl are present
! does not speed up the code on Mephisto @ 32x32x64.
!
! 12-sep-01/axel: coded
! 15-mar-07/wlad: added cylindrical coordinates
!
real, dimension (mx_ogrid,my_ogrid,mz_ogrid,mfarray_ogrid) :: f
real, dimension (nx_ogrid,3,3) :: fjji,fijj
real, dimension (nx_ogrid,3), optional :: del2,graddiv
real, dimension (nx_ogrid) :: tmp
integer :: i,j,k,k1
!
intent(in) :: f,k
intent(out) :: del2,graddiv
!
! calculate f_{i,jj} and f_{j,ji}
! AJ: graddiv needs diagonal elements from the first tmp (derij only sets
! off-diagonal elements)
!
k1=k-1
do i=1,3
do j=1,3
if (present(del2) .or. present(graddiv)) then
call der2_ogrid(f,k1+i,tmp, j)
fijj(:,i,j)=tmp ! f_{i,jj}
endif
if (present(graddiv)) then
call derij_ogrid(f,k1+j,tmp,j,i)
fjji(:,i,j)=tmp ! f_{j,ji}
endif
enddo
enddo
!
! the diagonal terms have not been set in derij; do this now
! ** They are automatically set above, because derij **
! ** doesn't overwrite the value of tmp for i=j! **
!
! do j=1,3
! fjji(:,j,j)=fijj(:,j,j)
! enddo
!
! calculate f_{i,jk} for i /= j /= k
!
!
! del2
!
if (present(del2)) then
do i=1,3
del2(:,i)=fijj(:,i,1)+fijj(:,i,2)+fijj(:,i,3)
enddo
!r-component
call der_ogrid(f,k1+2,tmp,2)
del2(:,1)=del2(:,1) -(2*tmp+f(l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,k1+1))*rcyl_mn2_ogrid
call der_ogrid(f,k1+1,tmp,1)
del2(:,1)=del2(:,1) + tmp*rcyl_mn1_ogrid
!phi-component
call der_ogrid(f,k1+1,tmp,2)
del2(:,2)=del2(:,2) +(2*tmp-f(l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,k1+2))*rcyl_mn2_ogrid
call der_ogrid(f,k1+2,tmp,1)
del2(:,2)=del2(:,2) + tmp*rcyl_mn1_ogrid
!z-component
call der_ogrid(f,k1+3,tmp,1)
del2(:,3)=del2(:,3) + tmp*rcyl_mn1_ogrid
endif
!
if (present(graddiv)) then
do i=1,3
graddiv(:,i)=fjji(:,i,1)+fjji(:,i,2)+fjji(:,i,3)
enddo
call der_ogrid(f,k1+1,tmp,1)
graddiv(:,1)=graddiv(:,1)+tmp*rcyl_mn1_ogrid - f(l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,k1+1)*rcyl_mn2_ogrid
call der_ogrid(f,2,tmp,2)
graddiv(:,1)=graddiv(:,1)-rcyl_mn1_ogrid*tmp
call der_ogrid(f,k1+1,tmp,2)
graddiv(:,2)=graddiv(:,2)+tmp*rcyl_mn1_ogrid
call der_ogrid(f,k1+1,tmp,3)
graddiv(:,3)=graddiv(:,3)+tmp*rcyl_mn1_ogrid
endif
endsubroutine del2v_etc_ogrid
!***********************************************************************
subroutine run_tests_ogrid
real :: velocity
real :: R2
real, dimension (mx_ogrid, my_ogrid, mz_ogrid,mfarray_ogrid) :: f_pflow
real, dimension (mx_ogrid, my_ogrid,2,2) :: df_pflow, df_pflow_ex
real, dimension (mx_ogrid, my_ogrid,2,2) :: df2_pflow, df2_pflow_ex
real, dimension (mx_ogrid, my_ogrid,2,2,2) :: df2ij_pflow, df2ij_pflow_ex
real, dimension (2,2) :: df_twonorm, df2_twonorm
real, dimension (3) :: graddivu_twonorm
real, dimension (3) :: graddivu2_twonorm
real, dimension (2,2,2) :: df2ij_twonorm
real, dimension (nx_ogrid,3) :: u_vec
real, dimension (nx_ogrid,3,3) :: uij_tensor
real, dimension (mx_ogrid,my_ogrid,3) :: graddivu_vec_exact
real, dimension (mx_ogrid,my_ogrid,3) :: graddivu_vec
real, dimension (mx_ogrid,my_ogrid,3) :: graddivu_vec_exact2
integer :: i,j,k
R2 = cylinder_radius**2
velocity = 1.0
!
! Set up potential flow
! No velocity in z-direction, or density variation
!
do i=1,mx_ogrid
do j=1,my_ogrid
do k=1,mz_ogrid
f_pflow(i,j,k,1) = velocity*(1-R2/(x_ogrid(i)**2))*cos(y_ogrid(j))
f_pflow(i,j,k,2) =-velocity*(1+R2/(x_ogrid(i)**2))*sin(y_ogrid(j))
f_pflow(i,j,k,3) =0.
f_pflow(i,j,k,4) =1.
enddo
enddo
enddo
!
! Compute first order derivatives
!
n_ogrid=4
do m_ogrid=m1_ogrid,m2_ogrid
call der_ogrid(f_pflow,1,df_pflow(l1_ogrid:l2_ogrid,m_ogrid,1,1),1)
call der_ogrid(f_pflow,1,df_pflow(l1_ogrid:l2_ogrid,m_ogrid,1,2),2)
call der_ogrid(f_pflow,2,df_pflow(l1_ogrid:l2_ogrid,m_ogrid,2,1),1)
call der_ogrid(f_pflow,2,df_pflow(l1_ogrid:l2_ogrid,m_ogrid,2,2),2)
enddo
!
! Compute second order derivatives
!
do m_ogrid=m1_ogrid,m2_ogrid
call der2_ogrid(f_pflow,1,df2_pflow(l1_ogrid:l2_ogrid,m_ogrid,1,1),1)
call der2_ogrid(f_pflow,1,df2_pflow(l1_ogrid:l2_ogrid,m_ogrid,1,2),2)
call der2_ogrid(f_pflow,2,df2_pflow(l1_ogrid:l2_ogrid,m_ogrid,2,1),1)
call der2_ogrid(f_pflow,2,df2_pflow(l1_ogrid:l2_ogrid,m_ogrid,2,2),2)
enddo
!
! Compute mixed derivatives
!
do m_ogrid=m1_ogrid,m2_ogrid
call derij_ogrid(f_pflow,1,df2ij_pflow(l1_ogrid:l2_ogrid,m_ogrid,1,1,2),1,2)
call derij_ogrid(f_pflow,1,df2ij_pflow(l1_ogrid:l2_ogrid,m_ogrid,1,2,1),2,1)
call derij_ogrid(f_pflow,2,df2ij_pflow(l1_ogrid:l2_ogrid,m_ogrid,2,1,2),1,2)
call derij_ogrid(f_pflow,2,df2ij_pflow(l1_ogrid:l2_ogrid,m_ogrid,2,2,1),2,1)
enddo
!
! Compute grad(div u)
!
do m_ogrid=m1_ogrid,m2_ogrid
u_vec(1:nx_ogrid,1)=f_pflow(l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,1)
u_vec(1:nx_ogrid,2)=f_pflow(l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,2)
u_vec(1:nx_ogrid,3)=f_pflow(l1_ogrid:l2_ogrid,m_ogrid,n_ogrid,3)
call gij_ogrid(f_pflow,iuu,uij_tensor)
! print*, 'dvr_dr :', uij_tensor(:,1,1)-df_pflow(l1_ogrid:l2_ogrid,m_ogrid,1,1)
! print*, 'dvr_dth :', uij_tensor(:,1,2)-df_pflow(l1_ogrid:l2_ogrid,m_ogrid,1,2)
! print*, 'dvth_dr :', uij_tensor(:,2,1)-df_pflow(l1_ogrid:l2_ogrid,m_ogrid,2,1)
! print*, 'dvth_dth:', uij_tensor(:,2,2)-df_pflow(l1_ogrid:l2_ogrid,m_ogrid,2,2)
call gij_etc_ogrid(f_pflow,iuu,u_vec,uij_tensor,GRADDIV=graddivu_vec(l1_ogrid:l2_ogrid,m_ogrid,:))
print*, 'gij_etc_ogrid:',graddivu_vec(l1_ogrid:l2_ogrid,m_ogrid,1)
call del2v_etc_ogrid(f_pflow,iuu,GRADDIV=graddivu_vec(l1_ogrid:l2_ogrid,m_ogrid,:))
print*, 'del2v_etc_ogr:',graddivu_vec(l1_ogrid:l2_ogrid,m_ogrid,1)
enddo
!
! Set up exact solutions to derivatives
! All values in cylindrical coordinates, hence d/dy = 1/r d/dth, etc.
!
do i=1,mx_ogrid
do j=1,my_ogrid
df_pflow_ex(i,j,1,1) = 2.*velocity*R2*cos(y_ogrid(j))/(x_ogrid(i)**3)
df_pflow_ex(i,j,1,2) = (velocity*sin(y_ogrid(j))*(R2/(x_ogrid(i)**2)-1.))/x_ogrid(i)
df_pflow_ex(i,j,2,1) = 2.*velocity*R2*sin(y_ogrid(j))/(x_ogrid(i)**3)
df_pflow_ex(i,j,2,2) = -(velocity*cos(y_ogrid(j))*(R2/(x_ogrid(i)**2)+1.))/x_ogrid(i)
df2_pflow_ex(i,j,1,1) = -6.*velocity*R2*cos(y_ogrid(j))/(x_ogrid(i)**4)
df2_pflow_ex(i,j,1,2) = (velocity*cos(y_ogrid(j))*(R2/(x_ogrid(i)**2)-1.))/(x_ogrid(i)**2)
df2_pflow_ex(i,j,2,1) = -6.*velocity*R2*sin(y_ogrid(j))/(x_ogrid(i)**4)
df2_pflow_ex(i,j,2,2) = (velocity*sin(y_ogrid(j))*(R2/(x_ogrid(i)**2)+1.))/(x_ogrid(i)**2)
df2ij_pflow_ex(i,j,1,1,2) = -2.*velocity*R2*sin(y_ogrid(j))/(x_ogrid(i)**4)
!df2ij_pflow_ex(i,j,1,2,1) = -2.*velocity*R2*sin(y_ogrid(j))/(x_ogrid(i)**4)
df2ij_pflow_ex(i,j,1,2,1) = df2ij_pflow_ex(i,j,1,1,2)
df2ij_pflow_ex(i,j,2,1,2) = 2.*velocity*R2*cos(y_ogrid(j))/(x_ogrid(i)**4)
df2ij_pflow_ex(i,j,2,2,1) = df2ij_pflow_ex(i,j,2,1,2)
!df2ij_pflow_ex(i,j,2,2,1) = 2.*velocity*R2*cos(y_ogrid(j))/(x_ogrid(i)**4)
graddivu_vec_exact(i,j,1) = df2_pflow_ex(i,j,1,1)+df2ij_pflow_ex(i,j,2,1,2) + &
(1./x_ogrid(i))*(df_pflow_ex(i,j,1,1)-df_pflow_ex(i,j,2,2)) - &
(1./(x_ogrid(i)**2))*(f_pflow(i,j,1,1))
graddivu_vec_exact2(i,j,2) = df2_pflow_ex(i,j,2,2)+df2ij_pflow_ex(i,j,1,1,2) + &
(1./x_ogrid(i))*(df_pflow_ex(i,j,1,2))
graddivu_vec_exact2(i,j,1) = df2_pflow(i,j,1,1)+df2ij_pflow(i,j,2,1,2) + &
(1./x_ogrid(i))*(df_pflow(i,j,1,1)-df_pflow(i,j,2,2)) - &
(1./(x_ogrid(i)**2))*(f_pflow(i,j,1,1))
graddivu_vec_exact2(i,j,2) = df2_pflow(i,j,2,2)+df2ij_pflow(i,j,1,1,2) + &
(1./x_ogrid(i))*(df_pflow(i,j,1,2))
!f_pflow(i,j,k,1) = velocity*(1-R2/(x_ogrid(i)**2))*cos(y_ogrid(j))
enddo
enddo
!
! Compute two-norms
!
df_twonorm=0.
df2_twonorm=0.
df2ij_twonorm=0.
graddivu_twonorm=0.
graddivu2_twonorm=0.
do i=l1_ogrid,l2_ogrid
do j=m1_ogrid,m2_ogrid
df_twonorm(1,1)=df_twonorm(1,1)+(df_pflow_ex(i,j,1,1)-df_pflow(i,j,1,1))**2 &
*(1./dx_1_ogrid(i))*(x_ogrid(i)/dy_1_ogrid(j))
df_twonorm(1,2)=df_twonorm(1,2)+(df_pflow_ex(i,j,1,2)-df_pflow(i,j,1,2))**2 &
*(1./dx_1_ogrid(i))*(x_ogrid(i)/dy_1_ogrid(j))
df_twonorm(2,1)=df_twonorm(2,1)+(df_pflow_ex(i,j,2,1)-df_pflow(i,j,2,1))**2 &
*(1./dx_1_ogrid(i))*(x_ogrid(i)/dy_1_ogrid(j))
df_twonorm(2,2)=df_twonorm(2,2)+(df_pflow_ex(i,j,2,2)-df_pflow(i,j,2,2))**2 &
*(1./dx_1_ogrid(i))*(x_ogrid(i)/dy_1_ogrid(j))
df2_twonorm(1,1)=df2_twonorm(1,1)+(df2_pflow_ex(i,j,1,1)-df2_pflow(i,j,1,1))**2 &
*(1./dx_1_ogrid(i))*(x_ogrid(i)/dy_1_ogrid(j))
df2_twonorm(1,2)=df2_twonorm(1,2)+(df2_pflow_ex(i,j,1,2)-df2_pflow(i,j,1,2))**2 &
*(1./dx_1_ogrid(i))*(x_ogrid(i)/dy_1_ogrid(j))
df2_twonorm(2,1)=df2_twonorm(2,1)+(df2_pflow_ex(i,j,2,1)-df2_pflow(i,j,2,1))**2 &
*(1./dx_1_ogrid(i))*(x_ogrid(i)/dy_1_ogrid(j))
df2_twonorm(2,2)=df2_twonorm(2,2)+(df2_pflow_ex(i,j,2,2)-df2_pflow(i,j,2,2))**2 &
*(1./dx_1_ogrid(i))*(x_ogrid(i)/dy_1_ogrid(j))
df2ij_twonorm(1,1,2)=df2ij_twonorm(1,1,2)+(df2ij_pflow_ex(i,j,1,1,2)-df2ij_pflow(i,j,1,1,2))**2 &
*(1./dx_1_ogrid(i))*(x_ogrid(i)/dy_1_ogrid(j))
df2ij_twonorm(1,2,1)=df2ij_twonorm(1,2,1)+(df2ij_pflow_ex(i,j,1,2,1)-df2ij_pflow(i,j,1,2,1))**2 &
*(1./dx_1_ogrid(i))*(x_ogrid(i)/dy_1_ogrid(j))
df2ij_twonorm(2,1,2)=df2ij_twonorm(2,1,2)+(df2ij_pflow_ex(i,j,2,1,2)-df2ij_pflow(i,j,2,1,2))**2 &
*(1./dx_1_ogrid(i))*(x_ogrid(i)/dy_1_ogrid(j))
df2ij_twonorm(2,2,1)=df2ij_twonorm(2,2,1)+(df2ij_pflow_ex(i,j,2,2,1)-df2ij_pflow(i,j,2,2,1))**2 &
*(1./dx_1_ogrid(i))*(x_ogrid(i)/dy_1_ogrid(j))
graddivu_twonorm(:)=graddivu_twonorm(:)+(graddivu_vec(i,j,:)-graddivu_vec_exact(i,j,:))**2 &
*(1./dx_1_ogrid(i))*(x_ogrid(i)/dy_1_ogrid(j))
graddivu2_twonorm(:)=graddivu2_twonorm(:)+(graddivu_vec(i,j,:)-graddivu_vec_exact2(i,j,:))**2 &
*(1./dx_1_ogrid(i))*(x_ogrid(i)/dy_1_ogrid(j))
enddo
enddo
print*, graddivu_twonorm
print*, graddivu2_twonorm
df_twonorm=sqrt(df_twonorm)
df2_twonorm=sqrt(df2_twonorm)
df2ij_twonorm=sqrt(df2ij_twonorm)
!
! Print two-norms
!
if (SBP) then
open(10,file='runinfo.dat',status='unknown')
open(1,file='SBP2norm_df.dat',status='unknown')
open(2,file='SBP2norm_df2.dat',status='unknown')
open(3,file='SBP2norm_df2ij.dat',status='unknown')
write(10,*) '% Summation by parts'
elseif (BDRY5) then
open(10,file='runinfo.dat',status='unknown')
open(1,file='BDRY5norm_df.dat',status='unknown')
open(2,file='BDRY5norm_df2.dat',status='unknown')
open(3,file='BDRY5norm_df2ij.dat',status='unknown')
write(10,*) '# Fifth order boundary closures'
else
open(10,file='runinfo.dat',status='unknown')
open(1,file='NOBDRYnorm_df.dat',status='unknown')
open(2,file='NOBDRYnorm_df2.dat',status='unknown')
open(3,file='NOBDRYnorm_df2ij.dat',status='unknown')
write(10,*) '# No boundary condition given'
endif
write(10,*) '# nx_ogrid, ny_ogrid'
write(10,*) nx_ogrid,ny_ogrid
write(*,*) '# df_twonorm'
write(*,*) '# dvrdr, dvrdth'
write(*,*) '# dvthdr, dvthdth'
write(*,*) df_twonorm(1,1), df_twonorm(1,2)
write(*,*) df_twonorm(2,1), df_twonorm(2,2)
write(*,*) '# df2_twonorm'
write(*,*) '# d2vrdr2, d2vrdth2'
write(*,*) '# d2vthdr2, d2vthdth2'
write(*,*) df2_twonorm(1,1), df2_twonorm(1,2)
write(*,*) df2_twonorm(2,1), df2_twonorm(2,2)
write(*,*) '# df2ij_twonorm'
write(*,*) '# d2vrdrdth, d2vrdthdr'
write(*,*) '# d2vthdrdth, d2vthdthdr'
write(*,*) df2ij_twonorm(1,1,2), df2ij_twonorm(1,2,1)
write(*,*) df2ij_twonorm(2,1,2), df2ij_twonorm(2,2,1)
close(1)
close(2)
close(3)
close(10)
open(111,file='r.dat',status='unknown')
open(211,file='th.dat',status='unknown')
open(100,file='x.dat',status='unknown')
open(11,file='y.dat',status='unknown')
open(20,file='vr.dat',status='unknown')
open(21,file='vth.dat',status='unknown')
open(29,file='dervr_r.dat',status='unknown')
open(30,file='der2vr_r.dat',status='unknown')
open(31,file='der2vr_th.dat',status='unknown')
open(32,file='der2vth_r.dat',status='unknown')
open(33,file='der2vth_th.dat',status='unknown')
!open(32,file='der2r_indirect.dat',status='unknown')
!open(33,file='der2th_indirect.dat',status='unknown')
write(111,*) x_ogrid(l1_ogrid:l2_ogrid)
write(211,*) y_ogrid(m1_ogrid:m2_ogrid)
do i=l1_ogrid,l2_ogrid
!do j=m1_ogrid,m2_ogrid
write(100,*) x_ogrid(i)*cos(y_ogrid(m1_ogrid:m2_ogrid))
write(11,*) x_ogrid(i)*sin(y_ogrid(m1_ogrid:m2_ogrid))
!enddo
enddo
do i=l1_ogrid,l2_ogrid
write(20,*) f_pflow(i,m1_ogrid:m2_ogrid,1,1)
write(21,*) f_pflow(i,m1_ogrid:m2_ogrid,1,2)
write(29,*) df_pflow(i,m1_ogrid:m2_ogrid,1,1)
write(30,*) df2_pflow(i,m1_ogrid:m2_ogrid,1,1)
write(31,*) df2_pflow(i,m1_ogrid:m2_ogrid,1,2)
write(32,*) df2_pflow(i,m1_ogrid:m2_ogrid,2,1)
write(33,*) df2_pflow(i,m1_ogrid:m2_ogrid,2,2)
enddo
close(111)
close(211)
close(100)
close(11)
close(20)
close(21)
close(29)
close(30)
close(31)
close(32)
close(33)
endsubroutine run_tests_ogrid
!***********************************************************************
subroutine initialize_pade_filter(f_og)
!
! Initialization of high order padé filtering of solution array.
! 10th order filter requires extension of ghost zones in periodic
! directions. Extended ghosts zones (halos) allocated here.
!
! 29-nov-17/Jorgen - Coded
!
real, dimension (mx_ogrid, my_ogrid, mz_ogrid,mfarray_ogrid), intent(in):: f_og
if (filter_Hsize==0) then
print*, 'WARNING: No need for filter halos, ghost zone large enough'
print*, ' This will not work for parallel runs with current implemtation'
elseif (filter_Hsize<0) then
call fatal_error('initialize_pade_filter','Negative filter halo size!')
elseif (filter_Hsize>nghost) then
! Requres a modification of mpi-buffers, not yet implemented
call fatal_error('initialize_pade_filter','Filter halo too large!')
endif
!
allocate(f_filterH_lowerx(filter_Hsize,my_ogrid,nz_ogrid,mfarray_ogrid))
allocate(f_filterH_upperx(filter_Hsize,my_ogrid,nz_ogrid,mfarray_ogrid))
allocate(f_filterH_lowery(mx_ogrid,filter_Hsize,nz_ogrid,mfarray_ogrid))
allocate(f_filterH_uppery(mx_ogrid,filter_Hsize,nz_ogrid,mfarray_ogrid))
!
endsubroutine initialize_pade_filter
!***********************************************************************
subroutine communicate_filter_zones(f_og,f_Hlox,f_Hupx,f_Hloy,f_Hupy)
use Solid_Cells_Mpicomm, only: initiate_isendrcv_bdry_filter, finalize_isendrcv_bdry_filter
real, dimension (mx_ogrid, my_ogrid, mz_ogrid,mfarray_ogrid) :: f_og
real, dimension (filter_Hsize,my_ogrid,nz_ogrid,mfarray_ogrid) :: f_Hlox,f_Hupx
real, dimension (mx_ogrid,filter_Hsize,nz_ogrid,mfarray_ogrid) :: f_Hloy,f_Hupy
intent(in) :: f_og
intent(inout) :: f_Hlox,f_Hupx,f_Hloy,f_Hupy
!
! Communicate additional ghost zones needed for 10th order filter.
!
! 29-nov-17/Jorgen - Coded
!
if (nprocx*nprocy>1) then
call initiate_isendrcv_bdry_filter(f_og,filter_Hsize)
call finalize_isendrcv_bdry_filter(f_Hlox,f_Hupx,f_Hloy,f_Hupy,filter_Hsize)
else
call boundconds_y_filter(f_og,f_Hloy,f_Hupy,filter_Hsize)
endif
endsubroutine communicate_filter_zones
!***********************************************************************
subroutine pade_filter(f_og)
use mpicomm, only: mpibarrier
use Solid_cells_Mpicomm, only: cyclic_parallel_y,tridag_parallel_x
use General, only: cyclic, tridag
!
! high order padé filtering of solution array
! 10th order on interor points, can choose 6th, 8th or 10th order at cylinder
! boundary.
!
! Filtering will stabilize solution, necessary for certain boundary conditions
! and grids (e.g., with large stretching)
! Coefficients from Gaitonde & Visbal (2000)
!
! WARNING: Only works for 2D serial runs at the moment
!
! 10-nov-17/Jorgen - Coded
!
real, dimension (mx_ogrid, my_ogrid, mz_ogrid,mfarray_ogrid), intent(inout) :: f_og
!
real, dimension(ny_ogrid,mfarray_ogrid) :: by
real, dimension(nx_ogrid,mfarray_ogrid) :: bx
real, dimension(ny_ogrid), save :: aWy, aPy, aEy
real, dimension(nx_ogrid), save :: aWx, aPx, aEx
integer :: i
integer, save :: ii,jj
real, save :: a0, a1, a2, a3, a4, a5
real, save :: a0_6, a1_6, a2_6, a3_6
logical :: lfirstcall = .true.
if (lfirstcall) then
a0=(193+126*af)/256.
a1=(105+302*af)/256.
a2=15*(-1+2*af)/64.
a3=45*(1-2*af)/512.
a4=5*(-1+2*af)/256.
a5=(1-2*af)/512.
a0_6=11./16.+5.*af/8.
a1_6=15./32.+17.*af/16.
a2_6=-3./16.+3.*af/8.
a3_6=1./32.-af/16.
aWy=af
aPy=1.
aEy=af
aWx = af
aPx = 1.
aEx = af
! Since we do not filter the point at the boundary
if (ipx==0) then
aWx(1) = 0.
aPx(1) = 1.
aEx(1) = 0.
endif
! Also, do not filter values in the interpolation region
if (ipx<nprocx-1) then
jj=0
else
jj=interpol_filter
aWx(nx_ogrid-jj) = 0.
aPx(nx_ogrid-jj) = 1.
aEx(nx_ogrid-jj) = 0.
endif
lfirstcall = .false.
endif
!
! Filtering in theta direction
! 10th order on all points
! Requires special handling near processor bondaries, due to not enough ghost points
! Note! Only works for serial runs
!
do i=l1_ogrid,l2_ogrid
by(3:ny_ogrid-2,:) = a0*f_og(i,m1_ogrid+2:m2_ogrid-2,4,:) &
+ a1*0.5*(f_og(i,m1_ogrid+1:m2_ogrid-3,4,:) + f_og(i,m1_ogrid+3:m2_ogrid-1,4,:)) &
+ a2*0.5*(f_og(i,m1_ogrid :m2_ogrid-4,4,:) + f_og(i,m1_ogrid+4:m2_ogrid ,4,:)) &
+ a3*0.5*(f_og(i,m1_ogrid-1:m2_ogrid-5,4,:) + f_og(i,m1_ogrid+5:m2_ogrid+1,4,:)) &
+ a4*0.5*(f_og(i,m1_ogrid-2:m2_ogrid-6,4,:) + f_og(i,m1_ogrid+6:m2_ogrid+2,4,:)) &
+ a5*0.5*(f_og(i,m1_ogrid-3:m2_ogrid-7,4,:) + f_og(i,m1_ogrid+7:m2_ogrid+3,4,:))
!
! Special handling outside of ordinary ghost points
!
by(1,:) = a0*f_og(i,m1_ogrid,4,:) &
+ a1*0.5*(f_og(i,m1_ogrid-1,4,:) + f_og(i,m1_ogrid+1,4,:)) &
+ a2*0.5*(f_og(i,m1_ogrid-2,4,:) + f_og(i,m1_ogrid+2,4,:)) &
+ a3*0.5*(f_og(i,m1_ogrid-3,4,:) + f_og(i,m1_ogrid+3,4,:)) &
+ a4*0.5*(f_filterH_lowery(i,2,1,:) + f_og(i,m1_ogrid+4,4,:)) &
+ a5*0.5*(f_filterH_lowery(i,1,1,:) + f_og(i,m1_ogrid+5,4,:))
by(2,:) = a0*f_og(i,m1_ogrid+1,4,:) &
+ a1*0.5*(f_og(i,m1_ogrid ,4,:) + f_og(i,m1_ogrid+2,4,:)) &
+ a2*0.5*(f_og(i,m1_ogrid-1,4,:) + f_og(i,m1_ogrid+3,4,:)) &
+ a3*0.5*(f_og(i,m1_ogrid-2,4,:) + f_og(i,m1_ogrid+4,4,:)) &
+ a4*0.5*(f_og(i,m1_ogrid-3,4,:) + f_og(i,m1_ogrid+5,4,:)) &
+ a5*0.5*(f_filterH_lowery(i,2,1,:) + f_og(i,m1_ogrid+6,4,:))
by(ny_ogrid-1,:) = a0*f_og(i,m2_ogrid-1,4,:) &
+ a1*0.5*(f_og(i,m2_ogrid-2,4,:) + f_og(i,m2_ogrid ,4,:)) &
+ a2*0.5*(f_og(i,m2_ogrid-3,4,:) + f_og(i,m2_ogrid+1,4,:)) &
+ a3*0.5*(f_og(i,m2_ogrid-4,4,:) + f_og(i,m2_ogrid+2,4,:)) &
+ a4*0.5*(f_og(i,m2_ogrid-5,4,:) + f_og(i,m2_ogrid+3,4,:)) &
+ a5*0.5*(f_og(i,m2_ogrid-6,4,:) + f_filterH_uppery(i,1,1,:))
by(ny_ogrid ,:) = a0*f_og(i,m2_ogrid,4,:) &
+ a1*0.5*(f_og(i,m2_ogrid-1,4,:) + f_og(i,m2_ogrid+1,4,:)) &
+ a2*0.5*(f_og(i,m2_ogrid-2,4,:) + f_og(i,m2_ogrid+2,4,:)) &
+ a3*0.5*(f_og(i,m2_ogrid-3,4,:) + f_og(i,m2_ogrid+3,4,:)) &
+ a4*0.5*(f_og(i,m2_ogrid-4,4,:) + f_filterH_uppery(i,1,1,:)) &
+ a5*0.5*(f_og(i,m2_ogrid-5,4,:) + f_filterH_uppery(i,2,1,:))
if (nprocy>1) then
if (.not. lfilter_rhoonly) then
call cyclic_parallel_y(aWy,aPy,aEy,af,af,by(:,iux),f_og(i,m1_ogrid:m2_ogrid,4,iux),ny_ogrid)
call cyclic_parallel_y(aWy,aPy,aEy,af,af,by(:,iuy),f_og(i,m1_ogrid:m2_ogrid,4,iuy),ny_ogrid)
call cyclic_parallel_y(aWy,aPy,aEy,af,af,by(:,iuz),f_og(i,m1_ogrid:m2_ogrid,4,iuz),ny_ogrid)
endif
if (lfilter_TT) then
call cyclic_parallel_y(aWy,aPy,aEy,af,af,by(:,iTT),f_og(i,m1_ogrid:m2_ogrid,4,iTT),ny_ogrid)
endif
call cyclic_parallel_y(aWy,aPy,aEy,af,af,by(:,irho),f_og(i,m1_ogrid:m2_ogrid,4,irho),ny_ogrid)
else
if (.not. lfilter_rhoonly) then
call cyclic(aWy,aPy,aEy,af,af,by(:,iux),f_og(i,m1_ogrid:m2_ogrid,4,iux),ny_ogrid)
call cyclic(aWy,aPy,aEy,af,af,by(:,iuy),f_og(i,m1_ogrid:m2_ogrid,4,iuy),ny_ogrid)
call cyclic(aWy,aPy,aEy,af,af,by(:,iuz),f_og(i,m1_ogrid:m2_ogrid,4,iuz),ny_ogrid)
endif
if (lfilter_TT) then
call cyclic(aWy,aPy,aEy,af,af,by(:,iTT),f_og(i,m1_ogrid:m2_ogrid,4,iTT),ny_ogrid)
endif
call cyclic(aWy,aPy,aEy,af,af,by(:,irho),f_og(i,m1_ogrid:m2_ogrid,4,irho),ny_ogrid)
endif
enddo
!
! Filtering in radial direction
! 10th order on interior points, 6th order near boundaries on the edge
! of cylindrical grid (near interpolation zone).
! One-sided filter on cylinder surface can be set to 6th, 8th or 10th order
! Surface point is not filtered, and neither are points in the 'filter'-zone between interpolations
!
do i=m1_ogrid,m2_ogrid
if (ipx==0) then
!
! Special filtering near surface
!
!call boundary_x_central(bx(1:5,:),f_og,af,i)
!call boundary_x_6th(bx(1:5,:),f_og,af,i)
!call boundary_x_8th(bx(1:5,:),f_og,af,i)
!call boundary_x_10th(bx(1:5,:),f_og,af,i)
call boundary_x_8_6th(bx(1:5,:),f_og,af,i)
bx(6:nx_ogrid-2,:) = a0*f_og(l1_ogrid+5:l2_ogrid-2,i,4,:) &
+ a1*0.5*(f_og(l1_ogrid+4:l2_ogrid-3,i,4,:) + f_og(l1_ogrid+ 6:l2_ogrid-1,i,4,:)) &
+ a2*0.5*(f_og(l1_ogrid+3:l2_ogrid-4,i,4,:) + f_og(l1_ogrid+ 7:l2_ogrid ,i,4,:)) &
+ a3*0.5*(f_og(l1_ogrid+2:l2_ogrid-5,i,4,:) + f_og(l1_ogrid+ 8:l2_ogrid+1,i,4,:)) &
+ a4*0.5*(f_og(l1_ogrid+1:l2_ogrid-6,i,4,:) + f_og(l1_ogrid+ 9:l2_ogrid+2,i,4,:)) &
+ a5*0.5*(f_og(l1_ogrid :l2_ogrid-7,i,4,:) + f_og(l1_ogrid+10:l2_ogrid+3,i,4,:))
else
!
! Special handling outside of ordinary ghost points
!
bx(1,:) = a0*f_og(l1_ogrid,i,4,:) &
+ a1*0.5*(f_og(l1_ogrid-1,i,4,:) + f_og(l1_ogrid+1,i,4,:)) &
+ a2*0.5*(f_og(l1_ogrid-2,i,4,:) + f_og(l1_ogrid+2,i,4,:)) &
+ a3*0.5*(f_og(l1_ogrid-3,i,4,:) + f_og(l1_ogrid+3,i,4,:)) &
+ a4*0.5*(f_filterH_lowerx(2,i,1,:) + f_og(l1_ogrid+4,i,4,:)) &
+ a5*0.5*(f_filterH_lowerx(1,i,1,:) + f_og(l1_ogrid+5,i,4,:))
bx(2,:) = a0*f_og(l1_ogrid+1,i,4,:) &
+ a1*0.5*(f_og(l1_ogrid ,i,4,:) + f_og(l1_ogrid+2,i,4,:)) &
+ a2*0.5*(f_og(l1_ogrid-1,i,4,:) + f_og(l1_ogrid+3,i,4,:)) &
+ a3*0.5*(f_og(l1_ogrid-2,i,4,:) + f_og(l1_ogrid+4,i,4,:)) &
+ a4*0.5*(f_og(l1_ogrid-3,i,4,:) + f_og(l1_ogrid+5,i,4,:)) &
+ a5*0.5*(f_filterH_lowerx(2,i,1,:) + f_og(l1_ogrid+6,i,4,:))
bx(3:nx_ogrid-2,:) = a0*f_og(l1_ogrid+2:l2_ogrid-2,i,4,:) &
+ a1*0.5*(f_og(l1_ogrid+1:l2_ogrid-3,i,4,:) + f_og(l1_ogrid+3:l2_ogrid-1,i,4,:)) &
+ a2*0.5*(f_og(l1_ogrid :l2_ogrid-4,i,4,:) + f_og(l1_ogrid+4:l2_ogrid ,i,4,:)) &
+ a3*0.5*(f_og(l1_ogrid-1:l2_ogrid-5,i,4,:) + f_og(l1_ogrid+5:l2_ogrid+1,i,4,:)) &
+ a4*0.5*(f_og(l1_ogrid-2:l2_ogrid-6,i,4,:) + f_og(l1_ogrid+6:l2_ogrid+2,i,4,:)) &
+ a5*0.5*(f_og(l1_ogrid-3:l2_ogrid-7,i,4,:) + f_og(l1_ogrid+7:l2_ogrid+3,i,4,:))
endif
if (ipx<nprocx-1) then
bx(nx_ogrid-1,:) = a0*f_og(l2_ogrid-1,i,4,:) &
+ a1*0.5*(f_og(l2_ogrid-2,i,4,:) + f_og(l2_ogrid ,i,4,:)) &
+ a2*0.5*(f_og(l2_ogrid-3,i,4,:) + f_og(l2_ogrid+1,i,4,:)) &
+ a3*0.5*(f_og(l2_ogrid-4,i,4,:) + f_og(l2_ogrid+2,i,4,:)) &
+ a4*0.5*(f_og(l2_ogrid-5,i,4,:) + f_og(l2_ogrid+3,i,4,:)) &
+ a5*0.5*(f_og(l2_ogrid-6,i,4,:) + f_filterH_upperx(1,i,1,:))
bx(nx_ogrid,:) = a0*f_og(l2_ogrid,i,4,:) &
+ a1*0.5*(f_og(l2_ogrid-1,i,4,:) + f_og(l2_ogrid+1,i,4,:)) &
+ a2*0.5*(f_og(l2_ogrid-2,i,4,:) + f_og(l2_ogrid+2,i,4,:)) &
+ a3*0.5*(f_og(l2_ogrid-3,i,4,:) + f_og(l2_ogrid+3,i,4,:)) &
+ a4*0.5*(f_og(l2_ogrid-4,i,4,:) + f_filterH_upperx(1,i,1,:)) &
+ a5*0.5*(f_og(l2_ogrid-5,i,4,:) + f_filterH_upperx(2,i,1,:))
else
bx(nx_ogrid-1:nx_ogrid,:) = a0_6*f_og(l2_ogrid-1:l2_ogrid,i,4,:) &
+ a1_6*0.5*(f_og(l2_ogrid-2:l2_ogrid-1,i,4,:) + f_og(l2_ogrid :l2_ogrid+1,i,4,:)) &
+ a2_6*0.5*(f_og(l2_ogrid-3:l2_ogrid-2,i,4,:) + f_og(l2_ogrid+1:l2_ogrid+2,i,4,:)) &
+ a3_6*0.5*(f_og(l2_ogrid-4:l2_ogrid-3,i,4,:) + f_og(l2_ogrid+2:l2_ogrid+3,i,4,:))
bx(nx_ogrid-jj,:) = f_og(l2_ogrid-jj,i,4,:)
endif
if (nprocx>1) then
if (.not. lfilter_rhoonly) then
call tridag_parallel_x(aWx(1:nx_ogrid-jj),aPx(1:nx_ogrid-jj),aEx(1:nx_ogrid-jj),bx(1:nx_ogrid-jj,iux), &
f_og(l1_ogrid:l2_ogrid-jj,i,4,iux), nx_ogrid-jj)
call tridag_parallel_x(aWx(1:nx_ogrid-jj),aPx(1:nx_ogrid-jj),aEx(1:nx_ogrid-jj),bx(1:nx_ogrid-jj,iuy), &
f_og(l1_ogrid:l2_ogrid-jj,i,4,iuy), nx_ogrid-jj)
call tridag_parallel_x(aWx(1:nx_ogrid-jj),aPx(1:nx_ogrid-jj),aEx(1:nx_ogrid-jj),bx(1:nx_ogrid-jj,iuz), &
f_og(l1_ogrid:l2_ogrid-jj,i,4,iuz), nx_ogrid-jj)
endif
if (lfilter_TT) then
call tridag_parallel_x(aWx(1:nx_ogrid-jj),aPx(1:nx_ogrid-jj),aEx(1:nx_ogrid-jj),bx(1:nx_ogrid-jj,iTT), &
f_og(l1_ogrid:l2_ogrid-jj,i,4,iTT), nx_ogrid-jj)
endif
call tridag_parallel_x(aWx(1:nx_ogrid-jj),aPx(1:nx_ogrid-jj),aEx(1:nx_ogrid-jj),bx(1:nx_ogrid-jj,irho), &
f_og(l1_ogrid:l2_ogrid-jj,i,4,irho), nx_ogrid-jj)
else
if (.not. lfilter_rhoonly) then
call tridag(aWx(1:nx_ogrid-jj),aPx(1:nx_ogrid-jj),aEx(1:nx_ogrid-jj), &
bx(1:nx_ogrid-jj,iux),f_og(l1_ogrid:l2_ogrid-jj,i,4,iux))
call tridag(aWx(1:nx_ogrid-jj),aPx(1:nx_ogrid-jj),aEx(1:nx_ogrid-jj), &
bx(1:nx_ogrid-jj,iuy),f_og(l1_ogrid:l2_ogrid-jj,i,4,iuy))
call tridag(aWx(1:nx_ogrid-jj),aPx(1:nx_ogrid-jj),aEx(1:nx_ogrid-jj), &
bx(1:nx_ogrid-jj,iuz),f_og(l1_ogrid:l2_ogrid-jj,i,4,iuz))
endif
if (lfilter_TT) then
call tridag(aWx(1:nx_ogrid-jj),aPx(1:nx_ogrid-jj),aEx(1:nx_ogrid-jj), &
bx(1:nx_ogrid-jj,iTT),f_og(l1_ogrid:l2_ogrid-jj,i,4,iTT))
endif
call tridag(aWx(1:nx_ogrid-jj),aPx(1:nx_ogrid-jj),aEx(1:nx_ogrid-jj), &
bx(1:nx_ogrid-jj,irho),f_og(l1_ogrid:l2_ogrid-jj,i,4,irho))
endif
enddo
!
endsubroutine pade_filter
!***********************************************************************
subroutine boundary_x_10th(bx_bound,f_og,af,i)
!
! Compute the 10th order filter function for the radial boundary near the surface.
! Use one-sided differences from Gaitonde & Visbal (2000)
!
! 10-nov-17/Jorgen - Coded
!
real, dimension(5,mfarray_ogrid), intent(out) :: bx_bound
real, dimension (mx_ogrid, my_ogrid, mz_ogrid,mfarray_ogrid), intent(in):: f_og
real, intent(in) :: af
integer, intent(in) :: i
real, dimension(2:5,11), save :: aB_10
integer :: j
logical :: lfirstcall = .true.
!
if (lfirstcall) then
aB_10(2,1) = (1 +1022*af)/1024.
aB_10(2,2) = (507 + 10*af)/512.
aB_10(2,3) = (45 +934*af)/1024.
aB_10(2,4) = 15*(-1+2*af)/128.
aB_10(2,5) = 105*( 1-2*af)/512.
aB_10(2,6) = 63*(-1+2*af)/256.
aB_10(2,7) = 105*( 1-2*af)/512.
aB_10(2,8) = 15*(-1+2*af)/128.
aB_10(2,9) = 45*( 1-2*af)/1024.
aB_10(2,10) = 5*(-1+2*af)/512.
aB_10(2,11) = ( 1-2*af)/1024.
aB_10(3,1) = (-1+2*af)/1024.
aB_10(3,2) = (5 +502*af)/512.
aB_10(3,3) = (979 + 90*af)/1024.
aB_10(3,4) = (15 + 98*af)/128.
aB_10(3,5) = 105*(-1+2*af)/512.
aB_10(3,6) = 63*( 1-2*af)/256.
aB_10(3,7) = 105*(-1+2*af)/512.
aB_10(3,8) = 15*( 1-2*af)/128.
aB_10(3,9) = 45*(-1+2*af)/1024.
aB_10(3,10) = 5*( 1-2*af)/512.
aB_10(3,11) = (-1+2*af)/1024.
aB_10(4,1) = ( 1-2*af)/1024.
aB_10(4,2) = 5*(-1+2*af)/512.
aB_10(4,3) = (45 +934*af)/1024.
aB_10(4,4) = (113 +30*af)/128.
aB_10(4,5) = (105 +302*af)/512.
aB_10(4,6) = 63*(-1+2*af)/256.
aB_10(4,7) = 105*( 1-2*af)/512.
aB_10(4,8) = 15*(-1+2*af)/128.
aB_10(4,9) = 45*( 1-2*af)/1024.
aB_10(4,10) = 5*(-1+2*af)/512.
aB_10(4,11) = ( 1-2*af)/1024.
aB_10(5,1) = (-1+2*af)/1024.
aB_10(5,2) = 5*( 1-2*af)/512.
aB_10(5,3) = 45*(-1+2*af)/1024.
aB_10(5,4) = (15 +98*af)/128.
aB_10(5,5) = (407 +210*af)/512.
aB_10(5,6) = (63 +130*af)/256.
aB_10(5,7) = 105*(-1+2*af)/512.
aB_10(5,8) = 15*( 1-2*af)/128.
aB_10(5,9) = 45*(-1+2*af)/1024.
aB_10(5,10) = 5*( 1-2*af)/512.
aB_10(5,11) = (-1+2*af)/1024.
lfirstcall = .false.
endif
!
do j=2,5
bx_bound(j,:) = aB_10(j, 1)*f_og(l1_ogrid ,i,4,:) + &
aB_10(j, 2)*f_og(l1_ogrid+ 1,i,4,:) + &
aB_10(j, 3)*f_og(l1_ogrid+ 2,i,4,:) + &
aB_10(j, 4)*f_og(l1_ogrid+ 3,i,4,:) + &
aB_10(j, 5)*f_og(l1_ogrid+ 4,i,4,:) + &
aB_10(j, 6)*f_og(l1_ogrid+ 5,i,4,:) + &
aB_10(j, 7)*f_og(l1_ogrid+ 6,i,4,:) + &
aB_10(j, 8)*f_og(l1_ogrid+ 7,i,4,:) + &
aB_10(j, 9)*f_og(l1_ogrid+ 8,i,4,:) + &
aB_10(j,10)*f_og(l1_ogrid+ 9,i,4,:) + &
aB_10(j,11)*f_og(l1_ogrid+10,i,4,:)
enddo
bx_bound(1,:)=f_og(l1_ogrid,i,4,:)
!
endsubroutine boundary_x_10th
!***********************************************************************
subroutine boundary_x_8th(bx_bound,f_og,af,i)
!
! Compute the 8th order filter function for the radial boundary near the surface.
! Use central differences point i=5 (with i=1 at the boundary) and
! one-sided differences fro points i=2:4
! Weights from Gaitonde & Visbal (2000)
!
! 10-nov-17/Jorgen - Coded
!
real, dimension(5,mfarray_ogrid), intent(out) :: bx_bound
real, dimension (mx_ogrid, my_ogrid, mz_ogrid,mfarray_ogrid), intent(in):: f_og
real, intent(in) :: af
integer, intent(in) :: i
real, dimension(2:4,9), save :: aB_8
real, save :: a0_8, a1_8, a2_8, a3_8, a4_8
integer :: j
logical :: lfirstcall = .true.
!
if (lfirstcall) then
a0_8=(93+70*af)/128.
a1_8=(7+18*af)/16.
a2_8=(-7+14*af)/32.
a3_8=1/16.-af/8.
a4_8=-1/128.+af/64.
aB_8(4,1) = 1/256. - af/128.
aB_8(4,2) = -1/32. + af/16.
aB_8(4,3) = 7/64. +25*af/32.
aB_8(4,4) = 25/32. + 7*af/16.
aB_8(4,5) = 35/128. +29*af/64.
aB_8(4,6) = -7/32. + 7*af/16.
aB_8(4,7) = 7/64. - 7*af/32.
aB_8(4,8) = -1/32. + af/16.
aB_8(4,9) = 1/256. - af/128.
aB_8(3,1) = -1/256. + af/128.
aB_8(3,2) = 1/32. +15*af/16.
aB_8(3,3) = 57/64. + 7*af/32.
aB_8(3,4) = 7/32. + 9*af/16.
aB_8(3,5) = 7*(-5 + 10*af)/128.
aB_8(3,6) = 7/32. - 7*af/16.
aB_8(3,7) = -7/64. + 7*af/32.
aB_8(3,8) = 1/32. - af/16.
aB_8(3,9) = -1/256. + af/128.
aB_8(2,1) = 1/256. +127*af/128.
aB_8(2,2) = 31/32. + af/16.
aB_8(2,3) = 7/64. +25*af/32.
aB_8(2,4) = -7/32. + 7*af/16.
aB_8(2,5) = 7*( 5 - 10*af)/128.
aB_8(2,6) = -7/32. + 7*af/16.
aB_8(2,7) = 7/64. - 7*af/32.
aB_8(2,8) = -1/32. + af/16.
aB_8(2,9) = 1/256. - af/128.
lfirstcall = .false.
endif
bx_bound(5,:) = a0_8*f_og(l1_ogrid+4,i,4,:) &
+ a1_8*0.5*(f_og(l1_ogrid+3,i,4,:) + f_og(l1_ogrid+5,i,4,:)) &
+ a2_8*0.5*(f_og(l1_ogrid+2,i,4,:) + f_og(l1_ogrid+6,i,4,:)) &
+ a3_8*0.5*(f_og(l1_ogrid+1,i,4,:) + f_og(l1_ogrid+7,i,4,:)) &
+ a4_8*0.5*(f_og(l1_ogrid ,i,4,:) + f_og(l1_ogrid+8,i,4,:))
do j=2,4
bx_bound(j,:) = aB_8(j,1)*f_og(l1_ogrid ,i,4,:) + &
aB_8(j,2)*f_og(l1_ogrid+1,i,4,:) + &
aB_8(j,3)*f_og(l1_ogrid+2,i,4,:) + &
aB_8(j,4)*f_og(l1_ogrid+3,i,4,:) + &
aB_8(j,5)*f_og(l1_ogrid+4,i,4,:) + &
aB_8(j,6)*f_og(l1_ogrid+5,i,4,:) + &
aB_8(j,7)*f_og(l1_ogrid+6,i,4,:) + &
aB_8(j,8)*f_og(l1_ogrid+7,i,4,:) + &
aB_8(j,9)*f_og(l1_ogrid+8,i,4,:)
enddo
bx_bound(1,:)=f_og(l1_ogrid,i,4,:)
endsubroutine boundary_x_8th
!***********************************************************************
subroutine boundary_x_6th(bx_bound,f_og,af,i)
!
! Compute the 6th order filter function for the radial boundary near the surface.
! Use central differences for points i=3:5 (with i=1 at the boundary) and
! one-sided differences fro points i=2:3
! Weights from Gaitonde & Visbal (2000)
!
! 10-nov-17/Jorgen - Coded
!
real, dimension(5,mfarray_ogrid), intent(out) :: bx_bound
real, dimension (mx_ogrid, my_ogrid, mz_ogrid,mfarray_ogrid), intent(in):: f_og
real, intent(in) :: af
integer, intent(in) :: i
real, dimension(2:3,7), save :: aB_6
real, save :: a0_6, a1_6, a2_6, a3_6
logical :: lfirstcall = .true.
!
if (lfirstcall) then
a0_6=11./16.+5.*af/8.
a1_6=15./32.+17.*af/16.
a2_6=-3./16.+3.*af/8.
a3_6=1./32.-af/16.
aB_6(2,1) = 1/64. +31*af/32.
aB_6(2,2) = 29/32. + 3*af/16.
aB_6(2,3) = 15/64. +17*af/32.
aB_6(2,4) = -5/16. + 5*af/8.
aB_6(2,5) = 15/64. -15*af/32.
aB_6(2,6) = -3/32. + 3*af/16.
aB_6(2,7) = 1/64. - af/32.
aB_6(3,1) = -1/64. + af/32.
aB_6(3,2) = 3/32. +13*af/16.
aB_6(3,3) = 49/64. +15*af/32.
aB_6(3,4) = 5/16. + 3*af/8.
aB_6(3,5) =-15/64. +15*af/32.
aB_6(3,6) = 3/32. - 3*af/16.
aB_6(3,7) = -1/64. + af/32.
lfirstcall = .false.
endif
bx_bound(4:5,:) = a0_6*f_og(l1_ogrid+3:l1_ogrid+4,i,4,:) &
+ a1_6*0.5*(f_og(l1_ogrid+2:l1_ogrid+3,i,4,:) + f_og(l1_ogrid+4:l1_ogrid+5,i,4,:)) &
+ a2_6*0.5*(f_og(l1_ogrid+1:l1_ogrid+2,i,4,:) + f_og(l1_ogrid+5:l1_ogrid+6,i,4,:)) &
+ a3_6*0.5*(f_og(l1_ogrid :l1_ogrid+1,i,4,:) + f_og(l1_ogrid+6:l1_ogrid+7,i,4,:))
bx_bound(3,:) = aB_6(3,1)*f_og(l1_ogrid ,i,4,:) + &
aB_6(3,2)*f_og(l1_ogrid+1,i,4,:) + &
aB_6(3,3)*f_og(l1_ogrid+2,i,4,:) + &
aB_6(3,4)*f_og(l1_ogrid+3,i,4,:) + &
aB_6(3,5)*f_og(l1_ogrid+4,i,4,:) + &
aB_6(3,6)*f_og(l1_ogrid+5,i,4,:) + &
aB_6(3,7)*f_og(l1_ogrid+6,i,4,:)
bx_bound(2,:) = aB_6(2,1)*f_og(l1_ogrid ,i,4,:) + &
aB_6(2,2)*f_og(l1_ogrid+1,i,4,:) + &
aB_6(2,3)*f_og(l1_ogrid+2,i,4,:) + &
aB_6(2,4)*f_og(l1_ogrid+3,i,4,:) + &
aB_6(2,5)*f_og(l1_ogrid+4,i,4,:) + &
aB_6(2,6)*f_og(l1_ogrid+5,i,4,:) + &
aB_6(2,7)*f_og(l1_ogrid+6,i,4,:)
bx_bound(1,:)=f_og(l1_ogrid,i,4,:)
!
endsubroutine boundary_x_6th
!***********************************************************************
subroutine boundary_x_central(bx_bound,f_og,af,i)
!
! Compute the 6th order filter function for the radial boundary near the surface.
! Use central differences for points i=3:5 (with i=1 at the boundary) and
! one-sided differences fro points i=2:3
! Weights from Gaitonde & Visbal (2000)
!
! 10-nov-17/Jorgen - Coded
!
real, dimension(5,mfarray_ogrid), intent(out) :: bx_bound
real, dimension (mx_ogrid, my_ogrid, mz_ogrid,mfarray_ogrid), intent(in):: f_og
real, intent(in) :: af
integer, intent(in) :: i
real, save :: a0_8, a1_8, a2_8, a3_8, a4_8
real, save :: a0_6, a1_6, a2_6, a3_6
real, save :: a0_4, a1_4, a2_4
real, save :: a0_2, a1_2
logical :: lfirstcall = .true.
!
if (lfirstcall) then
a0_8=(93+70*af)/128.
a1_8=(7+18*af)/16.
a2_8=(-7+14*af)/32.
a3_8=1/16.-af/8.
a4_8=-1/128.+af/64.
!
a0_6=11./16.+5.*af/8.
a1_6=15./32.+17.*af/16.
a2_6=-3./16.+3.*af/8.
a3_6=1./32.-af/16.
a0_4=5/8. + 3*af/4.
a1_4=1/2. + af
a2_4=-1/8. + af/4.
a0_2=0.5+af
a1_2=0.5+af
lfirstcall = .false.
endif
bx_bound(5,:) = a0_8* f_og(l1_ogrid+4,i,4,:) &
+ a1_8*0.5*(f_og(l1_ogrid+3,i,4,:) + f_og(l1_ogrid+5,i,4,:)) &
+ a2_8*0.5*(f_og(l1_ogrid+2,i,4,:) + f_og(l1_ogrid+6,i,4,:)) &
+ a3_8*0.5*(f_og(l1_ogrid+1,i,4,:) + f_og(l1_ogrid+7,i,4,:)) &
+ a4_8*0.5*(f_og(l1_ogrid ,i,4,:) + f_og(l1_ogrid+8,i,4,:))
bx_bound(4,:) = a0_6* f_og(l1_ogrid+3,i,4,:) &
+ a1_6*0.5*(f_og(l1_ogrid+2,i,4,:) + f_og(l1_ogrid+4,i,4,:)) &
+ a2_6*0.5*(f_og(l1_ogrid+1,i,4,:) + f_og(l1_ogrid+5,i,4,:)) &
+ a3_6*0.5*(f_og(l1_ogrid ,i,4,:) + f_og(l1_ogrid+6,i,4,:))
bx_bound(3,:) = a0_4* f_og(l1_ogrid+2,i,4,:) &
+ a1_4*0.5*(f_og(l1_ogrid+1,i,4,:) + f_og(l1_ogrid+3,i,4,:)) &
+ a1_4*0.5*(f_og(l1_ogrid ,i,4,:) + f_og(l1_ogrid+4,i,4,:))
bx_bound(2,:) = a0_2* f_og(l1_ogrid+1,i,4,:) &
+ a1_2*0.5*(f_og(l1_ogrid ,i,4,:) + f_og(l1_ogrid+1,i,4,:))
bx_bound(1,:)=f_og(l1_ogrid,i,4,:)
!
endsubroutine boundary_x_central
!***********************************************************************
subroutine boundary_x_8_6th(bx_bound,f_og,af,i)
!
! Compute the 8th order filter function for the radial boundary near the surface.
! Use central differences point i=5 (with i=1 at the boundary) and
! one-sided differences fro points i=2:4
! Weights from Gaitonde & Visbal (2000)
!
! 10-nov-17/Jorgen - Coded
!
real, dimension(5,mfarray_ogrid), intent(out) :: bx_bound
real, dimension (mx_ogrid, my_ogrid, mz_ogrid,mfarray_ogrid), intent(in):: f_og
real, intent(in) :: af
integer, intent(in) :: i
real, dimension(3:4,9), save :: aB_8
real, dimension(7), save :: aB_6
real, save :: a0_8, a1_8, a2_8, a3_8, a4_8
logical :: lfirstcall = .true.
integer :: j
!
if (lfirstcall) then
a0_8=(93+70*af)/128.
a1_8=(7+18*af)/16.
a2_8=(-7+14*af)/32.
a3_8=1/16.-af/8.
a4_8=-1/128.+af/64.
aB_8(4,1) = 1/256. - af/128.
aB_8(4,2) = -1/32. + af/16.
aB_8(4,3) = 7/64. +25*af/32.
aB_8(4,4) = 25/32. + 7*af/16.
aB_8(4,5) = 35/128. +29*af/64.
aB_8(4,6) = -7/32. + 7*af/16.
aB_8(4,7) = 7/64. - 7*af/32.
aB_8(4,8) = -1/32. + af/16.
aB_8(4,9) = 1/256. - af/128.
aB_8(3,1) = -1/256. + af/128.
aB_8(3,2) = 1/32. +15*af/16.
aB_8(3,3) = 57/64. + 7*af/32.
aB_8(3,4) = 7/32. + 9*af/16.
aB_8(3,5) = 7*(-5 + 10*af)/128.
aB_8(3,6) = 7/32. - 7*af/16.
aB_8(3,7) = -7/64. + 7*af/32.
aB_8(3,8) = 1/32. - af/16.
aB_8(3,9) = -1/256. + af/128.
aB_6(1) = 1/64. +31*af/32.
aB_6(2) = 29/32. + 3*af/16.
aB_6(3) = 15/64. +17*af/32.
aB_6(4) = -5/16. + 5*af/8.
aB_6(5) = 15/64. -15*af/32.
aB_6(6) = -3/32. + 3*af/16.
aB_6(7) = 1/64. - af/32.
lfirstcall = .false.
endif
bx_bound(5,:) = a0_8*f_og(l1_ogrid+4,i,4,:) &
+ a1_8*0.5*(f_og(l1_ogrid+3,i,4,:) + f_og(l1_ogrid+5,i,4,:)) &
+ a2_8*0.5*(f_og(l1_ogrid+2,i,4,:) + f_og(l1_ogrid+6,i,4,:)) &
+ a3_8*0.5*(f_og(l1_ogrid+1,i,4,:) + f_og(l1_ogrid+7,i,4,:)) &
+ a4_8*0.5*(f_og(l1_ogrid ,i,4,:) + f_og(l1_ogrid+8,i,4,:))
do j=3,4
bx_bound(j,:) = aB_8(j,1)*f_og(l1_ogrid ,i,4,:) + &
aB_8(j,2)*f_og(l1_ogrid+1,i,4,:) + &
aB_8(j,3)*f_og(l1_ogrid+2,i,4,:) + &
aB_8(j,4)*f_og(l1_ogrid+3,i,4,:) + &
aB_8(j,5)*f_og(l1_ogrid+4,i,4,:) + &
aB_8(j,6)*f_og(l1_ogrid+5,i,4,:) + &
aB_8(j,7)*f_og(l1_ogrid+6,i,4,:) + &
aB_8(j,8)*f_og(l1_ogrid+7,i,4,:) + &
aB_8(j,9)*f_og(l1_ogrid+8,i,4,:)
enddo
bx_bound(2,:) = aB_6(1)*f_og(l1_ogrid ,i,4,:) + &
aB_6(2)*f_og(l1_ogrid+1,i,4,:) + &
aB_6(3)*f_og(l1_ogrid+2,i,4,:) + &
aB_6(4)*f_og(l1_ogrid+3,i,4,:) + &
aB_6(5)*f_og(l1_ogrid+4,i,4,:) + &
aB_6(6)*f_og(l1_ogrid+5,i,4,:) + &
aB_6(7)*f_og(l1_ogrid+6,i,4,:)
bx_bound(1,:)=f_og(l1_ogrid,i,4,:)
endsubroutine boundary_x_8_6th
!***********************************************************************
subroutine check_cyl_pos(cyl_pos,domstart,domend)
!
! Check if the cylinder is positioned inside the domain
!
real, dimension(3) :: cyl_pos, domstart, domend
if ((domstart(1) < cyl_pos(1) .and. cyl_pos(1) < domend(1)) .and. &
(domstart(2) < cyl_pos(2) .and. cyl_pos(2) < domend(2)) .and. &
(domstart(3) < cyl_pos(3) .and. cyl_pos(3) < domend(3))) then
continue
else
call fatal_error('init_solid_cells','Cylinder placed outside domain')
endif
endsubroutine check_cyl_pos
!***********************************************************************
subroutine create_curv_cart_transform(trans_mat)
real, dimension(my_ogrid,2), intent(out) :: trans_mat
trans_mat(:,1) = sin(y_ogrid(:))
trans_mat(:,2) = cos(y_ogrid(:))
endsubroutine create_curv_cart_transform
!***********************************************************************
!
! CURRENTLY NOT USED
!
!***********************************************************************
! logical function linear_interpolate_cart_HO(farr,ivar1,ivar2,xxp,inear_glob,fp,lcheck,order)
!!
!! Interpolate the value of f to arbitrary (xp, yp) CARTESIAN coordinate
!! using the high-order lagrangian interpolation.
!!
!! TODO: Extend to 3D
!! TODO: Extend to arbitrary order
!!
!! The coefficients are determined by the 2xN grid points surrounding the
!! interpolation point.
!! Global coordinates are used for the interpolation, to allow interpolation of
!! values outside this processors domain.
!!
!! 26-apr-17/Jorgen: Adapted from linear_interpolate_curv_HO
!!
! integer :: ivar1, ivar2
! integer, intent(in) :: order
! real, dimension (3) :: xxp
! real, dimension (order,order,2,ivar2-ivar1+1) :: farr
! real, dimension (ivar2-ivar1+1) :: fp
! integer, dimension (3) :: inear_glob
! logical :: lcheck
!!
! intent(in) :: farr, ivar1, ivar2, xxp, inear_glob, lcheck
! intent(out) :: fp
! integer :: i,ix0,iy0,iz0
! real, dimension(ivar2-ivar1+1) :: g1,g2
! real :: xp,yp,l1,l2,l3,l4
! real, dimension(order,ivar2-ivar1+1) :: g_interp
! real, dimension(order) :: lagrange
! real, dimension(order,order) :: dx1,dy1
! integer :: j,k,l
!!
!! Determine index value of lowest lying corner point of grid box surrounding
!! the interpolation point.
!!
! linear_interpolate_cart_HO= .true.
!!
! ix0=inear_glob(1); iy0=inear_glob(2); iz0=inear_glob(3)
!!
!! Check if the grid point interval is really correct.
!!
! if ((xglobal(ix0)<=xxp(1) .and. xglobal(ix0+1)>=xxp(1) .or. nxgrid==1) .and. &
! (yglobal(iy0)<=xxp(2) .and. yglobal(iy0+1)>=xxp(2) .or. nygrid==1) .and. &
! (zglobal(iz0)<=xxp(3) .and. zglobal(iz0+1)>=xxp(3) .or. nzgrid==1)) then
! ! Everything okay
! else
! print*, 'linear_interpolate_cartesian: Global interpolation point does not ' // &
! 'lie within the calculated grid point interval.'
! print*, 'iproc = ', iproc_world
! print*, 'mxgrid, xglobal(1), xglobal(mx) = ', mxgrid, xglobal(1), xglobal(mxgrid)
! print*, 'mygrid, yglobal(1), yglobal(my) = ', mygrid, yglobal(1), yglobal(mygrid)
! print*, 'mzgrid, zglobal(1), zglobal(mz) = ', mzgrid, zglobal(1), zglobal(mzgrid)
! print*, 'ix0, iy0, iz0 = ', ix0, iy0, iz0
! print*, 'xp, xp0, xp1 = ', xxp(1), xglobal(ix0), xglobal(ix0+1)
! print*, 'yp, yp0, yp1 = ', xxp(2), yglobal(iy0), yglobal(iy0+1)
! print*, 'zp, zp0, zp1 = ', xxp(3), zglobal(iz0), zglobal(iz0+1)
! linear_interpolate_cart_HO = .false.
! return
! endif
!!
!! Set up 1D Lagrange basis polynomials in x-direction
!!
! k=-floor(order/2.)
! do i=1,order
! k=k+1
! l=-floor(order/2.)
! do j=1,order
! l=l+1
! dx1(i,j)=xglobal(ix0+k)-xglobal(ix0+l)
! enddo
! dx1(i,i)=1 ! To avoid division by zero
! enddo
! dx1=1./dx1
! xp=xxp(1)
! k=-floor(order/2.)
! do i=1,order
! k=k+1
! lagrange(i)=1./(xp-xglobal(ix0+k))
! enddo
! k=-floor(order/2.)
! do i=1,order
! k=k+1
! lagrange(:)=lagrange(:)*(xp-xglobal(ix0+k))*dx1(:,i)
! enddo
! g_interp=0
! do i=1,order
! g_interp(:,ivar1:ivar2)=g_interp(:,ivar1:ivar2)+farr(i,:,1,ivar1:ivar2)*lagrange(i)
! enddo
! ! y-dir
! k=-floor(order/2.)
! do i=1,order
! k=k+1
! l=-floor(order/2.)
! do j=1,order
! l=l+1
! dy1(i,j)=yglobal(iy0+k)-yglobal(iy0+l)
! enddo
! dy1(i,i)=1 ! To avoid division by zero
! enddo
! dy1=1./dy1
! yp=xxp(2)
! k=-floor(order/2.)
! do i=1,order
! k=k+1
! lagrange(i)=1./(yp-yglobal(iy0+k))
! enddo
! k=-floor(order/2.)
! do i=1,order
! k=k+1
! lagrange(:)=lagrange(:)*(yp-yglobal(iy0+k))*dy1(:,i)
! enddo
! fp=0
! do i=1,order
! fp(ivar1:ivar2)=fp(ivar1:ivar2)+g_interp(i,ivar1:ivar2)*lagrange(i)
! enddo
!!
!! Do a reality check on the interpolation scheme.
!!
! if (lcheck) then
! do i=1,ivar2-ivar1+1
! if (fp(i)>maxval(farr(:,:,1,i)).and.i/=3) then
! l1=(xp-xglobal(ix0+1))/(xglobal(ix0)-xglobal(ix0+1))
! l2=(xp-xglobal(ix0 ))/(xglobal(ix0+1)-xglobal(ix0))
! g1=farr(k,k,1,ivar1:ivar2)*l1+farr(k+1,k,1,ivar1:ivar2)*l2
! g2=farr(k,k+1,1,ivar1:ivar2)*l1+farr(k,k+1,1,ivar1:ivar2)*l2
! l3=(yp-yglobal(iy0+1))/(yglobal(iy0)-yglobal(iy0+1))
! l4=(yp-yglobal(iy0 ))/(yglobal(iy0+1)-yglobal(iy0))
! fp=g1*l3+g2*l4
! elseif (fp(i)<minval(farr(:,:,1,i)).and.i/=3) then
! l1=(xp-xglobal(ix0+1))/(xglobal(ix0)-xglobal(ix0+1))
! l2=(xp-xglobal(ix0 ))/(xglobal(ix0+1)-xglobal(ix0))
! g1=farr(k,k,1,ivar1:ivar2)*l1+farr(k+1,k,1,ivar1:ivar2)*l2
! g2=farr(k,k+1,1,ivar1:ivar2)*l1+farr(k,k+1,1,ivar1:ivar2)*l2
! l3=(yp-yglobal(iy0+1))/(yglobal(iy0)-yglobal(iy0+1))
! l4=(yp-yglobal(iy0 ))/(yglobal(iy0+1)-yglobal(iy0))
! fp=g1*l3+g2*l4
! endif
! if ((fp(i)>maxval(farr(:,:,1,i)).and.i/=3) .or. (fp(i)<minval(farr(:,:,1,i)).and.i/=3)) then
! print*, 'linear_interpolate_cart_HO: interpolated value is smaller or larger than'
! print*, 'linear_interpolate_cart_HO: a values at the corner points, even after linearization!'
! print*, '------------------'
! linear_interpolate_cart_HO=.false.
! endif
! if (fp(i)/=fp(i)) then
! print*, 'linear_interpolate_cart_HO: interpolated value is NaN'
! print*, 'linear_interpolate_cart_HO: xxp=', xxp
! print*, 'linear_interpolate_cart_HO: x0, y0, z0=', &
! xglobal(ix0), yglobal(iy0), zglobal(iz0)
! print*, 'linear_interpolate_cart_HO: i, fp(i)=', i, fp(i)
! print*, 'linear_interpolate_cart_HO: farr=', farr(:,:,1,i)
! print*, '------------------'
! linear_interpolate_cart_HO=.false.
! endif
! enddo
! endif
!!
! endfunction linear_interpolate_cart_HO
!
!***********************************************************************
!
!! subroutine send_rcv_all_data(ivar1,ivar2,f_cartesian)
!!
!! ! Subroutine that exhanges all data in f-arrays, both for curvilinear and cartesian grid,
!! ! between all processors.
!! ! Very inefficient, but can be useful for testing.
!! ! Only works properly in 2D.
!! !
!! ! 30-sep-17/Jorgen: Coded
!!
!! use mpicomm, only: mpisend_int, mpisend_real, mpirecv_int, mpirecv_real, mpibcast_real
!! real, dimension (mx,my,mz,mfarray),intent(in) :: f_cartesian
!! integer, intent(in) :: ivar1,ivar2
!! real, dimension (nx_ogrid, ny_ogrid, nz_ogrid,ivar2-ivar1+1) :: fbuf_og
!! real, dimension (nx, ny, nz, ivar2-ivar1+1) :: fbuf_cg
!! real, dimension (nxgrid_ogrid, nygrid_ogrid, nzgrid_ogrid,ivar2-ivar1+1) :: fgrid_ogrid_tmp
!! real, dimension (nxgrid, nygrid, nzgrid,ivar2-ivar1+1) :: fgrid_cartesian_tmp
!! integer, dimension(4) :: nfbuf_og
!! integer, dimension(4) :: nfbuf_cg
!! integer, dimension(3) :: ipxyz
!! integer :: ixdo,ixup,iydo,iyup,izdo,izup
!! integer :: jx, iproc_recv
!! integer :: i,j
!!
!! nfbuf_og= (/ nxgrid_ogrid, nygrid_ogrid, nzgrid_ogrid,ivar2-ivar1+1/)
!! nfbuf_cg= (/ nxgrid, nygrid, nzgrid,ivar2-ivar1+1/)
!! !
!! if (iproc/=root) then
!! fbuf_og = f_ogrid(l1_ogrid:l2_ogrid,m1_ogrid:m2_ogrid,n1_ogrid:n2_ogrid,ivar1:ivar2)
!! fbuf_cg = f_cartesian(l1:l2,m1:m2,n1:n2,ivar1:ivar2)
!! call mpisend_int((/ipx,ipy,ipz/),3,root,111)
!! do i = 1,nx_ogrid
!! do j = 1,ny_ogrid
!! call mpisend_real(fbuf_og(i,j,:,:),nfbuf_og(3:4),root,i*ny_ogrid+j)
!! enddo
!! enddo
!! do i = 1,nx
!! do j = 1,ny
!! call mpisend_real(fbuf_cg(i,j,:,:),nfbuf_cg(3:4),root,i*ny_ogrid+j)
!! enddo
!! enddo
!! else
!! !
!! ! The root processor, in turn, receives the data from the others
!! !
!! do jx=0,ncpus-1
!! !avoid send-to-self
!! if (jx/=root) then
!! !
!! ! Formula of the serial processor number:
!! ! iproc=ipx+nprocx*ipy+nprocx*nprocy*ipz
!! ! Since for the x-row ipy=ipz=0, this reduces
!! ! to iproc_recv=jx.
!! !
!! iproc_recv=jx
!! call mpirecv_int(ipxyz,3,iproc_recv,111)
!! do i = 1,nx_ogrid
!! do j = 1,ny_ogrid
!! call mpirecv_real(fbuf_og(i,j,:,:),nfbuf_og(3:4),iproc_recv,i*ny_ogrid+j)
!! enddo
!! enddo
!! !call mpirecv_real(fbuf_og,nfbuf_og,iproc_recv,111)
!! do i = 1,nx
!! do j = 1,ny
!! call mpirecv_real(fbuf_cg(i,j,:,:),nfbuf_cg(3:4),iproc_recv,i*ny_ogrid+j)
!! enddo
!! enddo
!! !call mpirecv_real(fbuf_cg,nfbuf_cg,iproc_recv,112)
!! !
!! ixdo=ipxyz(1)*nx_ogrid+1
!! ixup=(ipxyz(1)+1)*nx_ogrid
!! iydo=ipxyz(2)*ny_ogrid+1
!! iyup=(ipxyz(2)+1)*ny_ogrid
!! izdo=ipxyz(3)*nz_ogrid+1
!! izup=(ipxyz(3)+1)*nz_ogrid
!!
!! fgrid_ogrid_tmp (ixdo:ixup,iydo:iyup,izdo:izup,ivar1:ivar2) = fbuf_og
!!
!! ixdo=ipxyz(1)*nx+1
!! ixup=(ipxyz(1)+1)*nx
!! iydo=ipxyz(2)*ny+1
!! iyup=(ipxyz(2)+1)*ny
!! izdo=ipxyz(3)*nz+1
!! izup=(ipxyz(3)+1)*nz
!! fgrid_cartesian_tmp(ixdo:ixup,iydo:iyup,izdo:izup,ivar1:ivar2) = fbuf_cg
!!
!! else
!! fgrid_ogrid_tmp(1:nx_ogrid,1:ny_ogrid,1:nz_ogrid,ivar1:ivar2) = &
!! f_ogrid(l1_ogrid:l2_ogrid,m1_ogrid:m2_ogrid,n1_ogrid:n2_ogrid,ivar1:ivar2)
!! fgrid_cartesian_tmp(1:nx,1:ny,1:nz,ivar1:ivar2) = &
!! f_cartesian(l1:l2,m1:m2,n1:n2,ivar1:ivar2)
!! endif
!! enddo
!! endif
!! if (iproc==root) then
!! fgrid_ogrid(nghost+1:mxgrid_ogrid-nghost,nghost+1:mygrid_ogrid-nghost, &
!! nghost+1:mzgrid_ogrid-nghost,ivar1:ivar2) = fgrid_ogrid_tmp
!! fgrid_cartesian(nghost+1:mxgrid-nghost,nghost+1:mygrid-nghost, &
!! nghost+1:mzgrid-nghost,ivar1:ivar2) = fgrid_cartesian_tmp
!! ! Ghosts cells x-direction
!! fgrid_ogrid(1:nghost,nghost+1:mygrid_ogrid-nghost, &
!! nghost+1:mzgrid_ogrid-nghost,ivar1:ivar2) = &
!! fgrid_ogrid_tmp(nxgrid_ogrid-nghost+1:nxgrid_ogrid,1:nygrid_ogrid, &
!! 1:nzgrid_ogrid,ivar1:ivar2)
!! fgrid_ogrid(mxgrid_ogrid-nghost+1:mxgrid_ogrid,nghost+1:mygrid_ogrid-nghost, &
!! nghost+1:mzgrid_ogrid-nghost,ivar1:ivar2) = &
!! fgrid_ogrid_tmp(1:nghost,1:nygrid_ogrid, &
!! 1:nzgrid_ogrid,ivar1:ivar2)
!! fgrid_cartesian(1:nghost,nghost+1:mygrid-nghost, &
!! nghost+1:mzgrid-nghost,ivar1:ivar2) = &
!! fgrid_cartesian_tmp(nxgrid-nghost+1:nxgrid,1:nygrid, &
!! 1:nzgrid,ivar1:ivar2)
!! fgrid_cartesian(mxgrid-nghost+1:mxgrid,nghost+1:mygrid-nghost, &
!! nghost+1:mzgrid-nghost,ivar1:ivar2) = &
!! fgrid_cartesian_tmp(1:nghost,1:nygrid, &
!! 1:nzgrid,ivar1:ivar2)
!! ! Ghosts cells y-direction
!! fgrid_ogrid(nghost+1:mxgrid_ogrid-nghost,1:nghost, &
!! nghost+1:mzgrid_ogrid-nghost,ivar1:ivar2) = &
!! fgrid_ogrid_tmp(1:nxgrid_ogrid,nygrid_ogrid-nghost+1:nygrid_ogrid, &
!! 1:nzgrid_ogrid,ivar1:ivar2)
!! fgrid_ogrid(nghost+1:mxgrid_ogrid-nghost,mygrid_ogrid-nghost+1:mygrid_ogrid, &
!! nghost+1:mzgrid_ogrid-nghost,ivar1:ivar2) = &
!! fgrid_ogrid_tmp(1:nxgrid_ogrid,1:nghost, &
!! 1:nzgrid_ogrid,ivar1:ivar2)
!! fgrid_cartesian(nghost+1:mxgrid-nghost,1:nghost, &
!! nghost+1:mzgrid-nghost,ivar1:ivar2) = &
!! fgrid_cartesian_tmp(1:nxgrid,nygrid-nghost+1:nygrid, &
!! 1:nzgrid,ivar1:ivar2)
!! fgrid_cartesian(nghost+1:mxgrid-nghost,mygrid-nghost+1:mygrid, &
!! nghost+1:mzgrid-nghost,ivar1:ivar2) = &
!! fgrid_cartesian_tmp(1:nxgrid,1:nghost, &
!! 1:nzgrid,ivar1:ivar2)
!! ! Ghosts cells z-direction (2D runs!)
!! fgrid_ogrid(nghost+1:mxgrid_ogrid-nghost,nghost+1:mygrid_ogrid-nghost, &
!! 1,ivar1:ivar2) = fgrid_ogrid_tmp(1:nxgrid_ogrid,1:nygrid_ogrid,1,ivar1:ivar2)
!! fgrid_ogrid(nghost+1:mxgrid_ogrid-nghost,nghost+1:mygrid_ogrid-nghost, &
!! 2,ivar1:ivar2) = fgrid_ogrid_tmp(1:nxgrid_ogrid,1:nygrid_ogrid,1,ivar1:ivar2)
!! fgrid_ogrid(nghost+1:mxgrid_ogrid-nghost,nghost+1:mygrid_ogrid-nghost, &
!! 3,ivar1:ivar2) = fgrid_ogrid_tmp(1:nxgrid_ogrid,1:nygrid_ogrid,1,ivar1:ivar2)
!! fgrid_ogrid(nghost+1:mxgrid_ogrid-nghost,nghost+1:mygrid_ogrid-nghost, &
!! 4,ivar1:ivar2) = fgrid_ogrid_tmp(1:nxgrid_ogrid,1:nygrid_ogrid,1,ivar1:ivar2)
!! fgrid_ogrid(nghost+1:mxgrid_ogrid-nghost,nghost+1:mygrid_ogrid-nghost, &
!! 5,ivar1:ivar2) = fgrid_ogrid_tmp(1:nxgrid_ogrid,1:nygrid_ogrid,1,ivar1:ivar2)
!! fgrid_ogrid(nghost+1:mxgrid_ogrid-nghost,nghost+1:mygrid_ogrid-nghost, &
!! 6,ivar1:ivar2) = fgrid_ogrid_tmp(1:nxgrid_ogrid,1:nygrid_ogrid,1,ivar1:ivar2)
!! fgrid_ogrid(nghost+1:mxgrid_ogrid-nghost,nghost+1:mygrid_ogrid-nghost, &
!! 7,ivar1:ivar2) = fgrid_ogrid_tmp(1:nxgrid_ogrid,1:nygrid_ogrid,1,ivar1:ivar2)
!! fgrid_cartesian(nghost+1:mxgrid-nghost,nghost+1:mygrid-nghost, &
!! 1,ivar1:ivar2) = fgrid_cartesian_tmp(1:nxgrid,1:nygrid,1,ivar1:ivar2)
!! fgrid_cartesian(nghost+1:mxgrid-nghost,nghost+1:mygrid-nghost, &
!! 2,ivar1:ivar2) = fgrid_cartesian_tmp(1:nxgrid,1:nygrid,1,ivar1:ivar2)
!! fgrid_cartesian(nghost+1:mxgrid-nghost,nghost+1:mygrid-nghost, &
!! 3,ivar1:ivar2) = fgrid_cartesian_tmp(1:nxgrid,1:nygrid,1,ivar1:ivar2)
!! fgrid_cartesian(nghost+1:mxgrid-nghost,nghost+1:mygrid-nghost, &
!! 4,ivar1:ivar2) = fgrid_cartesian_tmp(1:nxgrid,1:nygrid,1,ivar1:ivar2)
!! fgrid_cartesian(nghost+1:mxgrid-nghost,nghost+1:mygrid-nghost, &
!! 5,ivar1:ivar2) = fgrid_cartesian_tmp(1:nxgrid,1:nygrid,1,ivar1:ivar2)
!! fgrid_cartesian(nghost+1:mxgrid-nghost,nghost+1:mygrid-nghost, &
!! 6,ivar1:ivar2) = fgrid_cartesian_tmp(1:nxgrid,1:nygrid,1,ivar1:ivar2)
!! fgrid_cartesian(nghost+1:mxgrid-nghost,nghost+1:mygrid-nghost, &
!! 7,ivar1:ivar2) = fgrid_cartesian_tmp(1:nxgrid,1:nygrid,1,ivar1:ivar2)
!! endif
!!
!! nfbuf_og= (/ mxgrid_ogrid, mygrid_ogrid, mzgrid_ogrid,ivar2-ivar1+1/)
!! nfbuf_cg= (/ mxgrid, mygrid, mzgrid,ivar2-ivar1+1/)
!! call mpibcast_real(fgrid_ogrid, nfbuf_og, root)
!! call mpibcast_real(fgrid_cartesian, nfbuf_cg, root)
!! endsubroutine send_rcv_all_data
!***********************************************************************
! subroutine initialize_send_ip_points
!!
!! Build arrays of interpolation data on processors that contain data
!! necessary for interpolation on other processors.
!!
!! apr-17/Jorgen: Coded
!!
! use Mpicomm, only: mpirecv_int, mpisend_nonblock_int, mpibarrier, mpiwait
! use Solid_Cells_Mpicomm, only: finalize_isend_init_interpol
! integer :: i,iip,npoint
! integer, dimension(ncpus) :: from_proc_curv_to_cart=0
! integer, dimension(ncpus) :: from_proc_cart_to_curv=0
! integer, dimension(:,:,:), allocatable :: ind_from_proc_curv
! integer, dimension(:,:,:), allocatable :: ind_from_proc_cart
! integer, dimension(:,:), allocatable :: ip_id_curv_to_cart
! integer, dimension(:,:), allocatable :: ip_id_cart_to_curv
! integer, dimension(:), allocatable :: send_to_curv_to_cart
! integer, dimension(:), allocatable :: send_to_cart_to_curv
! integer, dimension(:,:), allocatable :: send_data_curv_to_cart
! integer, dimension(:,:), allocatable :: send_data_cart_to_curv
! integer, dimension(:), allocatable :: send_id_curv_to_cart
! integer, dimension(:), allocatable :: send_id_cart_to_curv
! integer :: max_from_proc, from_proc
! integer, dimension(2) :: nelements
! integer :: size_arr, npoints_requested
! integer, dimension(:), allocatable :: tmp_arr1D
! integer, dimension(:,:), allocatable :: tmp_arr2D
! integer :: nreq0D,nreq1D,nreq2D
! integer, dimension(ncpus-1) :: ireq0D,ireq1D
! integer, dimension(3*(ncpus-1)) :: ireq2D
! integer :: iter1,iter2
!! TODO: COULD THIS BE MOVED INTO SOLID_CELLS_OGRID_MPICOMM?
! if (n_ip_curv_to_cart>0) then
! do i=1,n_ip_curv_to_cart
! from_proc=curvilinear_to_cartesian(i)%from_proc
! if (from_proc/=iproc) then
!! Must access from_proc+1 instead of from_proc, to avoid accessing element 0
! from_proc_curv_to_cart(from_proc+1)=from_proc_curv_to_cart(from_proc+1)+1
! endif
! enddo
! endif
!!
! max_from_proc=maxval(from_proc_curv_to_cart)
! if (max_from_proc>0) then
! allocate(ind_from_proc_curv(ncpus,max_from_proc,3))
! allocate(ip_id_curv_to_cart(ncpus,max_from_proc))
! do iip=0,ncpus-1
! if (from_proc_curv_to_cart(iip+1)>0) then
! npoint=0
! do i=1,n_ip_curv_to_cart
! if (curvilinear_to_cartesian(i)%from_proc==iip) then
! npoint=npoint+1
!! Must access iip+1 instead of iip, to avoid accessing element 0
! ind_from_proc_curv(iip+1,npoint,:)=curvilinear_to_cartesian(i)%ind_global_neighbour
! ip_id_curv_to_cart(iip+1,npoint)=i
! endif
! enddo
! endif
! enddo
! endif
!!
! if (n_ip_cart_to_curv>0) then
! do i=1,n_ip_cart_to_curv
! from_proc=cartesian_to_curvilinear(i)%from_proc
! if (from_proc/=iproc) then
!! Must access from_proc+1 instead of from_proc, to avoid accessing element 0
! from_proc_cart_to_curv(from_proc+1)=from_proc_cart_to_curv(from_proc+1)+1
! endif
! enddo
! endif
!!
! max_from_proc=maxval(from_proc_cart_to_curv)
! if (max_from_proc>0) then
! allocate(ind_from_proc_cart(ncpus,max_from_proc,3))
! allocate(ip_id_cart_to_curv(ncpus,max_from_proc))
! do iip=0,ncpus-1
! if (from_proc_cart_to_curv(iip+1)>0) then
! npoint=0
! do i=1,n_ip_cart_to_curv
! if (cartesian_to_curvilinear(i)%from_proc==iip) then
! npoint=npoint+1
!! Must access iip+1 instead of iip, to avoid accessing element 0
! ind_from_proc_cart(iip+1,npoint,:)=cartesian_to_curvilinear(i)%ind_global_neighbour
! ip_id_cart_to_curv(iip+1,npoint)=i
! endif
! enddo
! endif
! enddo
! endif
!!
!! Arrays containing information about which points should be sent by what processor to this
!! processor has now been created. Now, there should be some communication to let all processors
!! know which grid points they should SEND and who should RECIEVE them.
!!
!! Note: Code is repeated twice in stead of being programmed as a function, since some compilers do
!! not support allocatable arrays as in/out from subroutines/functions
!! Use som variant of processor number as unique MPI tag (iip,iip+ncpus,etc.) in communication.
!!
!! Curvilinear to Cartesian
!!
! nreq0D=0
! nreq1D=0
! nreq2D=0
! do iip=0,ncpus-1
!! Send number of points requested from each processors, and send what points are requested
!! if the number of points is larger than zero.
!! Avoid sending to oneself
! if (iip/=iproc) then
! nreq0D=nreq0D+1
! call mpisend_nonblock_int(from_proc_curv_to_cart(iip+1),iip,iip,ireq0D(nreq0D))
! if (from_proc_curv_to_cart(iip+1)>0) then
! nelements=(/ from_proc_curv_to_cart(iip+1),3 /)
! do i=1,3
! nreq2D=nreq2D+1
! call mpisend_nonblock_int(ind_from_proc_curv(iip+1,1:nelements(1),i),nelements(1),iip,200+i,ireq2D(nreq2D))
! enddo
! nreq1D=nreq1D+1
! call mpisend_nonblock_int(ip_id_curv_to_cart(iip+1,1:nelements(1)),nelements(1),iip,iip+2*ncpus,ireq1D(nreq1D))
! endif
! endif
! enddo
! allocate(send_to_curv_to_cart(0))
! allocate(send_data_curv_to_cart(0,3))
! allocate(send_id_curv_to_cart(0))
! do iip=0,ncpus-1
!! Recieve data from all processors. If any points are requested, create array of request.
!! Avoid recieving from oneself
! if (iip/=iproc) then
! call mpirecv_int(npoints_requested,iip,iproc)
!! Allocation/deallocation in a very inefficient manner, but this is only done during pre-processing
!! so memory effieient code is a priority.
! if (npoints_requested>0) then
!! Expand array
! size_arr=size(send_to_curv_to_cart)
! allocate(tmp_arr1D(size_arr))
! tmp_arr1D = send_to_curv_to_cart
! deallocate(send_to_curv_to_cart)
! allocate(send_to_curv_to_cart(size_arr+npoints_requested))
! send_to_curv_to_cart(1:size_arr)=tmp_arr1D
! deallocate(tmp_arr1D)
! !
! send_to_curv_to_cart(size_arr+1:size_arr+npoints_requested)=iip
! nelements=(/ npoints_requested,3 /)
!! Expand array
! allocate(tmp_arr2D(size_arr,3))
! tmp_arr2D = send_data_curv_to_cart
! deallocate(send_data_curv_to_cart)
! allocate(send_data_curv_to_cart(size_arr+npoints_requested,3))
!
! send_data_curv_to_cart(1:size_arr,:)=tmp_arr2D
! deallocate(tmp_arr2D)
! do i=1,3
! call mpirecv_int(send_data_curv_to_cart(size_arr+1:size_arr+npoints_requested,i),nelements(1),iip,200+i)
! enddo
!! Expand array
! allocate(tmp_arr1D(size_arr))
! tmp_arr1D=send_id_curv_to_cart
! deallocate(send_id_curv_to_cart)
! allocate(send_id_curv_to_cart(size_arr+npoints_requested))
! send_id_curv_to_cart(1:size_arr)=tmp_arr1D
! deallocate(tmp_arr1D)
! call mpirecv_int(send_id_curv_to_cart(size_arr+1:size_arr+npoints_requested),npoints_requested,iip,iproc+2*ncpus)
! endif
! endif
! enddo
! do i=1,nreq0D
! call mpiwait(ireq0D(i))
! enddo
! do i=1,nreq1D
! call mpiwait(ireq1D(i))
! enddo
! do i=1,nreq2D
! call mpiwait(ireq2D(i))
! enddo
! call mpibarrier
! !call finalize_isend_init_interpol(ireq1D,ireq2D,nreq1D,nreq2D)
!!
!! Cartesian to curvilinear
!!
! nreq1D=0
! nreq2D=0
! do iip=0,ncpus-1
!! Send number of points requested from each processors, and send what points are requested
!! if the number of points is larger than zero.
!! Avoid sending to oneself
! if (iip/=iproc) then
! nreq1D=nreq1D+1
! call mpisend_nonblock_int(from_proc_cart_to_curv(iip+1),iip,iip+3*ncpus,ireq1D(nreq1D))
! if (from_proc_cart_to_curv(iip+1)>0) then
! nelements=(/ from_proc_cart_to_curv(iip+1),3 /)
! nreq2D=nreq2D+2
! call mpisend_nonblock_int(ind_from_proc_cart(iip+1,1:nelements(1),:),nelements,iip,iip+4*ncpus,ireq2D(nreq2D-1))
! call mpisend_nonblock_int(ip_id_cart_to_curv(iip+1,1:nelements(1)),nelements(1),iip,iip+5*ncpus,ireq2D(nreq2D))
! endif
! endif
! enddo
! allocate(send_to_cart_to_curv(0))
! allocate(send_data_cart_to_curv(0,3))
! allocate(send_id_cart_to_curv(0))
! do iip=0,ncpus-1
!! Recieve data from all processors. If any points are requested, create array of request.
!! Avoid recieving from oneself
! if (iip/=iproc) then
! call mpirecv_int(npoints_requested,iip,iproc+3*ncpus)
!! Allocation/deallocation in a very inefficient manner, but this is only done during pre-processing
!! so memory effieient code is a priority.
! if (npoints_requested>0) then
!! Expand array
! size_arr=size(send_to_cart_to_curv)
! allocate(tmp_arr1D(size_arr))
! tmp_arr1D = send_to_cart_to_curv
! deallocate(send_to_cart_to_curv)
! allocate(send_to_cart_to_curv(size_arr+npoints_requested))
! send_to_cart_to_curv(1:size_arr)=tmp_arr1D
! deallocate(tmp_arr1D)
! !
! send_to_cart_to_curv(size_arr+1:size_arr+npoints_requested)=iip
! nelements=(/ npoints_requested,3 /)
!! Expand array
! allocate(tmp_arr2D(size_arr,3))
! tmp_arr2D = send_data_cart_to_curv
! deallocate(send_data_cart_to_curv)
! allocate(send_data_cart_to_curv(size_arr+npoints_requested,3))
! send_data_cart_to_curv(1:size_arr,:)=tmp_arr2D
! deallocate(tmp_arr2D)
! call mpirecv_int(send_data_cart_to_curv(size_arr+1:size_arr+npoints_requested,:),nelements,iip,iproc+4*ncpus)
!! Expand array
! allocate(tmp_arr1D(size_arr))
! tmp_arr1D=send_id_cart_to_curv
! deallocate(send_id_cart_to_curv)
! allocate(send_id_cart_to_curv(size_arr+npoints_requested))
! send_id_cart_to_curv(1:size_arr)=tmp_arr1D
! deallocate(tmp_arr1D)
! call mpirecv_int(send_id_cart_to_curv(size_arr+1:size_arr+npoints_requested),npoints_requested,iip,iproc+5*ncpus)
! endif
! endif
! enddo
! call finalize_isend_init_interpol(ireq1D,ireq2D,nreq1D,nreq2D)
!!
!! Deallocate arrays not not needed later
!!
! if (allocated(ind_from_proc_curv)) deallocate(ind_from_proc_curv)
! if (allocated(ind_from_proc_cart)) deallocate(ind_from_proc_cart)
! if (allocated(ip_id_curv_to_cart)) deallocate(ip_id_curv_to_cart)
! if (allocated(ip_id_cart_to_curv)) deallocate(ip_id_cart_to_curv)
!!
!! Translate recieved global indices to local indices and save the module variables for communication
!!
! size_arr=size(send_data_curv_to_cart(:,1))
! allocate(send_curvilinear_to_cartesian(size_arr))
! do i=1,size_arr
! send_curvilinear_to_cartesian(i)%send_to_proc=send_to_curv_to_cart(i)
! send_curvilinear_to_cartesian(i)%ip_id=send_id_curv_to_cart(i)
! call ind_global_to_local_curv(send_data_curv_to_cart(i,:), &
! send_curvilinear_to_cartesian(i)%i_near_neighbour,lcheck_init_interpolation)
! enddo
! size_arr=size(send_data_cart_to_curv(:,1))
! allocate(send_cartesian_to_curvilinear(size_arr))
! do i=1,size_arr
! send_cartesian_to_curvilinear(i)%send_to_proc=send_to_cart_to_curv(i)
! send_cartesian_to_curvilinear(i)%ip_id=send_id_cart_to_curv(i)
! call ind_global_to_local_cart(send_data_cart_to_curv(i,:), &
! send_cartesian_to_curvilinear(i)%i_near_neighbour,lcheck_init_interpolation)
! enddo
!!
!! Set some auxiliary parameters to help with the interpolation communication
!! Global to module, not to proc
!!
! size_arr=size(send_data_curv_to_cart(:,1))
! n_procs_send_curv_to_cart=0
! if (size_arr>0) then
! n_procs_send_curv_to_cart=1
! do i=2,size_arr
! if (send_curvilinear_to_cartesian(i)%send_to_proc /= &
! send_curvilinear_to_cartesian(i-1)%send_to_proc) then
! n_procs_send_curv_to_cart=n_procs_send_curv_to_cart+1
! endif
! enddo
! endif
! allocate(n_ip_to_proc_curv_to_cart(n_procs_send_curv_to_cart))
! n_ip_to_proc_curv_to_cart=1
! do i=2,size_arr
! if (send_curvilinear_to_cartesian(i)%send_to_proc == &
! send_curvilinear_to_cartesian(i-1)%send_to_proc) then
! n_ip_to_proc_curv_to_cart=n_ip_to_proc_curv_to_cart+1
! endif
! enddo
! size_arr=size(send_data_cart_to_curv(:,1))
! n_procs_send_cart_to_curv=0
! if (size_arr>0) then
! n_procs_send_cart_to_curv=1
! do i=2,size_arr
! if (send_cartesian_to_curvilinear(i)%send_to_proc /= &
! send_cartesian_to_curvilinear(i-1)%send_to_proc) then
! n_procs_send_cart_to_curv=n_procs_send_cart_to_curv+1
! endif
! enddo
! endif
! allocate(n_ip_to_proc_cart_to_curv(n_procs_send_cart_to_curv))
! n_ip_to_proc_cart_to_curv=1
! do i=2,size_arr
! if (send_cartesian_to_curvilinear(i)%send_to_proc == &
! send_cartesian_to_curvilinear(i-1)%send_to_proc) then
! n_ip_to_proc_cart_to_curv=n_ip_to_proc_cart_to_curv+1
! endif
! enddo
!!
! n_procs_recv_curv_to_cart=count(from_proc_curv_to_cart.gt.0)
! n_procs_recv_cart_to_curv=count(from_proc_cart_to_curv.gt.0)
! allocate(n_ip_recv_proc_curv_to_cart(n_procs_recv_curv_to_cart))
! allocate(n_ip_recv_proc_cart_to_curv(n_procs_recv_cart_to_curv))
! n_ip_recv_proc_curv_to_cart=pack(from_proc_curv_to_cart,from_proc_curv_to_cart.gt.0)
! n_ip_recv_proc_cart_to_curv=pack(from_proc_cart_to_curv,from_proc_cart_to_curv.gt.0)
! allocate(procs_recv_curv_to_cart(n_procs_recv_curv_to_cart))
! allocate(procs_recv_cart_to_curv(n_procs_recv_cart_to_curv))
! iter1=1
! iter2=1
! do iip=0,ncpus-1
! if (from_proc_cart_to_curv(iip+1)>0) then
! procs_recv_cart_to_curv(iter1)=iip
! iter1=iter1+1
! endif
! if (from_proc_curv_to_cart(iip+1)>0) then
! procs_recv_curv_to_cart(iter2)=iip
! iter2=iter2+1
! endif
! enddo
! max_send_ip_curv_to_cart=maxval(n_ip_to_proc_curv_to_cart)
! max_recv_ip_curv_to_cart=maxval(n_ip_recv_proc_curv_to_cart)
! max_send_ip_cart_to_curv=maxval(n_ip_to_proc_cart_to_curv)
! max_recv_ip_cart_to_curv=maxval(n_ip_recv_proc_cart_to_curv)
!!
!! Deallocate arrays
!!
! deallocate(send_to_curv_to_cart)
! deallocate(send_to_cart_to_curv)
! deallocate(send_data_curv_to_cart)
! deallocate(send_data_cart_to_curv)
! deallocate(send_id_curv_to_cart)
! deallocate(send_id_cart_to_curv)
!!
!! Make sure that all processors complete this initialization before continuing
!!
! call mpibarrier
! endsubroutine initialize_send_ip_points
!!***********************************************************************
! subroutine comm_ip_curv_to_cart_alt(f_cartesian,ivar1,ivar2)
!!
!! Send and recieve necessary information to perform interpolation from
!! the curvilinear to the cartesian grid.
!! This version of the communication between grids is optimized for the case
!! where all processors have a part of the ogrid, and not all processors have
!! parts of the cartesian grid near the ogrid. Hence, we want as much as
!! possible to be done with the data before passing it from the curvilinear
!! to the cartesian grid
!!
!! 02-okt-17/Jorgen: Coded
!!
! use Mpicomm, only: mpisend_nonblock_int,mpisend_nonblock_real,mpirecv_int,mpirecv_real,mpiwait,mpibarrier
! real, dimension(mx,my,mz,mfarray), intent(inout) :: f_cartesian
! integer, intent(in) :: ivar1,ivar2
! integer, dimension(n_procs_send_curv_to_cart) :: ireq1D, ireq5D
! integer, dimension(5) :: nbuf_farr
! integer, dimension(max_recv_ip_curv_to_cart) :: id_bufi
! real, dimension(ivar2-ivar1+1,max_send_ip_curv_to_cart) :: f_bufo
! real, dimension(ivar2-ivar1+1,max_recv_ip_curv_to_cart) :: f_bufi
! real, dimension(inter_len,inter_len,inter_len,ivar2-ivar1+1) :: farr
! integer :: i,j,k,id,ipp
! integer :: ii1,ii2,jj1,jj2,kk1,kk2
! integer :: iter, send_to, recv_from
! integer, dimension(3) :: inear_loc
! integer, dimension(3) :: inear_glob
! integer :: ind_send_first, ind_send_last, ind_recv_first, ind_recv_last
! integer, dimension(max_send_ip_curv_to_cart) :: ip_bufo
! integer :: ind, ipoly
! real, dimension(3) :: xyz_ip
!!
! if (interpolation_method==1) then
! ii1=0; ii2=1; jj1=0; jj2=1; kk1=0; kk2=1
! elseif (interpolation_method==2 .or. interpolation_method==3) then
! ii1=1; ii2=1; jj1=1; jj2=1; kk1=1; kk2=1
! ! elseif (interpolation_method==4) then
! ! ii1=2; ii2=2; jj1=2; jj2=2; kk1=2; kk2=2
! elseif (interpolation_method==5) then
! ipoly=floor((interpol_order_poly)*0.5)
! ii1=ipoly; ii2=ipoly; jj1=ipoly; jj2=ipoly; kk1=ipoly; kk2=ipoly
! elseif (mod(interpolation_method,2)==0) then
! ii1=interpolation_method/2; ii2=ii1; jj1=ii1; jj2=ii1; kk1=ii1; kk2=ii1
! endif
! nbuf_farr(5)=ivar2-ivar1+1
!!
!! Before sending data, interpolate. Only send interpolated f-data
!!
! ind_send_first=1
! do iter=1,n_procs_send_curv_to_cart
! ind_send_last=n_ip_to_proc_curv_to_cart(iter)+ind_send_first-1
! send_to=send_curvilinear_to_cartesian(ind_send_last)%send_to_proc
! nbuf_farr(5)=ind_send_last-ind_send_first+1
! do ipp=1,nbuf_farr(5)
! ind=ind_send_first+ipp-1
! i=send_curvilinear_to_cartesian(ind)%i_near_neighbour(1)
! j=send_curvilinear_to_cartesian(ind)%i_near_neighbour(2)
! k=send_curvilinear_to_cartesian(ind)%i_near_neighbour(3)
! farr(:,:,:,:)=f_ogrid(i-ii1:i+ii2,j-jj1:j+jj2,k-kk1:k+kk2,ivar1:ivar2)
!!
!! Need global coordinates for interpolation.
!!
! inear_glob=send_curvilinear_to_cartesian(ind)%i_global_neighbour
! xyz_ip=send_curvilinear_to_cartesian(ind)%xyz
! call interp_point_curv_to_cart_alt(xyz_ip,inear_glob,ivar1,ivar2,farr,f_bufo(:,ipp))
! enddo
! ip_bufo(1:nbuf_farr(5)) = send_curvilinear_to_cartesian(ind_send_first:ind_send_last)%ip_id
! call mpisend_nonblock_int(ip_bufo(1:nbuf_farr(5)),nbuf_farr(5),send_to,send_to,ireq1D(iter))
! call mpisend_nonblock_real(f_bufo(:,1:nbuf_farr(5)),nbuf_farr,send_to,send_to+ncpus,ireq5D(iter))
! ind_send_first=ind_send_last+1
! enddo
! ind_recv_first=1
! do iter=1,n_procs_recv_curv_to_cart
! ind_recv_last=n_ip_recv_proc_curv_to_cart(iter)
! recv_from=procs_recv_curv_to_cart(iter)
! nbuf_farr(5)=ind_recv_last-ind_recv_first+1
! call mpirecv_int(id_bufi(1:nbuf_farr(5)),nbuf_farr(5),recv_from,iproc)
! call mpirecv_real(f_bufi(:,1:nbuf_farr(5)),nbuf_farr,recv_from,iproc+ncpus)
! do ipp=1,nbuf_farr(5)
! call transform_curv_to_cart(f_bufi(:,ipp),f_cartesian,id_bufi(ipp),ivar1,ivar2)
! enddo
! enddo
!!
!! Interpolate remaining points
!!
! do id=1,n_ip_curv_to_cart
! if (curvilinear_to_cartesian(id)%from_proc==iproc) then
! inear_loc=curvilinear_to_cartesian(id)%ind_local_neighbour
! farr(:,:,:,:)=f_ogrid(inear_loc(1)-ii1:inear_loc(1)+ii2, &
! inear_loc(2)-jj1:inear_loc(2)+jj2,inear_loc(3)-kk1:inear_loc(3)+kk2,ivar1:ivar2)
! call interpolate_point_curv_to_cart(f_cartesian,id,ivar1,ivar2,farr)
! endif
! enddo
!!
!! Finalize nonblocking sends
!!
! do iter=1,n_procs_send_curv_to_cart
! call mpiwait(ireq1D(iter))
! call mpiwait(ireq5D(iter))
! enddo
! call mpibarrier
!!
! endsubroutine comm_ip_curv_to_cart_alt
!!***********************************************************************
! logical function interp_lagrange4(farr_in,ivar1,ivar2,xxp,inear_glob,fp,lcart_to_curv,lcurv_to_cart,lcheck)
!
!! Interpolate the value of f to (xp, yp) CURVILINEAR coordinate
!! using the fourth-order lagrangian interpolation.
!
!! TODO: Extend to 3D
!! TODO: Adjust nearest point to be ACTUALLY NEAREST, not bottom left corner
!! Needed due to asymetric stencil
!
!! The coefficients are determined by the 5x5 grid points surrounding the
!! interpolation point.
!! Global coordinates are used for the interpolation, to allow interpolation of
!! values outside this processors domain.
!
!! 28-sep-17/Jorgen: Coded
!
! integer :: ivar1, ivar2
! real, dimension (3) :: xxp
! real, dimension (5,5,5,ivar2-ivar1+1) :: farr_in
! !TODO
! real, dimension (-2:2,-2:2,ivar2-ivar1+1) :: farr
! real, dimension (ivar2-ivar1+1) :: fp
! integer, dimension (3) :: inear_glob
! logical :: lcart_to_curv, lcurv_to_cart, lcheck
!
! intent(in) :: farr_in, ivar1, ivar2, xxp, inear_glob, lcheck, lcart_to_curv, lcurv_to_cart
! intent(out) :: fp
!
! real, dimension(-2:2) :: xglob, yglob
! real :: dx_2_1,dx_20,dx_21,dx_22,dx_1_2,dx_10,dx_11,dx_12,dx0_2,dx0_1, &
! dx01,dx02,dx1_2,dx1_1,dx10,dx12,dx2_2,dx2_1,dx20,dx21
! real :: deltax_2,deltax_1,deltax0,deltax1,deltax2
! real :: dy_2_1,dy_20,dy_21,dy_22,dy_1_2,dy_10,dy_11,dy_12,dy0_2,dy0_1, &
! dy01,dy02,dy1_2,dy1_1,dy10,dy12,dy2_2,dy2_1,dy20,dy21
! real :: deltay_2,deltay_1,deltay0,deltay1,deltay2
! real :: lag_2,lag_1,lag0,lag1,lag2
! real, dimension(-2:2,ivar2-ivar1+1) :: g_2,g_1,g0,g1,g2
! real, dimension(-2:2,ivar2-ivar1+1) :: gp
! integer :: i,ix0,ix1,iy0,iy1
!
! interp_lagrange4= .true.
! farr(:,:,:) = farr_in(:,:,3,:)
!
!! Get grid points
!!
! if (lcart_to_curv) then
! xglob(-2:2) = xglobal(inear_glob(1)-2:inear_glob(1)+2)
! yglob(-2:2) = yglobal(inear_glob(2)-2:inear_glob(2)+2)
! elseif (lcurv_to_cart) then
! xglob(-2:2) = xglobal_ogrid(inear_glob(1)-2:inear_glob(1)+2)
! yglob(-2:2) = yglobal_ogrid(inear_glob(2)-2:inear_glob(2)+2)
! else
! print*,'interp_lagrange4:Not interpolated to any specific grid!'
! interp_lagrange4= .false.
! return
! endif
!!
!! Compute distance from xxp to surrounding grid points
!! Needed for checking that inear_glob is correct, and for lagrange polynomials
!!
! deltax_2 = xxp(1)-xglob(-2)
! deltax_1 = xxp(1)-xglob(-1)
! deltax0 = xxp(1)-xglob( 0)
! deltax1 = xxp(1)-xglob( 1)
! deltax2 = xxp(1)-xglob( 2)
!!
! deltay_2 = xxp(2)-yglob(-2)
! deltay_1 = xxp(2)-yglob(-1)
! deltay0 = xxp(2)-yglob( 0)
! deltay1 = xxp(2)-yglob( 1)
! deltay2 = xxp(2)-yglob( 2)
!!
!! Check that inear_glob actually points to the grid point closest to xxp
!!
! if (lcheck) then
! if ((abs(deltax0)<=min(abs(deltax_2),abs(deltax_1),abs(deltax1),abs(deltax2))) .or. &
! (abs(deltay0)<=min(abs(deltay_2),abs(deltay_1),abs(deltay1),abs(deltay2)))) then
! ! Everything okay
! else
! print*, 'interp_lagrange4: Interpolation point does not lie closest to center grid point.'
! print*, 'ix0, iy0, iz0 = ', inear_glob(1:3)
! print*, 'xp, xglob(-2:2) = ', xxp(1), xglob
! print*, 'yp, yglob(-2:2) = ', xxp(2), yglob
! interp_lagrange4= .false.
! return
! endif
! endif
!!
!! Interpolate in x-direction
!!
!! Compute distances
!!
! dx_2_1=xglob(-2)-xglob(-1)
! dx_20 =xglob(-2)-xglob( 0)
! dx_21 =xglob(-2)-xglob( 1)
! dx_22 =xglob(-2)-xglob( 2)
!
! dx_1_2=-dx_2_1
! dx_10 =xglob(-1)-xglob( 0)
! dx_11 =xglob(-1)-xglob( 1)
! dx_12 =xglob(-1)-xglob( 2)
!
! dx0_2 =-dx_20
! dx0_1 =-dx_10
! dx01 =xglob( 0)-xglob( 1)
! dx02 =xglob( 0)-xglob( 2)
!
! dx1_2 =-dx_21
! dx1_1 =-dx_11
! dx10 =-dx01
! dx12 =xglob( 1)-xglob( 2)
!
! dx2_2 =-dx_22
! dx2_1 =-dx_12
! dx20 =-dx02
! dx21 =-dx12
!!
!! Compute products of x-x_k/(x_i-x_k) for (i!=k)
!!
! lag_2 = (deltax_1/dx_2_1)*(deltax0 /dx_20)*(deltax1/dx_21)*(deltax2/dx_22)
! lag_1 = (deltax_2/dx_1_2)*(deltax0 /dx_10)*(deltax1/dx_11)*(deltax2/dx_12)
! lag0 = (deltax_2/dx0_2 )*(deltax_1/dx0_1)*(deltax1/dx01 )*(deltax2/dx02 )
! lag1 = (deltax_2/dx1_2 )*(deltax_1/dx1_1)*(deltax0/dx10 )*(deltax2/dx12 )
! lag2 = (deltax_2/dx2_2 )*(deltax_1/dx2_1)*(deltax0/dx20 )*(deltax1/dx21 )
!
! g_2 = farr(-2,:,:)
! g_1 = farr(-1,:,:)
! g0 = farr( 0,:,:)
! g1 = farr( 1,:,:)
! g2 = farr( 2,:,:)
!!
!! Interpolate points in x-direction
!!
! do i=ivar1,ivar2
! gp(:,i) = lag_2*g_2(:,i)+lag_1*g_1(:,i)+lag0*g0(:,i)+lag1*g1(:,i)+lag2*g2(:,i)
! enddo
! !gp = lag_2*g_2 + lag_1*g_1 + lag0*g0 + lag1*g1 * lag2*g2
!!
!! Interpolate in y-direction
!!
!! Compute distances
!!
! dy_2_1=yglob(-2)-yglob(-1)
! dy_20 =yglob(-2)-yglob( 0)
! dy_21 =yglob(-2)-yglob( 1)
! dy_22 =yglob(-2)-yglob( 2)
!
! dy_1_2=-dy_2_1
! dy_10 =yglob(-1)-yglob( 0)
! dy_11 =yglob(-1)-yglob( 1)
! dy_12 =yglob(-1)-yglob( 2)
!
! dy0_2 =-dy_20
! dy0_1 =-dy_10
! dy01 =yglob( 0)-yglob( 1)
! dy02 =yglob( 0)-yglob( 2)
!
! dy1_2 =-dy_21
! dy1_1 =-dy_11
! dy10 =-dy01
! dy12 =yglob( 1)-yglob( 2)
!
! dy2_2 =-dy_22
! dy2_1 =-dy_12
! dy20 =-dy02
! dy21 =-dy12
!!
!! Compute products of x-x_k/(x_i-x_k) for (i!=k)
!!
! lag_2 = (deltay_1/dy_2_1)*(deltay0 /dy_20)*(deltay1/dy_21)*(deltay2/dy_22)
! lag_1 = (deltay_2/dy_1_2)*(deltay0 /dy_10)*(deltay1/dy_11)*(deltay2/dy_12)
! lag0 = (deltay_2/dy0_2 )*(deltay_1/dy0_1)*(deltay1/dy01 )*(deltay2/dy02 )
! lag1 = (deltay_2/dy1_2 )*(deltay_1/dy1_1)*(deltay0/dy10 )*(deltay2/dy12 )
! lag2 = (deltay_2/dy2_2 )*(deltay_1/dy2_1)*(deltay0/dy20 )*(deltay1/dy21 )
!!
!! Interpolate points in y-direction
!!
! do i=ivar1,ivar2
! fp(i) = lag_2*gp(-2,i)+lag_1*gp(-1,i)+lag0*gp(0,i)+lag1*gp(1,i)+lag2*gp(2,i)
! enddo
! !fp = lag_2*gp(-2,:)+lag_1*gp(-1,:)+lag0*gp(0,:)+lag1*gp(1,:)+lag2*gp(2,:)
!
! if (lcheck) then
! do i=1,ivar2-ivar1+1
! if ((fp(i)>maxval(farr(:,:,i)).and.i/=3) .or. (fp(i)<minval(farr(:,:,i)).and.i/=3)) then
!!
!! Compensate for overshoots by linear interpolation
!!
! ix0=0; ix1=1; iy0=0; iy1=1
! if (xglob(0)>xxp(1)) then
! ix0=2; ix1=3
! else
! ix0=3; ix1=4
! endif
! if (yglob(0)>xxp(2)) then
! iy0=2; iy1=3
! else
! iy0=3; iy1=4
! endif
! if (lcart_to_curv) then
! interp_lagrange4= linear_interpolate_cartesian(farr_in(ix0:ix1,iy0:iy1,3:4,i),i,i,xxp, &
! (/inear_glob(1)+ix0-3,inear_glob(2)+iy0-3,inear_glob(3)/),&
! gp(0,i),lcheck_interpolation)
! else
! interp_lagrange4= linear_interpolate_curvilinear(farr_in(ix0:ix1,iy0:iy1,3:4,i),i,i,xxp, &
! (/inear_glob(1)+ix0-3,inear_glob(2)+iy0-3,inear_glob(3)/),&
! gp(0,i),lcheck_interpolation)
! endif
!!
! fp(i)=gp(0,i)
! endif
! if (fp(i)/=fp(i)) then
! print*, 'interp_interpolate: interpolated value is NaN'
! print*, 'interp_interpolate: xxp=', xxp
! print*, 'interp_interpolate: i, fp(i)=', i, fp(i)
! print*, '------------------'
! interp_lagrange4=.false.
! endif
! enddo
! endif
!!
! endfunction interp_lagrange4
!***********************************************************************
! logical function HO_interp_curv_loc(farr,ivar1,ivar2,xxp,inear_glob,inear_loc,fp,lcheck,order)
!!
!! Interpolate the value of f to arbitrary (xp, yp) CURVILINEAR coordinate
!! using the high-order lagrangian interpolation.
!!
!! The coefficients are determined by the 2xN grid points surrounding the
!! interpolation point.
!!
!! TEST VERSION: ONLY APPLICABLE FOR SERIAL RUNS
!!
!! 21-may-17/Jorgen: Adapted from linear_interpolate_curvilinear_HO
!!
! integer :: ivar1, ivar2
! integer, intent(in) :: order
! real, dimension (3) :: xxp
! real, dimension (ivar2-ivar1+1) :: fp
! real, dimension (order,order,ivar2-ivar1+1) :: farr
! integer, dimension (3) :: inear_glob, inear_loc
! logical :: lcheck
!!
! intent(in) :: farr, ivar1, ivar2, xxp, inear_glob, inear_loc, lcheck
! intent(out) :: fp
!!
! integer :: i,ix0,iy0,iz0
! real :: x0,y0,xN,yN,dx,dy,dxN,dyN,xp,yp
!
! real, dimension(order,ivar2-ivar1+1) :: gp
! integer :: j
!!
!! Determine index value of lowest lying corner point of grid box surrounding
!! the interpolation point.
!!
! HO_interp_curv_loc=.true.
!!
! ix0=inear_glob(1); iy0=inear_glob(2); iz0=inear_glob(3)
!!
!! Check if the grid point interval is really correct.
!!
! if ((xglobal_ogrid(ix0)<=xxp(1) .and. xglobal_ogrid(ix0+1)>=xxp(1) .or. nxgrid==1) .and. &
! (yglobal_ogrid(iy0)<=xxp(2) .and. yglobal_ogrid(iy0+1)>=xxp(2) .or. nygrid==1) .and. &
! (zglobal_ogrid(iz0)<=xxp(3) .and. zglobal_ogrid(iz0+1)>=xxp(3) .or. nzgrid==1)) then
! ! Everything okay
! else
! print*, 'HO_interp_curv_loc: Global interpolation point does not ' // &
! 'lie within the calculated grid point interval.'
! print*, 'iproc = ', iproc_world
! print*, 'mxgrid_ogrid, xglobal_ogrid(1), xglobal_ogrid(mxgrid_ogrid) = ', &
! mxgrid_ogrid, xglobal_ogrid(1), xglobal_ogrid(mxgrid_ogrid)
! print*, 'mygrid_ogrid, yglobal_ogrid(1), yglobal_ogrid(mygrid_ogrid) = ', &
! mygrid_ogrid, yglobal_ogrid(1), yglobal_ogrid(mygrid_ogrid)
! print*, 'mzgrid_ogrid, zglobal_ogrid(1), zglobal_ogrid(mzgrid_ogrid) = ', &
! mzgrid_ogrid, zglobal_ogrid(1), zglobal_ogrid(mzgrid_ogrid)
! print*, 'ix0, iy0, iz0 = ', ix0, iy0, iz0
! print*, 'xp, xp0, xp1 = ', xxp(1), xglobal_ogrid(ix0), xglobal_ogrid(ix0+1)
! print*, 'yp, yp0, yp1 = ', xxp(2), yglobal_ogrid(iy0), yglobal_ogrid(iy0+1)
! print*, 'zp, zp0, zp1 = ', xxp(3), zglobal_ogrid(iz0), zglobal_ogrid(iz0+1)
! HO_interp_curv_loc=.false.
! return
! endif
! if ((xglobal_ogrid(ix0)-x_ogrid(inear_loc(1))<10.e-10 ).or. &
! (yglobal_ogrid(iy0)-y_ogrid(inear_loc(2))<10.e-10 )) then
! ! Everything okay
! else
! print*, 'HO_interp_curv_loc: Global and local interpolation point values do not match'
! print*, 'GLOBAL:'
! print*, 'ix0, iy0, iz0 = ', ix0, iy0, iz0
! print*, 'xp, xp0, xp1 = ', xxp(1), xglobal_ogrid(ix0), xglobal_ogrid(ix0+1)
! print*, 'yp, yp0, yp1 = ', xxp(2), yglobal_ogrid(iy0), yglobal_ogrid(iy0+1)
! print*, 'zp, zp0, zp1 = ', xxp(3), zglobal_ogrid(iz0), zglobal_ogrid(iz0+1)
! print*, 'LOCAL:'
! print*, 'ix0, iy0, iz0 = ', ix0, iy0, iz0
! print*, 'xp, xp0, xp1 = ', xxp(1), x_ogrid(inear_loc(1)), x_ogrid(inear_loc(1)+1)
! print*, 'yp, yp0, yp1 = ', xxp(2), y_ogrid(inear_loc(2)), y_ogrid(inear_loc(2)+1)
! print*, 'zp, zp0, zp1 = ', xxp(3), z_ogrid(inear_loc(3)), z_ogrid(inear_loc(3)+1)
! print*, 'DIFF:'
! print*, 'xglobal_ogrid(ix0)-x_ogrid(inear_loc(1)) =', xglobal_ogrid(ix0)-x_ogrid(inear_loc(1))
! print*, 'yglobal_ogrid(iy0)-y_ogrid(inear_loc(2)) =', yglobal_ogrid(iy0)-y_ogrid(inear_loc(2))
! HO_interp_curv_loc=.false.
! return
! endif
!!
!! Mapping to quadratic area with corners at (0,0) -- (1,1)
!!
! x0 = xglobal_ogrid(ix0-floor(0.5*order)+1)
! y0 = yglobal_ogrid(iy0-floor(0.5*order)+1)
! xN = xglobal_ogrid(ix0+floor(0.5*order))
! yN = yglobal_ogrid(iy0+floor(0.5*order))
!!
! dx = xglobal_ogrid(ix0+1)-xglobal_ogrid(ix0)
! dy = yglobal_ogrid(iy0+1)-yglobal_ogrid(iy0)
!!
!! Check that gridspacing is correct
!!
! if ((xN-x0 - (order-1)*dx)<10.e-10 .and. (yN-y0 - (order-1)*dy)<10.e-10) then
! !Do nothing
! else
! print*, 'HO_interp_curv_loc: Grid spacing error'
! print*, 'x0, x1, xN = ', x0,xglobal_ogrid(ix0-floor(0.5*order)+2),xN
! print*, 'dx, N*dx,xN-x0 = ', dx,(order-1)*dx,xN-x0
! print*, 'y0, y1, yN = ', y0,yglobal_ogrid(iy0-floor(0.5*order)+2),yN
! print*, 'dy, N*dy, yN-y0 = ', dy,(order-1)*dy, yN-y0
! endif
!!
! dxN = dx*(order-1)
! dyN = dy*(order-1)
! xp = (xxp(1)-x0)/dxN
! yp = (xxp(2)-y0)/dyN
! x0 = 0.
! y0 = 0.
! xN = 1.
! yN = 1.
! dx = 1./(order-1)
! dy = 1./(order-1)
!
! do i=1,order
! call lagrange1D(farr(:,i,:),ivar1,ivar2,yp,y0,dy,order,gp(i,:))
! enddo
! call lagrange1D(gp,ivar1,ivar2,xp,x0,dx,order,fp)
!
!!
!! Do a reality check on the interpolation scheme.
!!
! if (lcheck) then
! do i=1,2!ivar2-ivar1+1
! if (((fp(i)>maxval(farr(:,:,i)).and.i/=3) .or. (fp(i)<minval(farr(:,:,i)).and.i/=3)).and.ix0>floor(nx_ogrid*0.5)) then
! print*, 'linear_interpolate_curvilinear_HO: interpolated value is smaller or larger than'
! print*, 'linear_interpolate_curvilinear_HO: a values at the corner points, even after linearization!'
! print*, 'linear_interpolate_curvilinear: xxp=', xxp
! print*, 'linear_interpolate_curvilinear: ix0, iy0, iz0=', ix0,iy0,iz0
! print*, 'linear_interpolate_curvilinear: x0, y0, z0=', &
! xglobal_ogrid(ix0), yglobal_ogrid(iy0), zglobal_ogrid(iz0)
! print*, 'linear_interpolate_curvilinear: i, fp(i)=', i, fp(i)
! print*, 'linear_interpolate_curvilinear: farr=', farr(:,:,i)
! print*, '------------------'
! print*, 'DETAILS:'
! do j=1,order
! print*, 'j,x(j)',ix0-floor(0.5*order)+1+j-1,xglobal_ogrid(ix0-floor(0.5*order)+1+j-1)
! print*, 'j,y(j)',iy0-floor(0.5*order)+1+j-1,yglobal_ogrid(iy0-floor(0.5*order)+1+j-1)
! print*, 'farr(j,:,1)',farr(j,:,1)
! print*, 'farr(j,:,2)',farr(j,:,2)
! enddo
! print*, '------------------'
! HO_interp_curv_loc=.false.
! endif
! if (fp(i)/=fp(i)) then
! print*, 'linear_interpolate_curvilinear: interpolated value is NaN'
! print*, 'linear_interpolate_curvilinear: xxp=', xxp
! print*, 'linear_interpolate_curvilinear: x0, y0, z0=', &
! xglobal_ogrid(ix0), yglobal_ogrid(iy0), zglobal_ogrid(iz0)
! print*, 'linear_interpolate_curvilinear: i, fp(i)=', i, fp(i)
! print*, 'linear_interpolate_curvilinear: farr=', farr(:,:,i)
! print*, '------------------'
! HO_interp_curv_loc=.false.
! endif
! enddo
! endif
!!
! endfunction HO_interp_curv_loc
!!
!!***********************************************************************
! subroutine lagrange1D(farr,ivar1,ivar2,xp,x0,dx,order,fp)
!!
! integer, intent(in) :: ivar1, ivar2
! integer, intent(in) :: order
! real, dimension(order,ivar2-ivar1+1), intent(in) :: farr
! real, intent(in) :: xp, x0, dx
!!
! real, dimension (ivar2-ivar1+1), intent(out) :: fp
!!
! real, dimension(order) :: l
! real :: xi
! integer :: i,j,ivar
! l = 1.
! do i=1,order
! xi = x0+dx*(i-1)
! do j=1,order
! if (i/=j) then
! l(i) = l(i)*(xp-(x0+dx*(j-1)))/(xi-(x0+dx*(j-1)))
! endif
! enddo
! enddo
! fp=0.
! do ivar=ivar1,ivar2
! do i=1,order
! fp(ivar)=fp(ivar)+l(i)*farr(i,ivar)
! enddo
! enddo
!!
! endsubroutine lagrange1D
!!***********************************************************************
! subroutine flow_cartesian_to_curvilinear(f_cartesian,f_og)
!
! use General, only: linear_interpolate
!!
!! Interpolate all flow variables from cartesian to curvilinear grid
!! Only need to do this for the radial direction
!!
!! Find position in (x,y,z)-coordinates from (r,theta,z)-system
!! Use this to interpolate (linearly) from nearest neighbours
!! Only works for iux:iuz and scalar values (rho,T,etc.) at present.
!!
!! NOTE: Does not work for parallell runs
!! should only be used for testing purposes
!!
!! 16-feb-17/Jorgen: Coded
!!
! real, dimension (mx,my,mz,mfarray) :: f_cartesian
! real, dimension (mx_ogrid,my_ogrid,mz_ogrid,mfarray) :: f_og
! real, dimension (3) :: xyz
! integer :: ivar1,ivar2
! integer, dimension (3) :: inear
! real, dimension (mvar) :: gp
! integer :: i,j,k
!!
! ivar1=1
! ivar2=mvar
! do k=n1_ogrid,n2_ogrid
! do j=m1_ogrid,m2_ogrid
! do i=l2_ogrid+1,l2_ogrid+nghost
! xyz=(/ x_ogrid(i)*cos(y_ogrid(j))+xorigo_ogrid(1), &
! x_ogrid(i)*sin(y_ogrid(j))+xorigo_ogrid(2), &
! z_ogrid(k) /)
! call find_near_ind_local_cart(inear,xyz,lcheck_interpolation)
!
! if ( .not. linear_interpolate(f_cartesian,ivar1,ivar2,xyz,gp,inear,lcheck_interpolation) ) then
! call fatal_error('linear_interpolate','interpolation from cartesian to curvilinear')
! endif
! f_og(i,j,k,iux)=gp(iux)*cos(y_ogrid(j))+gp(iuy)*sin(y_ogrid(j))
! f_og(i,j,k,iuy)=-gp(iux)*sin(y_ogrid(j))+gp(iuy)*cos(y_ogrid(j))
! f_og(i,j,k,iuz)=gp(iuz)
! f_og(i,j,k,irho)=gp(irho)
! enddo
! enddo
! enddo
!
! endsubroutine flow_cartesian_to_curvilinear
!!***********************************************************************
! subroutine flow_curvilinear_to_cartesian(f_cartesian)
!!
!! Interpolate all flow variables from curvilinear to cartesian grid
!!
!! NOTE: Does not work for parallell runs,
!! should only be used for testing purposes
!!
! real, dimension (mx,my,mz,mfarray) :: f_cartesian
! real, dimension (3) :: rthz
! integer :: i,j,k
! integer, dimension (3) :: inear
! real, dimension (mvar) :: gp
! integer, parameter :: ivar1=1,ivar2=mvar
!
! do k=n1,n2
! do j=m1,m2
! do i=l1,l2
! call get_polar_coords(x(i),y(j),z(k),rthz)
! if ((rthz(1)<=r_int_outer) .and.(rthz(1)>r_int_inner)) then
! call find_near_ind_local_curv(inear,rthz,lcheck_interpolation)
! if ( .not. linear_interpolate_ogrid(ivar1,ivar2,rthz,gp,inear,lcheck_interpolation) ) then
! call fatal_error('linear_interpolate_ogrid','interpolation from curvilinear to cartesian')
! endif
! f_cartesian(i,j,k,iux)=gp(iux)*cos(rthz(2))-gp(iuy)*sin(rthz(2))
! f_cartesian(i,j,k,iuy)=gp(iux)*sin(rthz(2))+gp(iuy)*cos(rthz(2))
! f_cartesian(i,j,k,iuz:ivar2)=gp(iuz:ivar2)
! endif
! enddo
! enddo
! enddo
!!
! endsubroutine flow_curvilinear_to_cartesian
!***********************************************************************
subroutine sc_init_diag_accum
!
! Need to initialize accumulators since master thread does not take part in diagnostics
! Dummy for solid cells ogrid
!
! 25-aug-23/TP: Coded
!
endsubroutine sc_init_diag_accum
!***********************************************************************
subroutine sc_diags_reductions
!
! Reduces accumulated diagnostic variables across threads. Only called if using OpenMP
! Dummy for solid cells ogrid
!
! 30-mar-23/TP: coded
!
endsubroutine sc_diags_reductions
!***********************************************************************
subroutine sc_init_reduc_pointers
!
! Initiliazes solid_cells specific pointers needed in thread_reductions
! Dummy for solid cells ogrid
!
! 30-mar-23/TP: Coded
!
endsubroutine sc_init_reduc_pointers
!***********************************************************************
endmodule solid_cells