2008-11-11 16:12:26 -06:00
|
|
|
!!*****************************************************************************
|
|
|
|
!!
|
|
|
|
!! module: mesh - handling adaptive mesh structure
|
|
|
|
!!
|
|
|
|
!! Copyright (C) 2008 Grzegorz Kowal <kowal@astro.wisc.edu>
|
|
|
|
!!
|
|
|
|
!!*****************************************************************************
|
|
|
|
!!
|
|
|
|
!! This file is part of Godunov-AMR.
|
|
|
|
!!
|
|
|
|
!! Godunov-AMR is free software; you can redistribute it and/or modify
|
|
|
|
!! it under the terms of the GNU General Public License as published by
|
|
|
|
!! the Free Software Foundation; either version 3 of the License, or
|
|
|
|
!! (at your option) any later version.
|
|
|
|
!!
|
|
|
|
!! Godunov-AMR is distributed in the hope that it will be useful,
|
|
|
|
!! but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
|
!! GNU General Public License for more details.
|
|
|
|
!!
|
|
|
|
!! You should have received a copy of the GNU General Public License
|
|
|
|
!! along with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
!!
|
|
|
|
!!*****************************************************************************
|
|
|
|
!!
|
|
|
|
!
|
|
|
|
module mesh
|
|
|
|
|
|
|
|
implicit none
|
|
|
|
|
2008-12-09 14:51:33 -06:00
|
|
|
! minimum grid step
|
|
|
|
!
|
|
|
|
real, save :: dx_min = 1.0
|
|
|
|
|
2009-05-18 22:46:19 +02:00
|
|
|
! spatial coordinates for all levels of refinements
|
2008-12-08 20:03:01 -06:00
|
|
|
!
|
|
|
|
real, dimension(:,:), allocatable, save :: ax , ay , az
|
|
|
|
real, dimension(: ), allocatable, save :: adx , ady , adz
|
|
|
|
real, dimension(: ), allocatable, save :: adxi, adyi, adzi
|
|
|
|
|
2008-11-11 16:12:26 -06:00
|
|
|
contains
|
|
|
|
!
|
2008-12-13 15:08:18 -06:00
|
|
|
!===============================================================================
|
2008-11-11 16:12:26 -06:00
|
|
|
!
|
|
|
|
! init_mesh: subroutine initializes mesh by creating blocks according
|
|
|
|
! to the geometry, initial problem and refinement criterium
|
|
|
|
!
|
2008-12-13 15:08:18 -06:00
|
|
|
!===============================================================================
|
2008-11-11 16:12:26 -06:00
|
|
|
!
|
|
|
|
subroutine init_mesh
|
|
|
|
|
2008-12-22 16:08:51 -06:00
|
|
|
use config , only : im, jm, km, xmin, xmax, ymin, ymax, zmin, zmax &
|
|
|
|
, ncells, maxlev
|
2008-12-22 14:57:31 -06:00
|
|
|
use blocks , only : list_allocated, init_blocks, clear_blocks &
|
2008-12-28 13:09:14 -06:00
|
|
|
, deallocate_block, refine_block, get_pointer &
|
2009-05-18 22:46:19 +02:00
|
|
|
, block, nchild, ndims, plist, last_id, nblocks, nleafs
|
2008-12-28 13:09:14 -06:00
|
|
|
use error , only : print_info, print_error
|
|
|
|
use mpitools, only : is_master, ncpu, ncpus
|
2008-12-22 16:08:51 -06:00
|
|
|
use problem , only : init_domain, init_problem, check_ref
|
2008-11-11 16:12:26 -06:00
|
|
|
|
|
|
|
implicit none
|
|
|
|
|
|
|
|
! local variables
|
|
|
|
!
|
2008-12-28 13:09:14 -06:00
|
|
|
type(block), pointer :: pblock, pparent, pchild, pneigh, pnext
|
2008-12-06 20:11:36 -06:00
|
|
|
integer(kind=4) :: l, p, i, j, k, n
|
2008-12-07 12:56:00 -06:00
|
|
|
character(len=32) :: bstr, tstr
|
2008-11-11 16:12:26 -06:00
|
|
|
|
|
|
|
!----------------------------------------------------------------------
|
|
|
|
!
|
|
|
|
! check if the list is allocated, if yes deallocate it
|
|
|
|
!
|
|
|
|
if (list_allocated()) then
|
|
|
|
call print_info("mesh::init_mesh", "Block list is allocated, deallocate it!")
|
|
|
|
|
|
|
|
call clear_blocks
|
|
|
|
endif
|
|
|
|
|
2008-12-07 12:56:00 -06:00
|
|
|
! print information
|
|
|
|
!
|
2008-12-22 14:57:31 -06:00
|
|
|
if (is_master()) then
|
2008-12-22 16:08:51 -06:00
|
|
|
write(*,"(1x,a)" ) "Generating initial mesh:"
|
2008-12-22 14:57:31 -06:00
|
|
|
write(*,"(4x,a,1x,i6)") "refining to max. level =", maxlev
|
|
|
|
write(*,"(4x,a,1x,i6)") "effective resolution =", ncells*2**maxlev
|
|
|
|
endif
|
2008-12-07 12:56:00 -06:00
|
|
|
|
2008-12-22 15:34:02 -06:00
|
|
|
! initialize blocks
|
2008-11-11 16:12:26 -06:00
|
|
|
!
|
|
|
|
call init_blocks
|
2008-12-22 15:34:02 -06:00
|
|
|
|
|
|
|
! allocate the initial structure of blocks according to the problem
|
|
|
|
!
|
|
|
|
call init_domain
|
2008-11-11 16:12:26 -06:00
|
|
|
|
|
|
|
! at this point we assume, that the initial structure of blocks
|
|
|
|
! according to the defined geometry is already created; no refinement
|
2009-05-18 22:46:19 +02:00
|
|
|
! is done yet; we fill out the coarse blocks with the initial condition
|
2008-11-11 16:12:26 -06:00
|
|
|
!
|
2009-05-18 22:46:19 +02:00
|
|
|
! pblock => plist
|
|
|
|
! do while (associated(pblock))
|
2008-11-11 16:12:26 -06:00
|
|
|
!
|
2009-05-18 22:46:19 +02:00
|
|
|
! ! set level
|
|
|
|
! !
|
|
|
|
! pblock%level = 1
|
|
|
|
! pblock%refine = 0
|
2008-11-11 16:12:26 -06:00
|
|
|
!
|
2009-05-18 22:46:19 +02:00
|
|
|
! ! set initial conditions
|
|
|
|
! !
|
|
|
|
! call init_problem(pblock)
|
2008-11-11 16:12:26 -06:00
|
|
|
!
|
2009-05-18 22:46:19 +02:00
|
|
|
! ! assign pointer to the next block
|
|
|
|
! !
|
|
|
|
! pblock => pblock%next
|
|
|
|
!
|
|
|
|
! end do
|
2008-11-11 16:12:26 -06:00
|
|
|
|
2008-12-22 16:15:27 -06:00
|
|
|
! TODO: refine blocks on master untill the total number of blocks exceeds
|
|
|
|
! the number of MPI processes, then interrupt refining and autobalance
|
|
|
|
! the allocated blocks, after that continue refining on all processes
|
|
|
|
! autobalancing after each level refinement
|
|
|
|
!
|
|
|
|
|
2008-11-11 16:12:26 -06:00
|
|
|
! at this point the inital blocks are allocated and set for refinement,
|
|
|
|
! so iterate over all levels from 1 to maxlevel and create sub-blocks,
|
|
|
|
! set the initial conditions for each, check criterium and set for
|
|
|
|
! refinement according to the criterium fullfilment
|
|
|
|
!
|
2008-12-28 13:09:14 -06:00
|
|
|
! TODO: refine blocks on master untill the total number of blocks exceeds
|
|
|
|
! the number of MPI processes, then interrupt refining and autobalance
|
|
|
|
! the allocated blocks, after that continue refining on all processes
|
|
|
|
! autobalancing after each level of refinement
|
|
|
|
!
|
|
|
|
! refine the blocks until the number of blocks is smaller than the number
|
|
|
|
! of processes
|
2008-11-29 22:19:02 -06:00
|
|
|
!
|
2008-12-22 14:57:31 -06:00
|
|
|
if (is_master()) &
|
|
|
|
write(*,"(4x,a,$)") "refining level = "
|
2008-12-07 12:56:00 -06:00
|
|
|
|
2008-12-28 13:09:14 -06:00
|
|
|
l = 1
|
2009-05-18 22:46:19 +02:00
|
|
|
do while (l .le. maxlev)
|
2008-12-28 13:09:14 -06:00
|
|
|
|
|
|
|
! print the level processed
|
2008-12-07 12:56:00 -06:00
|
|
|
!
|
2008-12-22 14:57:31 -06:00
|
|
|
if (is_master()) &
|
|
|
|
write(*,"(1x,i2,$)") l
|
2008-11-29 22:19:02 -06:00
|
|
|
|
2009-05-18 22:46:19 +02:00
|
|
|
! iterate over all blocks at the current level and initialize problem
|
2008-11-29 22:19:02 -06:00
|
|
|
!
|
2008-12-07 12:56:00 -06:00
|
|
|
pblock => plist
|
2008-11-29 22:19:02 -06:00
|
|
|
do while (associated(pblock))
|
|
|
|
|
2009-05-18 22:46:19 +02:00
|
|
|
! set initial conditions if the block at current level
|
2008-12-13 15:08:18 -06:00
|
|
|
!
|
2009-05-18 22:46:19 +02:00
|
|
|
if (pblock%level .le. l) &
|
|
|
|
call init_problem(pblock)
|
2008-11-29 22:19:02 -06:00
|
|
|
|
2008-12-06 20:11:36 -06:00
|
|
|
! assign pointer to the next block
|
2008-12-05 14:04:12 -06:00
|
|
|
!
|
2008-12-06 20:11:36 -06:00
|
|
|
pblock => pblock%next
|
2008-12-05 14:04:12 -06:00
|
|
|
|
2008-12-06 20:11:36 -06:00
|
|
|
end do
|
|
|
|
|
2009-05-18 22:46:19 +02:00
|
|
|
! for the maximum level we only initialize problem (with not check of the
|
|
|
|
! refinements criterion or the refinement)
|
|
|
|
!
|
|
|
|
if (l .lt. maxlev) then
|
|
|
|
|
|
|
|
! iterate over all blocks at the current level and check the refinement
|
|
|
|
! criterion; do not allow for derefinement
|
2008-12-06 20:11:36 -06:00
|
|
|
!
|
2008-12-07 12:56:00 -06:00
|
|
|
pblock => plist
|
2008-12-06 20:11:36 -06:00
|
|
|
do while (associated(pblock))
|
|
|
|
|
2009-05-18 22:46:19 +02:00
|
|
|
if (pblock%level .eq. l) &
|
|
|
|
pblock%refine = max(0, check_ref(pblock))
|
|
|
|
|
|
|
|
! assign pointer to the next block
|
|
|
|
!
|
|
|
|
pblock => pblock%next
|
|
|
|
|
|
|
|
end do
|
|
|
|
|
|
|
|
! walk through all levels down and check if the neighbors have to be refined
|
|
|
|
! too; there is no need for checking the blocks at the lowest level;
|
|
|
|
!
|
|
|
|
do n = l, 2, -1
|
|
|
|
|
|
|
|
! iterate over all blocks of the current level and if the current block is
|
|
|
|
! selected for the refinement and its neighbors are at lower levels select them
|
|
|
|
! for refinement too;
|
|
|
|
!
|
|
|
|
pblock => plist
|
|
|
|
do while (associated(pblock))
|
|
|
|
|
|
|
|
! check if the current block is at the current level, a leaf, and selected for
|
|
|
|
! refimenet
|
2008-12-06 20:11:36 -06:00
|
|
|
!
|
2008-12-28 13:09:14 -06:00
|
|
|
if (pblock%level .eq. n) then
|
2009-05-18 22:46:19 +02:00
|
|
|
if (pblock%leaf) then
|
|
|
|
if (pblock%refine .eq. 1) then
|
2008-12-06 20:11:36 -06:00
|
|
|
|
|
|
|
! iterate over all neighbors
|
|
|
|
!
|
2009-05-18 22:46:19 +02:00
|
|
|
do i = 1, ndims
|
|
|
|
do j = 1, 2
|
|
|
|
do k = 1, 2
|
2008-12-28 13:09:14 -06:00
|
|
|
|
2009-05-18 22:46:19 +02:00
|
|
|
pneigh => get_pointer(pblock%neigh(i,j,k)%id)
|
2008-12-06 20:11:36 -06:00
|
|
|
|
2008-12-28 13:09:14 -06:00
|
|
|
! check if the neighbor is associated
|
|
|
|
!
|
2009-05-18 22:46:19 +02:00
|
|
|
if (associated(pneigh)) then
|
|
|
|
if (pneigh%leaf) then
|
|
|
|
|
2008-12-06 20:11:36 -06:00
|
|
|
|
2008-12-28 13:09:14 -06:00
|
|
|
! if th eneighbor has lower level, select it to be refined too
|
2008-12-05 14:43:43 -06:00
|
|
|
!
|
2009-05-18 22:46:19 +02:00
|
|
|
if (pneigh%level .lt. pblock%level) &
|
|
|
|
pneigh%refine = 1
|
|
|
|
else
|
|
|
|
call print_error("mesh::init_mesh", "Neighbor is not a leaf!")
|
|
|
|
endif
|
2008-12-28 13:09:14 -06:00
|
|
|
endif
|
2008-12-05 14:43:43 -06:00
|
|
|
|
2009-05-18 22:46:19 +02:00
|
|
|
end do
|
2008-12-28 13:09:14 -06:00
|
|
|
end do
|
|
|
|
end do
|
2008-12-05 14:43:43 -06:00
|
|
|
|
2009-05-18 22:46:19 +02:00
|
|
|
endif
|
2008-12-28 13:09:14 -06:00
|
|
|
endif
|
|
|
|
endif
|
2008-12-06 20:11:36 -06:00
|
|
|
|
|
|
|
! assign pointer to the next block
|
|
|
|
!
|
2009-05-18 22:46:19 +02:00
|
|
|
pblock => pblock%next
|
2008-12-06 20:11:36 -06:00
|
|
|
|
2009-05-18 22:46:19 +02:00
|
|
|
end do
|
2008-12-06 20:11:36 -06:00
|
|
|
end do
|
2008-12-05 14:43:43 -06:00
|
|
|
|
2009-05-18 22:46:19 +02:00
|
|
|
! walk through the levels starting from the lowest to the current
|
2008-12-05 14:43:43 -06:00
|
|
|
!
|
2009-05-18 22:46:19 +02:00
|
|
|
do n = 1, l
|
2008-12-05 14:43:43 -06:00
|
|
|
|
2009-05-18 22:46:19 +02:00
|
|
|
! iterate over all blocks and refine selected
|
2008-12-05 14:43:43 -06:00
|
|
|
!
|
2009-05-18 22:46:19 +02:00
|
|
|
pblock => plist
|
|
|
|
do while (associated(pblock))
|
2008-12-05 14:43:43 -06:00
|
|
|
|
2009-05-18 22:46:19 +02:00
|
|
|
! check if the current block is at the current level and selected for refinement
|
|
|
|
! and perform the refinement
|
2008-12-06 20:11:36 -06:00
|
|
|
!
|
2009-05-18 22:46:19 +02:00
|
|
|
if (pblock%level .eq. n .and. pblock%refine .eq. 1) &
|
|
|
|
call refine_block(pblock)
|
2008-12-05 14:43:43 -06:00
|
|
|
|
2008-12-28 13:09:14 -06:00
|
|
|
! assign pointer to the next block
|
2008-12-06 20:11:36 -06:00
|
|
|
!
|
2009-05-18 22:46:19 +02:00
|
|
|
pblock => pblock%next
|
|
|
|
|
|
|
|
end do
|
2008-11-29 22:19:02 -06:00
|
|
|
|
2008-12-28 13:09:14 -06:00
|
|
|
end do
|
2009-05-18 22:46:19 +02:00
|
|
|
|
|
|
|
endif
|
2008-12-06 20:11:36 -06:00
|
|
|
|
2008-12-28 13:09:14 -06:00
|
|
|
l = l + 1
|
|
|
|
end do
|
|
|
|
|
|
|
|
#ifdef MPI
|
|
|
|
! divide all blocks between all processes
|
|
|
|
!
|
|
|
|
l = 0
|
|
|
|
pblock => plist
|
|
|
|
do while (associated(pblock))
|
|
|
|
|
|
|
|
! assign the cpu to the current block
|
|
|
|
!
|
|
|
|
pblock%cpu = l * ncpus / nblocks
|
2008-11-29 22:19:02 -06:00
|
|
|
|
|
|
|
! assign pointer to the next block
|
|
|
|
!
|
2008-12-28 13:09:14 -06:00
|
|
|
pblock => pblock%next
|
|
|
|
|
|
|
|
l = l + 1
|
|
|
|
end do
|
2008-11-29 22:19:02 -06:00
|
|
|
|
2009-01-08 00:08:52 -06:00
|
|
|
! update the cpu field of the neighbors, parent and children
|
2008-12-28 13:09:14 -06:00
|
|
|
!
|
|
|
|
pblock => plist
|
|
|
|
do while (associated(pblock))
|
|
|
|
|
2009-01-08 00:08:52 -06:00
|
|
|
! update neighbors
|
|
|
|
!
|
2008-12-28 13:09:14 -06:00
|
|
|
do i = 1, ndims
|
|
|
|
do j = 1, 2
|
|
|
|
do k = 1, 2
|
|
|
|
|
|
|
|
pneigh => get_pointer(pblock%neigh(i,j,k)%id)
|
|
|
|
|
|
|
|
if (associated(pneigh)) &
|
|
|
|
pblock%neigh(i,j,k)%cpu = pneigh%cpu
|
|
|
|
|
|
|
|
end do
|
2008-12-06 20:11:36 -06:00
|
|
|
end do
|
2008-11-29 22:19:02 -06:00
|
|
|
end do
|
|
|
|
|
2009-01-08 00:08:52 -06:00
|
|
|
! update parent
|
|
|
|
!
|
|
|
|
pparent => get_pointer(pblock%parent%id)
|
|
|
|
if (associated(pparent)) &
|
|
|
|
pblock%parent%cpu = pparent%cpu
|
|
|
|
|
|
|
|
! update children
|
|
|
|
!
|
|
|
|
do p = 1, nchild
|
|
|
|
pchild => get_pointer(pblock%child(p)%id)
|
|
|
|
|
|
|
|
if (associated(pchild)) &
|
|
|
|
pblock%child(p)%cpu = pchild%cpu
|
|
|
|
end do
|
|
|
|
|
2009-01-02 20:18:57 -06:00
|
|
|
! assign pointer to the next block
|
|
|
|
!
|
2008-12-28 13:09:14 -06:00
|
|
|
pblock => pblock%next
|
|
|
|
end do
|
|
|
|
|
|
|
|
! remove all blocks which don't belong to the current process
|
|
|
|
!
|
|
|
|
pblock => plist
|
|
|
|
do while (associated(pblock))
|
|
|
|
pnext => pblock%next
|
|
|
|
|
|
|
|
if (pblock%cpu .ne. ncpu) &
|
|
|
|
call deallocate_block(pblock)
|
|
|
|
|
|
|
|
pblock => pnext
|
2008-11-29 22:19:02 -06:00
|
|
|
end do
|
2008-12-28 13:09:14 -06:00
|
|
|
#endif /* MPI */
|
2008-11-29 22:19:02 -06:00
|
|
|
|
2008-12-07 12:56:00 -06:00
|
|
|
! print information
|
|
|
|
!
|
2008-12-22 14:57:31 -06:00
|
|
|
if (is_master()) then
|
2009-05-18 22:46:19 +02:00
|
|
|
write(bstr,"(i)") nblocks
|
2008-12-22 14:57:31 -06:00
|
|
|
write(tstr,"(i)") (2**maxlev)**ndims
|
|
|
|
write(*,*)
|
|
|
|
write(*,"(4x,a,1x,a6,' / ',a,' = ',f8.4,' %')") "allocated/total blocks =", trim(adjustl(bstr)),trim(adjustl(tstr)), (100.0*last_id)/(2**maxlev)**ndims
|
2009-05-18 22:46:19 +02:00
|
|
|
|
|
|
|
write(bstr,"(i)") nleafs
|
|
|
|
write(tstr,"(i)") (2**maxlev)**ndims
|
|
|
|
write(*,"(4x,a,1x,a6,' / ',a,' = ',f8.4,' %')") "leafs/cover blocks =", trim(adjustl(bstr)),trim(adjustl(tstr)), (100.0*nleafs)/(2**maxlev)**ndims
|
2008-12-22 14:57:31 -06:00
|
|
|
endif
|
2008-11-11 16:12:26 -06:00
|
|
|
|
2008-12-08 20:03:01 -06:00
|
|
|
! allocating space for coordinate variables
|
|
|
|
!
|
2008-12-22 15:34:02 -06:00
|
|
|
allocate(ax (maxlev, im))
|
|
|
|
allocate(ay (maxlev, jm))
|
|
|
|
allocate(az (maxlev, km))
|
2008-12-08 20:03:01 -06:00
|
|
|
allocate(adx (maxlev))
|
|
|
|
allocate(ady (maxlev))
|
|
|
|
allocate(adz (maxlev))
|
|
|
|
allocate(adxi(maxlev))
|
|
|
|
allocate(adyi(maxlev))
|
|
|
|
allocate(adzi(maxlev))
|
|
|
|
|
|
|
|
! generating coordinates for all levels
|
|
|
|
!
|
|
|
|
do l = 1, maxlev
|
2008-12-13 21:05:51 -06:00
|
|
|
adx (l) = (xmax - xmin) / (ncells*2**l)
|
2008-12-08 20:03:01 -06:00
|
|
|
adxi(l) = 1.0 / adx(l)
|
2008-12-13 21:05:51 -06:00
|
|
|
ady (l) = (ymax - ymin) / (ncells*2**l)
|
2008-12-08 20:03:01 -06:00
|
|
|
adyi(l) = 1.0 / ady(l)
|
|
|
|
#if NDIMS == 3
|
2008-12-13 21:05:51 -06:00
|
|
|
adz (l) = (zmax - zmin) / (ncells*2**l)
|
2008-12-08 20:03:01 -06:00
|
|
|
#else
|
|
|
|
adz (l) = 1.0
|
|
|
|
#endif
|
|
|
|
adzi(l) = 1.0 / adz(l)
|
|
|
|
end do
|
2008-11-11 16:12:26 -06:00
|
|
|
|
2008-12-09 14:51:33 -06:00
|
|
|
! get the minimum grid step
|
|
|
|
!
|
2008-12-13 21:05:51 -06:00
|
|
|
dx_min = 0.5*min(adx(maxlev), ady(maxlev), adz(maxlev))
|
2008-12-09 14:51:33 -06:00
|
|
|
|
2008-12-13 15:08:18 -06:00
|
|
|
!-------------------------------------------------------------------------------
|
2008-11-11 16:12:26 -06:00
|
|
|
!
|
|
|
|
end subroutine init_mesh
|
|
|
|
!
|
2008-12-13 15:08:18 -06:00
|
|
|
!===============================================================================
|
|
|
|
!
|
|
|
|
! update_mesh: subroutine check the refinement criterion for each block,
|
|
|
|
! refines or derefines it if necessary, and restricts or
|
|
|
|
! prolongates all data to the newly created blocks
|
|
|
|
!
|
|
|
|
!===============================================================================
|
|
|
|
!
|
|
|
|
subroutine update_mesh(ref)
|
|
|
|
|
2009-01-03 22:49:04 -06:00
|
|
|
use config , only : maxlev
|
|
|
|
use blocks , only : block, plist, ndims, nchild, nblocks, refine_block &
|
2009-01-08 00:08:52 -06:00
|
|
|
, get_pointer, maxid, last_id
|
2009-01-03 22:49:04 -06:00
|
|
|
use error , only : print_info
|
|
|
|
#ifdef MPI
|
2009-01-08 00:08:52 -06:00
|
|
|
use mpitools, only : ncpus, ncpu, mfindmaxi, mallreducesuml, mallreducemaxl, msendi, mrecvi
|
2009-01-03 22:49:04 -06:00
|
|
|
#endif /* MPI */
|
|
|
|
use problem , only : check_ref
|
2008-12-13 15:08:18 -06:00
|
|
|
|
|
|
|
implicit none
|
|
|
|
|
|
|
|
integer, intent(in) :: ref
|
|
|
|
|
|
|
|
! local variables
|
|
|
|
!
|
|
|
|
type(block), pointer :: pblock, pneigh, pchild, pparent
|
2009-01-03 22:49:04 -06:00
|
|
|
integer(kind=4) :: l, i, j, k, m, n, p, q
|
|
|
|
|
|
|
|
#ifdef MPI
|
2009-01-08 00:08:52 -06:00
|
|
|
logical :: flag
|
|
|
|
integer(kind=4) :: mblk
|
2009-01-03 22:49:04 -06:00
|
|
|
|
|
|
|
! local arrays for MPI
|
|
|
|
!
|
2009-05-18 22:46:19 +02:00
|
|
|
integer(kind=4), dimension(:,:,:) , allocatable :: iblk, idif, ichl
|
2009-01-03 22:49:04 -06:00
|
|
|
#endif /* MPI */
|
2008-12-13 15:08:18 -06:00
|
|
|
|
2009-05-18 22:46:19 +02:00
|
|
|
!-------------------------------------------------------------------------------
|
2008-12-13 15:08:18 -06:00
|
|
|
!
|
2009-01-03 22:49:04 -06:00
|
|
|
#ifdef MPI
|
2009-01-08 00:08:52 -06:00
|
|
|
! find maximum number of blocks
|
2009-01-03 22:49:04 -06:00
|
|
|
!
|
2009-01-08 00:08:52 -06:00
|
|
|
mblk = last_id
|
|
|
|
call mfindmaxi(mblk)
|
2009-01-03 22:49:04 -06:00
|
|
|
|
2009-01-08 00:08:52 -06:00
|
|
|
! allocate and initialize temporary arrays
|
2009-01-03 22:49:04 -06:00
|
|
|
!
|
2009-01-08 00:08:52 -06:00
|
|
|
allocate(iblk(0:ncpus-1, mblk, 3))
|
|
|
|
allocate(idif(0:ncpus-1, mblk, 2))
|
2009-05-18 22:46:19 +02:00
|
|
|
allocate(ichl(0:ncpus-1, mblk, 4))
|
2009-01-08 00:08:52 -06:00
|
|
|
iblk(:,:,:) = 0
|
|
|
|
idif(:,:,:) = 0
|
2009-05-18 22:46:19 +02:00
|
|
|
ichl(:,:,:) = 0
|
2009-01-03 22:49:04 -06:00
|
|
|
|
2009-05-18 22:46:19 +02:00
|
|
|
! check the refinement criterion for all leafes
|
2008-12-13 15:08:18 -06:00
|
|
|
!
|
2009-01-08 00:08:52 -06:00
|
|
|
pblock => plist
|
|
|
|
do while (associated(pblock))
|
2009-05-18 22:46:19 +02:00
|
|
|
|
2009-01-08 00:08:52 -06:00
|
|
|
if (pblock%leaf) then
|
|
|
|
pblock%refine = check_ref(pblock)
|
2008-12-13 15:08:18 -06:00
|
|
|
|
2009-01-08 00:08:52 -06:00
|
|
|
if (pblock%level .eq. maxlev) &
|
|
|
|
pblock%refine = min(0, pblock%refine)
|
|
|
|
endif
|
2009-05-18 22:46:19 +02:00
|
|
|
|
2009-01-08 00:08:52 -06:00
|
|
|
pblock => pblock%next
|
|
|
|
end do
|
2008-12-13 15:08:18 -06:00
|
|
|
|
2009-05-18 22:46:19 +02:00
|
|
|
! walk down from the highest level and select neighbors for refinement if they
|
|
|
|
! are at lower levels
|
2008-12-13 15:08:18 -06:00
|
|
|
!
|
2009-05-18 22:46:19 +02:00
|
|
|
do l = maxlev, 1, -1
|
2009-01-08 00:08:52 -06:00
|
|
|
|
2009-05-18 22:46:19 +02:00
|
|
|
! iterate over all blocks at the current level and if the current block is
|
|
|
|
! selected for refinement set the neighbor at lower level to be refined too
|
2008-12-13 15:08:18 -06:00
|
|
|
!
|
2009-01-08 00:08:52 -06:00
|
|
|
pblock => plist
|
|
|
|
do while (associated(pblock))
|
2009-01-03 22:49:04 -06:00
|
|
|
|
2009-05-18 22:46:19 +02:00
|
|
|
if (pblock%level .eq. l .and. pblock%leaf) then
|
|
|
|
if (pblock%refine .eq. 1) then
|
|
|
|
|
|
|
|
do i = 1, ndims
|
|
|
|
do j = 1, 2
|
|
|
|
do k = 1, 2
|
|
|
|
if (pblock%neigh(i,j,k)%cpu .eq. ncpu) then
|
|
|
|
pneigh => get_pointer(pblock%neigh(i,j,k)%id)
|
|
|
|
|
|
|
|
if (pneigh%level .lt. pblock%level) &
|
|
|
|
pneigh%refine = 1
|
|
|
|
|
|
|
|
if (pneigh%level .eq. pblock%level .and. pneigh%refine .eq. -1) &
|
|
|
|
pneigh%refine = 0
|
|
|
|
endif
|
2009-01-03 22:49:04 -06:00
|
|
|
end do
|
|
|
|
end do
|
2009-05-18 22:46:19 +02:00
|
|
|
end do
|
|
|
|
|
2008-12-13 15:08:18 -06:00
|
|
|
endif
|
2009-01-08 00:08:52 -06:00
|
|
|
endif
|
2009-05-18 22:46:19 +02:00
|
|
|
|
2009-01-08 00:08:52 -06:00
|
|
|
pblock => pblock%next
|
|
|
|
end do
|
2008-12-13 15:08:18 -06:00
|
|
|
|
2009-05-18 22:46:19 +02:00
|
|
|
! check if all children are selected for derefinement; if this condition is not
|
|
|
|
! fullfiled deselect all children from derefinement
|
|
|
|
!
|
2009-01-08 00:08:52 -06:00
|
|
|
pblock => plist
|
|
|
|
do while (associated(pblock))
|
2009-05-18 22:46:19 +02:00
|
|
|
|
|
|
|
if (pblock%level .eq. l-1 .and. .not. pblock%leaf) then
|
2009-01-08 00:08:52 -06:00
|
|
|
flag = .true.
|
|
|
|
do p = 1, nchild
|
2009-05-18 22:46:19 +02:00
|
|
|
if (pblock%child(p)%cpu .eq. ncpu) then
|
|
|
|
pchild => get_pointer(pblock%child(p)%id)
|
|
|
|
|
|
|
|
flag = flag .and. (pchild%refine .eq. -1)
|
|
|
|
endif
|
2009-01-08 00:08:52 -06:00
|
|
|
end do
|
|
|
|
if (.not. flag) then
|
|
|
|
do p = 1, nchild
|
2009-05-18 22:46:19 +02:00
|
|
|
if (pblock%child(p)%cpu .eq. ncpu) then
|
|
|
|
pchild => get_pointer(pblock%child(p)%id)
|
|
|
|
|
|
|
|
if (pchild%leaf) &
|
|
|
|
pchild%refine = max(0, pchild%refine)
|
|
|
|
endif
|
2009-01-08 00:08:52 -06:00
|
|
|
end do
|
|
|
|
endif
|
|
|
|
endif
|
2009-05-18 22:46:19 +02:00
|
|
|
|
2009-01-08 00:08:52 -06:00
|
|
|
pblock => pblock%next
|
|
|
|
end do
|
2008-12-13 15:08:18 -06:00
|
|
|
|
2009-05-18 22:46:19 +02:00
|
|
|
! deselect neighbors from derefinement if the current block is set for
|
|
|
|
! refinement or it is at higher level and not selected for derefinement
|
|
|
|
!
|
|
|
|
pblock => plist
|
|
|
|
do while (associated(pblock))
|
|
|
|
|
|
|
|
if (pblock%level .eq. l .and. pblock%leaf) then
|
2008-12-13 15:08:18 -06:00
|
|
|
|
2009-05-18 22:46:19 +02:00
|
|
|
if (pblock%refine .ne. -1) then
|
|
|
|
|
|
|
|
do i = 1, ndims
|
|
|
|
do j = 1, 2
|
|
|
|
do k = 1, 2
|
|
|
|
if (pblock%neigh(i,j,k)%cpu .eq. ncpu) then
|
|
|
|
pneigh => get_pointer(pblock%neigh(i,j,k)%id)
|
|
|
|
|
|
|
|
if (pneigh%refine .eq. -1) then
|
|
|
|
|
|
|
|
if (pneigh%level .lt. pblock%level) &
|
|
|
|
pneigh%refine = 0
|
|
|
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
endif
|
|
|
|
end do
|
|
|
|
end do
|
|
|
|
end do
|
|
|
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
pblock => pblock%next
|
|
|
|
end do
|
|
|
|
|
|
|
|
end do
|
|
|
|
|
|
|
|
! ! check blocks at the maximum level for derefinement
|
|
|
|
! !
|
|
|
|
! pblock => plist
|
|
|
|
! do while (associated(pblock))
|
|
|
|
! if (pblock%leaf) then
|
|
|
|
! pblock%refine = check_ref(pblock)
|
|
|
|
!
|
|
|
|
! if (pblock%level .eq. maxlev) &
|
|
|
|
! pblock%refine = min(0, pblock%refine)
|
|
|
|
!
|
|
|
|
! if (pblock%level .eq. 1) &
|
|
|
|
! pblock%refine = max(0, pblock%refine)
|
|
|
|
!
|
|
|
|
! iblk(ncpu,pblock%id,1) = pblock%refine
|
|
|
|
! iblk(ncpu,pblock%id,2) = pblock%level
|
|
|
|
! iblk(ncpu,pblock%id,3) = 1
|
|
|
|
! endif
|
|
|
|
! pblock => pblock%next
|
|
|
|
! end do
|
|
|
|
!
|
|
|
|
! ! exchange information about the block refinements
|
|
|
|
! !
|
|
|
|
! call mallreducesuml(size(iblk), iblk)
|
|
|
|
!
|
|
|
|
! ! go down to lower levels
|
|
|
|
! !
|
|
|
|
! do l = maxlev - 1, 1, -1
|
|
|
|
!
|
|
|
|
! idif(:,:,:) = 0
|
|
|
|
!
|
|
|
|
! pblock => plist
|
|
|
|
! do while (associated(pblock))
|
|
|
|
! if (pblock%leaf) then
|
|
|
|
! if (pblock%level .eq. l) then
|
|
|
|
! if (pblock%refine .eq. -1) then
|
|
|
|
! do i = 1, ndims
|
|
|
|
! do j = 1, 2
|
|
|
|
! do k = 1, 2
|
|
|
|
! if (pblock%neigh(i,j,k)%id .gt. 0) then
|
|
|
|
! if (iblk(pblock%neigh(i,j,k)%cpu,pblock%neigh(i,j,k)%id,2) .gt. pblock%level) then
|
|
|
|
! idif(ncpu,pblock%id,1) = 1
|
|
|
|
! endif
|
|
|
|
! endif
|
|
|
|
! end do
|
|
|
|
! end do
|
|
|
|
! end do
|
|
|
|
! endif
|
|
|
|
!
|
|
|
|
! if (pblock%refine .eq. 1) then
|
|
|
|
! do i = 1, ndims
|
|
|
|
! do j = 1, 2
|
|
|
|
! do k = 1, 2
|
|
|
|
! if (pblock%neigh(i,j,k)%id .gt. 0) then
|
|
|
|
! if (iblk(pblock%neigh(i,j,k)%cpu,pblock%neigh(i,j,k)%id,2) .lt. pblock%level) then
|
|
|
|
! idif(pblock%neigh(i,j,k)%cpu,pblock%neigh(i,j,k)%id,2) = 1
|
|
|
|
! endif
|
|
|
|
! endif
|
|
|
|
! end do
|
|
|
|
! end do
|
|
|
|
! end do
|
|
|
|
! endif
|
|
|
|
! endif
|
|
|
|
! endif
|
|
|
|
! pblock => pblock%next
|
|
|
|
! end do
|
|
|
|
!
|
|
|
|
! pblock => plist
|
|
|
|
! do while (associated(pblock))
|
|
|
|
! if (.not. pblock%leaf) then
|
|
|
|
! flag = .true.
|
|
|
|
! do p = 1, nchild
|
|
|
|
! if (pblock%child(p)%id .gt. 0) &
|
|
|
|
! flag = flag .and. (iblk(pblock%child(p)%cpu,pblock%child(p)%id,1) .eq. -1) .and. (iblk(pblock%child(p)%cpu,pblock%child(p)%id,3) .eq. 1)
|
|
|
|
! end do
|
|
|
|
! if (.not. flag) then
|
|
|
|
! do p = 1, nchild
|
|
|
|
! if (pblock%child(p)%id .gt. 0) &
|
|
|
|
! idif(pblock%child(p)%cpu,pblock%child(p)%id,1) = 1
|
|
|
|
! end do
|
|
|
|
! endif
|
|
|
|
! endif
|
|
|
|
! pblock => pblock%next
|
|
|
|
! end do
|
|
|
|
!
|
|
|
|
! call mallreducemaxl(size(idif), idif)
|
|
|
|
!
|
|
|
|
! do i = 0, ncpus - 1
|
|
|
|
! do j = 1, mblk
|
|
|
|
! if (idif(i,j,1) .eq. 1) &
|
|
|
|
! iblk(i,j,1) = max(0, iblk(i,j,1))
|
|
|
|
! if (idif(i,j,2) .eq. 1) &
|
|
|
|
! iblk(i,j,1) = 1
|
|
|
|
! end do
|
|
|
|
! end do
|
|
|
|
!
|
|
|
|
! do i = 1, mblk
|
|
|
|
! if (iblk(ncpu,i,2) .gt. 0) then
|
|
|
|
! pblock => get_pointer(i)
|
|
|
|
! pblock%refine = iblk(ncpu,i,1)
|
|
|
|
! endif
|
|
|
|
! end do
|
|
|
|
!
|
|
|
|
! end do
|
|
|
|
|
|
|
|
! perform the actual derefinement
|
|
|
|
!
|
|
|
|
do l = maxlev, 2, -1
|
|
|
|
|
|
|
|
pblock => plist
|
|
|
|
do while (associated(pblock))
|
|
|
|
|
|
|
|
if (pblock%level .eq. l) then
|
|
|
|
if (pblock%leaf) then
|
|
|
|
if (pblock%refine .eq. -1) then
|
|
|
|
pparent => get_pointer(pblock%parent%id)
|
|
|
|
|
|
|
|
if (associated(pparent)) then
|
|
|
|
call restrict_block(pparent)
|
|
|
|
pblock => pparent
|
|
|
|
endif
|
|
|
|
endif
|
|
|
|
endif
|
|
|
|
endif
|
|
|
|
|
|
|
|
pblock => pblock%next
|
2009-01-08 00:08:52 -06:00
|
|
|
end do
|
2008-12-13 15:08:18 -06:00
|
|
|
|
2009-05-18 22:46:19 +02:00
|
|
|
end do
|
|
|
|
|
|
|
|
! perform the actual refinement
|
|
|
|
!
|
|
|
|
do l = 1, maxlev - 1
|
|
|
|
|
|
|
|
pblock => plist
|
|
|
|
do while (associated(pblock))
|
|
|
|
|
|
|
|
if (pblock%leaf) then
|
|
|
|
if (pblock%level .eq. l) then
|
|
|
|
if (pblock%refine .eq. 1) then
|
|
|
|
pparent => pblock
|
|
|
|
|
|
|
|
call refine_block(pblock)
|
|
|
|
call prolong_block(pparent)
|
|
|
|
endif
|
|
|
|
endif
|
2008-12-13 15:08:18 -06:00
|
|
|
endif
|
2009-05-18 22:46:19 +02:00
|
|
|
|
|
|
|
pblock => pblock%next
|
|
|
|
|
2008-12-13 15:08:18 -06:00
|
|
|
end do
|
|
|
|
|
|
|
|
end do
|
|
|
|
|
2009-05-18 22:46:19 +02:00
|
|
|
|
|
|
|
! ! perform the actual refinement
|
|
|
|
! !
|
|
|
|
! do l = 1, 3!maxlev - 1
|
|
|
|
! pblock => plist
|
|
|
|
! do while (associated(pblock))
|
|
|
|
! if (pblock%leaf) then
|
|
|
|
! if (pblock%level .eq. l) then
|
|
|
|
! if (pblock%refine .eq. 1) then
|
|
|
|
! pparent => pblock
|
|
|
|
!
|
|
|
|
! call refine_block(pblock)
|
|
|
|
! call prolong_block(pparent)
|
|
|
|
!
|
|
|
|
! do p = 1, nchild
|
|
|
|
! ichl(ncpu,pparent%id,p) = pparent%child(p)%id
|
|
|
|
! end do
|
|
|
|
! endif
|
|
|
|
! endif
|
|
|
|
! endif
|
|
|
|
! pblock => pblock%next
|
|
|
|
! end do
|
|
|
|
! end do
|
|
|
|
|
2009-01-03 22:49:04 -06:00
|
|
|
! deallocate temporary arrays
|
|
|
|
!
|
|
|
|
deallocate(iblk)
|
2009-01-08 00:08:52 -06:00
|
|
|
deallocate(idif)
|
2009-05-18 22:46:19 +02:00
|
|
|
deallocate(ichl)
|
2009-01-08 00:08:52 -06:00
|
|
|
#else /* MPI */
|
2009-01-03 22:49:04 -06:00
|
|
|
#endif /* MPI */
|
2008-12-13 15:08:18 -06:00
|
|
|
|
|
|
|
!-------------------------------------------------------------------------------
|
|
|
|
!
|
|
|
|
end subroutine update_mesh
|
|
|
|
!
|
|
|
|
!===============================================================================
|
|
|
|
!
|
|
|
|
! prolong_block: subroutine expands the block data and copy them to children
|
|
|
|
!
|
|
|
|
!===============================================================================
|
|
|
|
!
|
|
|
|
subroutine prolong_block(pblock)
|
|
|
|
|
2008-12-19 17:24:36 -06:00
|
|
|
use blocks , only : block, nv => nvars, get_pointer
|
2008-12-13 15:08:18 -06:00
|
|
|
use config , only : in, jn, kn, im, jm, km, ng
|
|
|
|
use interpolation, only : expand
|
|
|
|
|
|
|
|
implicit none
|
|
|
|
|
|
|
|
! input arguments
|
|
|
|
!
|
|
|
|
type(block), pointer :: pblock, pchild
|
|
|
|
|
|
|
|
! local variables
|
|
|
|
!
|
|
|
|
integer :: q, dm(3), fm(3), il, iu, jl, ju, k
|
|
|
|
|
|
|
|
! local arrays
|
|
|
|
!
|
|
|
|
real, dimension(nv,2*im,2*jm,2*km) :: u
|
|
|
|
|
|
|
|
!-------------------------------------------------------------------------------
|
|
|
|
!
|
|
|
|
dm(1) = im
|
|
|
|
dm(2) = jm
|
|
|
|
dm(3) = km
|
|
|
|
fm(:) = 2 * (dm(:) - ng)
|
|
|
|
if (km .eq. 1) &
|
|
|
|
fm(3) = 1
|
|
|
|
|
|
|
|
! first expand variables
|
|
|
|
!
|
|
|
|
do q = 1, nv
|
|
|
|
call expand(dm,fm,ng,pblock%u(q,:,:,:),u(q,:,:,:),'t','t','t')
|
|
|
|
end do
|
|
|
|
|
|
|
|
! fill values of children
|
|
|
|
!
|
|
|
|
il = 1
|
|
|
|
iu = il + im - 1
|
|
|
|
jl = 1
|
|
|
|
ju = jl + jm - 1
|
2008-12-19 17:24:36 -06:00
|
|
|
pchild => get_pointer(pblock%child(1)%id)
|
2008-12-13 15:08:18 -06:00
|
|
|
do k = 1, km
|
2008-12-19 17:24:36 -06:00
|
|
|
pchild%u(:,:,:,k) = u(:,il:iu,jl:ju,k)
|
2008-12-13 15:08:18 -06:00
|
|
|
end do
|
|
|
|
|
|
|
|
il = in + 1
|
|
|
|
iu = il + im - 1
|
|
|
|
jl = 1
|
|
|
|
ju = jl + jm - 1
|
2008-12-19 17:24:36 -06:00
|
|
|
pchild => get_pointer(pblock%child(2)%id)
|
2008-12-13 15:08:18 -06:00
|
|
|
do k = 1, km
|
2008-12-19 17:24:36 -06:00
|
|
|
pchild%u(:,:,:,k) = u(:,il:iu,jl:ju,k)
|
2008-12-13 15:08:18 -06:00
|
|
|
end do
|
|
|
|
|
|
|
|
il = 1
|
|
|
|
iu = il + im - 1
|
|
|
|
jl = in + 1
|
|
|
|
ju = jl + jm - 1
|
2008-12-19 17:24:36 -06:00
|
|
|
pchild => get_pointer(pblock%child(3)%id)
|
2008-12-13 15:08:18 -06:00
|
|
|
do k = 1, km
|
2008-12-19 17:24:36 -06:00
|
|
|
pchild%u(:,:,:,k) = u(:,il:iu,jl:ju,k)
|
2008-12-13 15:08:18 -06:00
|
|
|
end do
|
|
|
|
|
|
|
|
il = in + 1
|
|
|
|
iu = il + im - 1
|
|
|
|
jl = in + 1
|
|
|
|
ju = jl + jm - 1
|
2008-12-19 17:24:36 -06:00
|
|
|
pchild => get_pointer(pblock%child(4)%id)
|
2008-12-13 15:08:18 -06:00
|
|
|
do k = 1, km
|
2008-12-19 17:24:36 -06:00
|
|
|
pchild%u(:,:,:,k) = u(:,il:iu,jl:ju,k)
|
2008-12-13 15:08:18 -06:00
|
|
|
end do
|
|
|
|
|
|
|
|
!-------------------------------------------------------------------------------
|
|
|
|
!
|
|
|
|
end subroutine prolong_block
|
|
|
|
!
|
|
|
|
!===============================================================================
|
|
|
|
!
|
|
|
|
! restrict_block: subroutine shrinks the block data and copy them from children
|
|
|
|
!
|
|
|
|
!===============================================================================
|
|
|
|
!
|
|
|
|
subroutine restrict_block(pblock)
|
|
|
|
|
2008-12-19 17:24:36 -06:00
|
|
|
use blocks , only : block, nv => nvars, derefine_block, get_pointer
|
2008-12-13 15:08:18 -06:00
|
|
|
use config , only : in, jn, kn, im, jm, km, ng
|
|
|
|
|
|
|
|
implicit none
|
|
|
|
|
|
|
|
! input arguments
|
|
|
|
!
|
|
|
|
type(block), pointer, intent(inout) :: pblock
|
|
|
|
|
|
|
|
! local variables
|
|
|
|
!
|
|
|
|
integer :: q, i, j, k, il, iu, jl, ju, i1, i2, j1, j2
|
|
|
|
|
|
|
|
! local pointers
|
|
|
|
!
|
|
|
|
type(block), pointer :: pbl, pbr, ptl, ptr, pb
|
|
|
|
|
|
|
|
!-------------------------------------------------------------------------------
|
|
|
|
!
|
2008-12-19 17:24:36 -06:00
|
|
|
pbl => get_pointer(pblock%child(1)%id)
|
|
|
|
pbr => get_pointer(pblock%child(2)%id)
|
|
|
|
ptl => get_pointer(pblock%child(3)%id)
|
|
|
|
ptr => get_pointer(pblock%child(4)%id)
|
2008-12-13 15:08:18 -06:00
|
|
|
|
|
|
|
! BL
|
|
|
|
!
|
|
|
|
il = ng / 2 + 1
|
|
|
|
iu = im / 2
|
|
|
|
jl = ng / 2 + 1
|
|
|
|
ju = jm / 2
|
|
|
|
do k = 1, km
|
|
|
|
do j = jl, ju
|
|
|
|
j2 = 2 * j - ng
|
|
|
|
j1 = j2 - 1
|
|
|
|
do i = il, iu
|
|
|
|
i2 = 2 * i - ng
|
|
|
|
i1 = i2 - 1
|
|
|
|
|
|
|
|
pblock%u(1:nv,i,j,k) = 0.25 * (pbl%u(1:nv,i1,j1,k) + pbl%u(1:nv,i1,j2,k) &
|
|
|
|
+ pbl%u(1:nv,i2,j1,k) + pbl%u(1:nv,i2,j2,k))
|
|
|
|
end do
|
|
|
|
end do
|
|
|
|
end do
|
|
|
|
|
|
|
|
! BR
|
|
|
|
!
|
|
|
|
il = im / 2 + 1
|
|
|
|
iu = im - ng / 2
|
|
|
|
jl = ng / 2 + 1
|
|
|
|
ju = jm / 2
|
|
|
|
do k = 1, km
|
|
|
|
do j = jl, ju
|
|
|
|
j2 = 2 * j - ng
|
|
|
|
j1 = j2 - 1
|
|
|
|
do i = il, iu
|
|
|
|
i2 = 2 * i - im + ng
|
|
|
|
i1 = i2 - 1
|
|
|
|
|
|
|
|
pblock%u(1:nv,i,j,k) = 0.25 * (pbr%u(1:nv,i1,j1,k) + pbr%u(1:nv,i1,j2,k) &
|
|
|
|
+ pbr%u(1:nv,i2,j1,k) + pbr%u(1:nv,i2,j2,k))
|
|
|
|
end do
|
|
|
|
end do
|
|
|
|
end do
|
|
|
|
|
|
|
|
! TL
|
|
|
|
!
|
|
|
|
il = ng / 2 + 1
|
|
|
|
iu = im / 2
|
|
|
|
jl = jm / 2 + 1
|
|
|
|
ju = jm - ng / 2
|
|
|
|
do k = 1, km
|
|
|
|
do j = jl, ju
|
|
|
|
j2 = 2 * j - jm + ng
|
|
|
|
j1 = j2 - 1
|
|
|
|
do i = il, iu
|
|
|
|
i2 = 2 * i - ng
|
|
|
|
i1 = i2 - 1
|
|
|
|
|
|
|
|
pblock%u(1:nv,i,j,k) = 0.25 * (ptl%u(1:nv,i1,j1,k) + ptl%u(1:nv,i1,j2,k) &
|
|
|
|
+ ptl%u(1:nv,i2,j1,k) + ptl%u(1:nv,i2,j2,k))
|
|
|
|
end do
|
|
|
|
end do
|
|
|
|
end do
|
|
|
|
|
|
|
|
! TR
|
|
|
|
!
|
|
|
|
il = im / 2 + 1
|
|
|
|
iu = im - ng / 2
|
|
|
|
jl = jm / 2 + 1
|
|
|
|
ju = jm - ng / 2
|
|
|
|
do k = 1, km
|
|
|
|
do j = jl, ju
|
|
|
|
j2 = 2 * j - jm + ng
|
|
|
|
j1 = j2 - 1
|
|
|
|
do i = il, iu
|
|
|
|
i2 = 2 * i - im + ng
|
|
|
|
i1 = i2 - 1
|
|
|
|
|
|
|
|
pblock%u(1:nv,i,j,k) = 0.25 * (ptr%u(1:nv,i1,j1,k) + ptr%u(1:nv,i1,j2,k) &
|
|
|
|
+ ptr%u(1:nv,i2,j1,k) + ptr%u(1:nv,i2,j2,k))
|
|
|
|
end do
|
|
|
|
end do
|
|
|
|
end do
|
|
|
|
|
|
|
|
! derefine block
|
|
|
|
!
|
|
|
|
pb => pblock
|
|
|
|
call derefine_block(pb)
|
|
|
|
|
|
|
|
nullify(pb)
|
|
|
|
nullify(pbl)
|
|
|
|
nullify(pbr)
|
|
|
|
nullify(ptl)
|
|
|
|
nullify(ptr)
|
|
|
|
|
|
|
|
!-------------------------------------------------------------------------------
|
|
|
|
!
|
|
|
|
end subroutine restrict_block
|
|
|
|
!
|
|
|
|
!===============================================================================
|
2008-11-11 16:12:26 -06:00
|
|
|
!
|
|
|
|
! clears_mesh: subroutine deallocates mesh, removing blocks
|
|
|
|
!
|
2008-12-13 15:08:18 -06:00
|
|
|
!===============================================================================
|
2008-11-11 16:12:26 -06:00
|
|
|
!
|
|
|
|
subroutine clear_mesh
|
|
|
|
|
|
|
|
use blocks, only : clear_blocks
|
|
|
|
use error , only : print_info
|
|
|
|
|
|
|
|
implicit none
|
|
|
|
|
2008-12-13 15:08:18 -06:00
|
|
|
!-------------------------------------------------------------------------------
|
2008-11-11 16:12:26 -06:00
|
|
|
!
|
|
|
|
! deallocate block structure
|
|
|
|
!
|
|
|
|
call clear_blocks
|
|
|
|
|
2008-12-08 20:03:01 -06:00
|
|
|
! deallocating coordinate variables
|
|
|
|
!
|
|
|
|
deallocate(ax)
|
|
|
|
deallocate(ay)
|
|
|
|
deallocate(az)
|
|
|
|
deallocate(adx)
|
|
|
|
deallocate(ady)
|
|
|
|
deallocate(adz)
|
|
|
|
deallocate(adxi)
|
|
|
|
deallocate(adyi)
|
|
|
|
deallocate(adzi)
|
|
|
|
|
2008-12-13 15:08:18 -06:00
|
|
|
!-------------------------------------------------------------------------------
|
2008-11-11 16:12:26 -06:00
|
|
|
!
|
|
|
|
end subroutine clear_mesh
|
|
|
|
|
2008-12-13 15:08:18 -06:00
|
|
|
!===============================================================================
|
2008-11-11 16:12:26 -06:00
|
|
|
!
|
|
|
|
end module
|