Merge branch 'master' into reconnection
This commit is contained in:
commit
5d6fff5407
1013
src/blocks.F90
1013
src/blocks.F90
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -143,8 +143,7 @@ module domains
|
||||
use blocks , only : metablock_set_configuration
|
||||
use blocks , only : metablock_set_coordinates, metablock_set_bounds
|
||||
use blocks , only : nsides, nfaces
|
||||
use boundaries , only : xlbndry, ylbndry, zlbndry
|
||||
use boundaries , only : xubndry, yubndry, zubndry
|
||||
use boundaries , only : bnd_type, bnd_periodic
|
||||
use coordinates , only : xmin, xmax, ymin, ymax, zmin, zmax
|
||||
use coordinates , only : ir, jr, kr
|
||||
|
||||
@ -349,7 +348,7 @@ module domains
|
||||
|
||||
! if periodic boundary conditions set edge block neighbors
|
||||
!
|
||||
if (xlbndry == 'periodic' .and. xubndry == 'periodic') then
|
||||
if (bnd_type(1,1) == bnd_periodic .and. bnd_type(1,2) == bnd_periodic) then
|
||||
do k = 1, kr
|
||||
do j = 1, jr
|
||||
|
||||
@ -395,7 +394,7 @@ module domains
|
||||
|
||||
! if periodic boundary conditions set edge block neighbors
|
||||
!
|
||||
if (ylbndry == 'periodic' .and. yubndry == 'periodic') then
|
||||
if (bnd_type(2,1) == bnd_periodic .and. bnd_type(2,2) == bnd_periodic) then
|
||||
do k = 1, kr
|
||||
do i = 1, ir
|
||||
|
||||
@ -442,7 +441,7 @@ module domains
|
||||
|
||||
! if periodic boundary conditions set edge block neighbors
|
||||
!
|
||||
if (zlbndry == 'periodic' .and. zubndry == 'periodic') then
|
||||
if (bnd_type(3,1) == bnd_periodic .and. bnd_type(3,2) == bnd_periodic) then
|
||||
do j = 1, jr
|
||||
do i = 1, ir
|
||||
|
||||
|
||||
@ -81,7 +81,7 @@ program amun
|
||||
!
|
||||
integer, dimension(3) :: div = 1
|
||||
logical, dimension(3) :: per = .true.
|
||||
integer :: nmax = 0, ndat = 1
|
||||
integer :: nmax = huge(1), ndat = 1
|
||||
real :: tmax = 0.0d+00, trun = 9.999d+03, tsav = 3.0d+01
|
||||
real(kind=8) :: dtnext = 0.0d+00
|
||||
|
||||
|
||||
@ -605,7 +605,8 @@ module equations
|
||||
|
||||
! include external procedures and variables
|
||||
!
|
||||
use coordinates, only : im, jm, km
|
||||
use coordinates, only : im, jm, km, in, jn, kn
|
||||
use coordinates, only : ib, jb, kb, ie, je, ke
|
||||
|
||||
! local variables are not implicit by default
|
||||
!
|
||||
@ -618,29 +619,21 @@ module equations
|
||||
|
||||
! temporary variables
|
||||
!
|
||||
integer :: j, k
|
||||
|
||||
! temporary array to store conserved variable vector
|
||||
!
|
||||
real(kind=8), dimension(nv,im) :: u
|
||||
integer :: j, k
|
||||
!
|
||||
!-------------------------------------------------------------------------------
|
||||
!
|
||||
! update primitive variables
|
||||
!
|
||||
do k = 1, km
|
||||
do j = 1, jm
|
||||
|
||||
! copy variables to temporary array of conserved variables
|
||||
!
|
||||
u(1:nv,1:im) = uu(1:nv,1:im,j,k)
|
||||
do k = kb, ke
|
||||
do j = jb, je
|
||||
|
||||
! convert conserved variables to primitive ones
|
||||
!
|
||||
call cons2prim(im, u(1:nv,1:im), qq(1:nv,1:im,j,k))
|
||||
call cons2prim(in, uu(1:nv,ib:ie,j,k), qq(1:nv,ib:ie,j,k))
|
||||
|
||||
end do ! j = 1, jm
|
||||
end do ! k = 1, km
|
||||
end do ! j = jb, je
|
||||
end do ! k = kb, ke
|
||||
|
||||
!-------------------------------------------------------------------------------
|
||||
!
|
||||
|
||||
@ -249,14 +249,14 @@ module evolution
|
||||
!
|
||||
call update_mesh()
|
||||
|
||||
! update boundaries
|
||||
!
|
||||
call boundary_variables()
|
||||
|
||||
! update primitive variables
|
||||
!
|
||||
call update_variables()
|
||||
|
||||
! update boundaries
|
||||
!
|
||||
call boundary_variables()
|
||||
|
||||
! set all meta blocks to be updated
|
||||
!
|
||||
call set_blocks_update(.true.)
|
||||
@ -467,14 +467,14 @@ module evolution
|
||||
|
||||
end do
|
||||
|
||||
! update boundaries
|
||||
!
|
||||
call boundary_variables()
|
||||
|
||||
! update primitive variables
|
||||
!
|
||||
call update_variables()
|
||||
|
||||
! update boundaries
|
||||
!
|
||||
call boundary_variables()
|
||||
|
||||
!-------------------------------------------------------------------------------
|
||||
!
|
||||
end subroutine evolve_euler
|
||||
@ -552,14 +552,14 @@ module evolution
|
||||
|
||||
end do
|
||||
|
||||
! update boundaries
|
||||
!
|
||||
call boundary_variables()
|
||||
|
||||
! update primitive variables
|
||||
!
|
||||
call update_variables()
|
||||
|
||||
! update boundaries
|
||||
!
|
||||
call boundary_variables()
|
||||
|
||||
! update fluxes for the second step of the RK2 integration
|
||||
!
|
||||
call update_fluxes()
|
||||
@ -598,14 +598,14 @@ module evolution
|
||||
|
||||
end do
|
||||
|
||||
! update boundaries
|
||||
!
|
||||
call boundary_variables()
|
||||
|
||||
! update primitive variables
|
||||
!
|
||||
call update_variables()
|
||||
|
||||
! update boundaries
|
||||
!
|
||||
call boundary_variables()
|
||||
|
||||
!-------------------------------------------------------------------------------
|
||||
!
|
||||
end subroutine evolve_rk2
|
||||
|
||||
1957
src/io.F90
1957
src/io.F90
File diff suppressed because it is too large
Load Diff
112
src/mesh.F90
112
src/mesh.F90
@ -462,6 +462,9 @@ module mesh
|
||||
use blocks , only : link_blocks, unlink_blocks, refine_block
|
||||
use blocks , only : get_mblocks, get_nleafs
|
||||
use blocks , only : set_neighbors_refine
|
||||
#ifdef DEBUG
|
||||
use blocks , only : check_neighbors
|
||||
#endif /* DEBUG */
|
||||
use coordinates , only : minlev, maxlev
|
||||
use domains , only : setup_domain
|
||||
use error , only : print_error
|
||||
@ -735,6 +738,12 @@ module mesh
|
||||
|
||||
end do ! pmeta
|
||||
|
||||
#ifdef DEBUG
|
||||
! check if neighbors are consistent after mesh generation
|
||||
!
|
||||
call check_neighbors()
|
||||
#endif /* DEBUG */
|
||||
|
||||
#ifdef PROFILE
|
||||
! stop accounting time for the initial mesh generation
|
||||
!
|
||||
@ -768,6 +777,9 @@ module mesh
|
||||
use blocks , only : refine_block, derefine_block
|
||||
use blocks , only : append_datablock, remove_datablock, link_blocks
|
||||
use blocks , only : set_neighbors_refine
|
||||
#ifdef DEBUG
|
||||
use blocks , only : check_neighbors
|
||||
#endif /* DEBUG */
|
||||
use coordinates , only : minlev, maxlev, toplev, im, jm, km
|
||||
use equations , only : nv
|
||||
use error , only : print_error
|
||||
@ -819,12 +831,6 @@ module mesh
|
||||
call start_timer(imu)
|
||||
#endif /* PROFILE */
|
||||
|
||||
#ifdef DEBUG
|
||||
! check the mesh when debugging
|
||||
!
|
||||
call check_mesh('before update_mesh')
|
||||
#endif /* DEBUG */
|
||||
|
||||
!! DETERMINE THE REFINEMENT OF ALL DATA BLOCKS
|
||||
!!
|
||||
! set the pointer to the first block on the data block list
|
||||
@ -1264,9 +1270,9 @@ module mesh
|
||||
#endif /* MPI */
|
||||
|
||||
#ifdef DEBUG
|
||||
! check mesh
|
||||
! check if neighbors are consistent after mesh refinement
|
||||
!
|
||||
call check_mesh('after update_mesh')
|
||||
call check_neighbors()
|
||||
#endif /* DEBUG */
|
||||
|
||||
#ifdef PROFILE
|
||||
@ -1359,92 +1365,98 @@ module mesh
|
||||
!
|
||||
do while (associated(pmeta))
|
||||
|
||||
! consider only meta blocks which belong to active processes
|
||||
!
|
||||
if (pmeta%process < nprocs) then
|
||||
|
||||
! check if the block belongs to another process
|
||||
!
|
||||
if (pmeta%process /= np) then
|
||||
if (pmeta%process /= np) then
|
||||
|
||||
! check if the block is the leaf
|
||||
!
|
||||
if (pmeta%leaf) then
|
||||
if (pmeta%leaf) then
|
||||
|
||||
! generate a tag for communication
|
||||
!
|
||||
itag = pmeta%process * nprocs + np + nprocs + 1
|
||||
itag = pmeta%process * nprocs + np + nprocs + 1
|
||||
|
||||
! sends the block to the right process
|
||||
!
|
||||
if (nproc == pmeta%process) then
|
||||
if (nproc == pmeta%process) then
|
||||
|
||||
! copy data to buffer
|
||||
!
|
||||
rbuf(1,:,:,:,:) = pmeta%data%u(:,:,:,:)
|
||||
rbuf(2,:,:,:,:) = pmeta%data%q(:,:,:,:)
|
||||
rbuf(1,:,:,:,:) = pmeta%data%u(:,:,:,:)
|
||||
rbuf(2,:,:,:,:) = pmeta%data%q(:,:,:,:)
|
||||
|
||||
! send data
|
||||
!
|
||||
call send_real_array(size(rbuf), np, itag, rbuf, iret)
|
||||
call send_real_array(size(rbuf), np, itag, rbuf, iret)
|
||||
|
||||
! remove data block from the current process
|
||||
!
|
||||
call remove_datablock(pmeta%data)
|
||||
call remove_datablock(pmeta%data)
|
||||
|
||||
! send data block
|
||||
!
|
||||
end if ! nproc == pmeta%process
|
||||
end if ! nproc == pmeta%process
|
||||
|
||||
! receive the block from another process
|
||||
!
|
||||
if (nproc == np) then
|
||||
if (nproc == np) then
|
||||
|
||||
! allocate a new data block and link it with the current meta block
|
||||
!
|
||||
call append_datablock(pdata)
|
||||
call link_blocks(pmeta, pdata)
|
||||
call append_datablock(pdata)
|
||||
call link_blocks(pmeta, pdata)
|
||||
|
||||
! receive the data
|
||||
!
|
||||
call receive_real_array(size(rbuf), pmeta%process, itag, rbuf, iret)
|
||||
call receive_real_array(size(rbuf), pmeta%process, itag, rbuf, iret)
|
||||
|
||||
! coppy the buffer to data block
|
||||
!
|
||||
pmeta%data%u(:,:,:,:) = rbuf(1,:,:,:,:)
|
||||
pmeta%data%q(:,:,:,:) = rbuf(2,:,:,:,:)
|
||||
pmeta%data%u(:,:,:,:) = rbuf(1,:,:,:,:)
|
||||
pmeta%data%q(:,:,:,:) = rbuf(2,:,:,:,:)
|
||||
|
||||
end if ! nproc == n
|
||||
end if ! nproc == n
|
||||
|
||||
end if ! leaf
|
||||
end if ! leaf
|
||||
|
||||
! set new processor number
|
||||
!
|
||||
pmeta%process = np
|
||||
pmeta%process = np
|
||||
|
||||
end if ! pmeta%process /= np
|
||||
end if ! pmeta%process /= np
|
||||
|
||||
! increase the number of blocks on the current process; if it exceeds the
|
||||
! allowed number reset the counter and increase the processor number
|
||||
!
|
||||
if (pmeta%leaf) then
|
||||
if (pmeta%leaf) then
|
||||
|
||||
! increase the number of leafs for the current process
|
||||
!
|
||||
nl = nl + 1
|
||||
nl = nl + 1
|
||||
|
||||
! if the number of leafs for the current process exceeds the number of assigned
|
||||
! blocks, reset the counter and increase the process number
|
||||
!
|
||||
if (nl >= lb(np)) then
|
||||
if (nl >= lb(np)) then
|
||||
|
||||
! reset the leaf counter for the current process
|
||||
!
|
||||
nl = 0
|
||||
nl = 0
|
||||
|
||||
! increase the process number
|
||||
!
|
||||
np = min(nprocs - 1, np + 1)
|
||||
np = min(nprocs - 1, np + 1)
|
||||
|
||||
end if ! l >= lb(n)
|
||||
end if ! l >= lb(n)
|
||||
|
||||
end if ! leaf
|
||||
end if ! leaf
|
||||
|
||||
end if ! pmeta%process < nprocs
|
||||
|
||||
! assign the pointer to the next meta block
|
||||
!
|
||||
@ -1502,7 +1514,7 @@ module mesh
|
||||
integer :: i, j, k, q, p
|
||||
integer :: il, iu, jl, ju, kl, ku
|
||||
integer :: ic, jc, kc, ip, jp, kp
|
||||
real :: dul, dur, dux, duy, duz
|
||||
real :: dul, dur, dux, duy, duz, du1, du2, du3, du4
|
||||
|
||||
! local pointers
|
||||
!
|
||||
@ -1586,21 +1598,27 @@ module mesh
|
||||
#endif /* NDIMS == 3 */
|
||||
|
||||
#if NDIMS == 2
|
||||
u(p,ic,jc,kc) = pdata%u(p,i,j,k) - (dux + duy)
|
||||
u(p,ip,jc,kc) = pdata%u(p,i,j,k) + (dux - duy)
|
||||
u(p,ic,jp,kc) = pdata%u(p,i,j,k) + (duy - dux)
|
||||
u(p,ip,jp,kc) = pdata%u(p,i,j,k) + (dux + duy)
|
||||
du1 = dux + duy
|
||||
du2 = dux - duy
|
||||
u(p,ic,jc,kc) = pdata%u(p,i,j,k) - du1
|
||||
u(p,ip,jc,kc) = pdata%u(p,i,j,k) + du2
|
||||
u(p,ic,jp,kc) = pdata%u(p,i,j,k) - du2
|
||||
u(p,ip,jp,kc) = pdata%u(p,i,j,k) + du1
|
||||
#endif /* NDIMS == 2 */
|
||||
|
||||
#if NDIMS == 3
|
||||
u(p,ic,jc,kc) = pdata%u(p,i,j,k) - dux - duy - duz
|
||||
u(p,ip,jc,kc) = pdata%u(p,i,j,k) + dux - duy - duz
|
||||
u(p,ic,jp,kc) = pdata%u(p,i,j,k) - dux + duy - duz
|
||||
u(p,ip,jp,kc) = pdata%u(p,i,j,k) + dux + duy - duz
|
||||
u(p,ic,jc,kp) = pdata%u(p,i,j,k) - dux - duy + duz
|
||||
u(p,ip,jc,kp) = pdata%u(p,i,j,k) + dux - duy + duz
|
||||
u(p,ic,jp,kp) = pdata%u(p,i,j,k) - dux + duy + duz
|
||||
u(p,ip,jp,kp) = pdata%u(p,i,j,k) + dux + duy + duz
|
||||
du1 = dux + duy + duz
|
||||
du2 = dux - duy - duz
|
||||
du3 = dux - duy + duz
|
||||
du4 = dux + duy - duz
|
||||
u(p,ic,jc,kc) = pdata%u(p,i,j,k) - du1
|
||||
u(p,ip,jc,kc) = pdata%u(p,i,j,k) + du2
|
||||
u(p,ic,jp,kc) = pdata%u(p,i,j,k) - du3
|
||||
u(p,ip,jp,kc) = pdata%u(p,i,j,k) + du4
|
||||
u(p,ic,jc,kp) = pdata%u(p,i,j,k) - du4
|
||||
u(p,ip,jc,kp) = pdata%u(p,i,j,k) + du3
|
||||
u(p,ic,jp,kp) = pdata%u(p,i,j,k) - du2
|
||||
u(p,ip,jp,kp) = pdata%u(p,i,j,k) + du1
|
||||
#endif /* NDIMS == 3 */
|
||||
end do
|
||||
end do
|
||||
|
||||
@ -141,7 +141,7 @@ module mpitools
|
||||
stop
|
||||
end if
|
||||
|
||||
! obtain the current process identificator
|
||||
! obtain the current process identifier
|
||||
!
|
||||
call mpi_comm_rank(mpi_comm_world, nproc , iret)
|
||||
|
||||
|
||||
225
src/problems.F90
225
src/problems.F90
@ -131,6 +131,9 @@ module problems
|
||||
case("blast")
|
||||
setup_problem => setup_problem_blast
|
||||
|
||||
case("implosion")
|
||||
setup_problem => setup_problem_implosion
|
||||
|
||||
case("kh", "kelvinhelmholtz", "kelvin-helmholtz")
|
||||
setup_problem => setup_problem_kelvin_helmholtz
|
||||
|
||||
@ -510,6 +513,228 @@ module problems
|
||||
!
|
||||
!===============================================================================
|
||||
!
|
||||
! subroutine SETUP_PROBLEM_IMPLOSION:
|
||||
! ----------------------------------
|
||||
!
|
||||
! Subroutine sets the initial conditions for the implosion problem.
|
||||
!
|
||||
! Arguments:
|
||||
!
|
||||
! pdata - pointer to the datablock structure of the currently initialized
|
||||
! block;
|
||||
!
|
||||
!===============================================================================
|
||||
!
|
||||
subroutine setup_problem_implosion(pdata)
|
||||
|
||||
! include external procedures and variables
|
||||
!
|
||||
use blocks , only : block_data, ndims
|
||||
use constants , only : d2r
|
||||
use coordinates, only : im, jm, km
|
||||
use coordinates, only : ax, ay, az, adx, ady, adz
|
||||
use equations , only : prim2cons
|
||||
use equations , only : nv
|
||||
use equations , only : idn, ivx, ivy, ivz, ipr, ibx, iby, ibz, ibp
|
||||
use parameters , only : get_parameter_real
|
||||
|
||||
! local variables are not implicit by default
|
||||
!
|
||||
implicit none
|
||||
|
||||
! input arguments
|
||||
!
|
||||
type(block_data), pointer, intent(inout) :: pdata
|
||||
|
||||
! default parameter values
|
||||
!
|
||||
real(kind=8), save :: sline = 1.50d-01
|
||||
real(kind=8), save :: adens = 1.00d+00
|
||||
real(kind=8), save :: apres = 1.00d+00
|
||||
real(kind=8), save :: drat = 1.25d-01
|
||||
real(kind=8), save :: prat = 1.40d-01
|
||||
real(kind=8), save :: buni = 1.00d+00
|
||||
real(kind=8), save :: bgui = 0.00d+00
|
||||
real(kind=8), save :: angle = 0.00d+00
|
||||
|
||||
! local saved parameters
|
||||
!
|
||||
logical , save :: first = .true.
|
||||
real(kind=8), save :: odens = 1.25d-01
|
||||
real(kind=8), save :: opres = 1.40d-01
|
||||
|
||||
! local variables
|
||||
!
|
||||
integer :: i, j, k
|
||||
real(kind=8) :: rl, ru, dx, dy, dz, dxh, dyh, dzh, ds, dl, dr
|
||||
real(kind=8) :: sn, cs
|
||||
|
||||
! local arrays
|
||||
!
|
||||
real(kind=8), dimension(nv,im) :: q, u
|
||||
real(kind=8), dimension(im) :: x, xl, xu
|
||||
real(kind=8), dimension(jm) :: y, yl, yu
|
||||
real(kind=8), dimension(km) :: z, zl, zu
|
||||
!
|
||||
!-------------------------------------------------------------------------------
|
||||
!
|
||||
#ifdef PROFILE
|
||||
! start accounting time for the problem setup
|
||||
!
|
||||
call start_timer(imu)
|
||||
#endif /* PROFILE */
|
||||
|
||||
! prepare problem constants during the first subroutine call
|
||||
!
|
||||
if (first) then
|
||||
|
||||
! get problem parameters
|
||||
!
|
||||
call get_parameter_real("shock_line" , sline )
|
||||
call get_parameter_real("ambient_density" , adens )
|
||||
call get_parameter_real("ambient_pressure", apres )
|
||||
call get_parameter_real("density_ratio" , drat )
|
||||
call get_parameter_real("pressure_ratio" , prat )
|
||||
call get_parameter_real("buni" , buni )
|
||||
call get_parameter_real("bgui" , bgui )
|
||||
call get_parameter_real("angle" , angle )
|
||||
|
||||
! calculate parameters
|
||||
!
|
||||
odens = drat * adens
|
||||
opres = prat * apres
|
||||
|
||||
! reset the first execution flag
|
||||
!
|
||||
first = .false.
|
||||
|
||||
end if ! first call
|
||||
|
||||
! prepare block coordinates
|
||||
!
|
||||
x(1:im) = pdata%meta%xmin + ax(pdata%meta%level,1:im)
|
||||
y(1:jm) = pdata%meta%ymin + ay(pdata%meta%level,1:jm)
|
||||
#if NDIMS == 3
|
||||
z(1:km) = pdata%meta%zmin + az(pdata%meta%level,1:km)
|
||||
#endif /* NDIMS == 3 */
|
||||
|
||||
! calculate mesh intervals and areas
|
||||
!
|
||||
dx = adx(pdata%meta%level)
|
||||
dy = ady(pdata%meta%level)
|
||||
#if NDIMS == 3
|
||||
dz = adz(pdata%meta%level)
|
||||
#endif /* NDIMS == 3 */
|
||||
dxh = 0.5d+00 * dx
|
||||
dyh = 0.5d+00 * dy
|
||||
#if NDIMS == 3
|
||||
dzh = 0.5d+00 * dz
|
||||
#endif /* NDIMS == 3 */
|
||||
|
||||
! calculate edge coordinates
|
||||
!
|
||||
xl(:) = abs(x(:)) - dxh
|
||||
xu(:) = abs(x(:)) + dxh
|
||||
yl(:) = abs(y(:)) - dyh
|
||||
yu(:) = abs(y(:)) + dyh
|
||||
#if NDIMS == 3
|
||||
zl(:) = abs(z(:)) - dzh
|
||||
zu(:) = abs(z(:)) + dzh
|
||||
#endif /* NDIMS == 3 */
|
||||
|
||||
! reset velocity components
|
||||
!
|
||||
q(ivx,:) = 0.0d+00
|
||||
q(ivy,:) = 0.0d+00
|
||||
q(ivz,:) = 0.0d+00
|
||||
|
||||
! if magnetic field is present, set it to be uniform with the desired strength
|
||||
! and orientation
|
||||
!
|
||||
if (ibx > 0) then
|
||||
|
||||
! calculate the orientation angles
|
||||
!
|
||||
sn = sin(d2r * angle)
|
||||
cs = sqrt(1.0d+00 - sn * sn)
|
||||
|
||||
! set magnetic field components
|
||||
!
|
||||
q(ibx,:) = buni * cs
|
||||
q(iby,:) = buni * sn
|
||||
q(ibz,:) = bgui
|
||||
q(ibp,:) = 0.0d+00
|
||||
|
||||
end if
|
||||
|
||||
! iterate over all positions
|
||||
!
|
||||
do k = 1, km
|
||||
do j = 1, jm
|
||||
do i = 1, im
|
||||
|
||||
! calculate the distance from the origin
|
||||
!
|
||||
#if NDIMS == 3
|
||||
rl = xl(i) + yl(j) + zl(k)
|
||||
ru = xu(i) + yu(j) + zu(k)
|
||||
#else /* NDIMS == 3 */
|
||||
rl = xl(i) + yl(j)
|
||||
ru = xu(i) + yu(j)
|
||||
#endif /* NDIMS == 3 */
|
||||
|
||||
! initialize density and pressure
|
||||
!
|
||||
if (ru <= sline) then
|
||||
q(idn,i) = odens
|
||||
if (ipr > 0) q(ipr,i) = opres
|
||||
else if (rl >= sline) then
|
||||
q(idn,i) = adens
|
||||
if (ipr > 0) q(ipr,i) = apres
|
||||
else
|
||||
ds = (sline - rl) / dx
|
||||
if (ds <= 1.0d+00) then
|
||||
dl = 5.0d-01 * ds**ndims
|
||||
dr = 1.0d+00 - dl
|
||||
else
|
||||
ds = (ru - sline) / dx
|
||||
dr = 5.0d-01 * ds**ndims
|
||||
dl = 1.0d+00 - dr
|
||||
end if
|
||||
|
||||
q(idn,i) = adens * dl + odens * dr
|
||||
if (ipr > 0) q(ipr,i) = apres * dl + opres * dr
|
||||
end if
|
||||
|
||||
end do ! i = 1, im
|
||||
|
||||
! convert the primitive variables to conservative ones
|
||||
!
|
||||
call prim2cons(im, q(1:nv,1:im), u(1:nv,1:im))
|
||||
|
||||
! copy the conserved variables to the current block
|
||||
!
|
||||
pdata%u(1:nv,1:im,j,k) = u(1:nv,1:im)
|
||||
|
||||
! copy the primitive variables to the current block
|
||||
!
|
||||
pdata%q(1:nv,1:im,j,k) = q(1:nv,1:im)
|
||||
|
||||
end do ! j = 1, jm
|
||||
end do ! k = 1, km
|
||||
|
||||
#ifdef PROFILE
|
||||
! stop accounting time for the problems setup
|
||||
!
|
||||
call stop_timer(imu)
|
||||
#endif /* PROFILE */
|
||||
|
||||
!-------------------------------------------------------------------------------
|
||||
!
|
||||
end subroutine setup_problem_implosion
|
||||
!
|
||||
!===============================================================================
|
||||
!
|
||||
! subroutine SETUP_PROBLEM_KELVIN_HELMHOLTZ:
|
||||
! -----------------------------------------
|
||||
!
|
||||
|
||||
@ -214,6 +214,11 @@ module random
|
||||
!
|
||||
integer , intent(in) :: np
|
||||
integer(kind=4), dimension(0:np-1), intent(in) :: seed
|
||||
|
||||
! local variables
|
||||
!
|
||||
integer :: i, l
|
||||
real :: r
|
||||
!
|
||||
!-------------------------------------------------------------------------------
|
||||
!
|
||||
@ -225,10 +230,34 @@ module random
|
||||
|
||||
! set the seeds only if the input array and seeds have the same sizes
|
||||
!
|
||||
if (np .eq. nseeds) then
|
||||
if (np == nseeds) then
|
||||
|
||||
seeds(0:lseed) = seed(0:lseed)
|
||||
|
||||
else
|
||||
|
||||
! if the input array and seeds have different sizes, expand or shrink seeds
|
||||
!
|
||||
select case(gentype)
|
||||
case('random')
|
||||
l = min(lseed, np - 1)
|
||||
seeds(0:l) = seed(0:l)
|
||||
if (l < lseed) then
|
||||
do i = l + 1, lseed
|
||||
call random_number(r)
|
||||
seeds(i) = 123456789 * r
|
||||
end do
|
||||
end if
|
||||
case default
|
||||
l = nseeds / 2
|
||||
do i = 0, l - 1
|
||||
seeds(i) = seed(0)
|
||||
end do
|
||||
do i = l, lseed
|
||||
seeds(i) = seed(np-1)
|
||||
end do
|
||||
end select
|
||||
|
||||
end if
|
||||
|
||||
#ifdef PROFILE
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user