2008-11-05 22:16:24 -06:00
|
|
|
!!*****************************************************************************
|
2008-11-04 21:00:50 -06:00
|
|
|
!!
|
2008-11-11 16:12:26 -06:00
|
|
|
!! module: blocks - handling block storage
|
2008-11-04 21:00:50 -06:00
|
|
|
!!
|
|
|
|
!! Copyright (C) 2008 Grzegorz Kowal <kowal@astro.wisc.edu>
|
|
|
|
!!
|
2008-11-05 22:16:24 -06:00
|
|
|
!!*****************************************************************************
|
2008-11-04 21:00:50 -06:00
|
|
|
!!
|
|
|
|
!! 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/>.
|
|
|
|
!!
|
2008-11-05 22:16:24 -06:00
|
|
|
!!*****************************************************************************
|
2008-11-04 21:00:50 -06:00
|
|
|
!!
|
|
|
|
!
|
|
|
|
module blocks
|
|
|
|
|
|
|
|
implicit none
|
|
|
|
|
|
|
|
! parameters
|
|
|
|
!
|
2008-12-08 15:31:35 -06:00
|
|
|
integer(kind=4), parameter :: ndims = NDIMS
|
2008-11-04 21:00:50 -06:00
|
|
|
integer(kind=4), parameter :: nchild = 2**ndims
|
2008-12-08 15:31:35 -06:00
|
|
|
integer(kind=4), parameter :: idn = 1, imx = 2, imy = 3, imz = 4
|
|
|
|
#ifdef HYDRO
|
|
|
|
#ifdef ISO
|
|
|
|
integer(kind=4), parameter :: nvars = 4
|
|
|
|
#endif /* ISO */
|
|
|
|
#ifdef ADI
|
|
|
|
integer(kind=4), parameter :: ien = 5
|
2008-12-08 15:36:58 -06:00
|
|
|
integer(kind=4), parameter :: nvars = 5
|
2008-12-08 15:31:35 -06:00
|
|
|
#endif /* ADI */
|
|
|
|
#endif /* HYDRO */
|
2008-12-08 13:59:57 -06:00
|
|
|
#ifdef MHD
|
|
|
|
#ifdef ISO
|
|
|
|
integer(kind=4), parameter :: ibx = 5, iby = 6, ibz = 7
|
2008-12-08 15:36:58 -06:00
|
|
|
integer(kind=4), parameter :: nvars = 7
|
2008-12-08 15:31:35 -06:00
|
|
|
#endif /* ISO */
|
|
|
|
#ifdef ADI
|
2008-12-08 15:36:58 -06:00
|
|
|
integer(kind=4), parameter :: ien = 5, ibx = 6, iby = 7, ibz = 8
|
2008-12-08 13:59:57 -06:00
|
|
|
integer(kind=4), parameter :: nvars = 8
|
2008-12-08 15:31:35 -06:00
|
|
|
#endif /* ADI */
|
2008-12-08 13:59:57 -06:00
|
|
|
#endif /* MHD */
|
2008-11-04 21:00:50 -06:00
|
|
|
|
|
|
|
! define block type
|
|
|
|
!
|
2008-12-05 14:13:21 -06:00
|
|
|
type bpointer
|
|
|
|
type(block), pointer :: p
|
|
|
|
end type bpointer
|
|
|
|
|
2008-11-04 21:00:50 -06:00
|
|
|
type block
|
2008-12-05 14:04:12 -06:00
|
|
|
type(block), pointer :: next, prev, parent
|
2008-12-05 15:13:16 -06:00
|
|
|
type(bpointer) :: child(nchild), pneigh(ndims,2,2)
|
2008-11-04 21:00:50 -06:00
|
|
|
|
2008-12-05 14:04:12 -06:00
|
|
|
character :: config, leaf
|
2008-12-06 20:11:36 -06:00
|
|
|
integer(kind=4) :: refine
|
2008-11-11 16:12:26 -06:00
|
|
|
|
2008-12-05 14:04:12 -06:00
|
|
|
integer(kind=4) :: id, level
|
2008-12-05 14:19:23 -06:00
|
|
|
integer(kind=4) :: neigh(ndims,2,2)
|
2008-11-04 21:00:50 -06:00
|
|
|
|
|
|
|
real :: xmin, xmax, ymin, ymax, zmin, zmax
|
|
|
|
|
2008-12-08 12:14:13 -06:00
|
|
|
real, dimension(:,:,:,:), allocatable :: u
|
2008-11-04 21:00:50 -06:00
|
|
|
end type block
|
|
|
|
|
|
|
|
! stored pointers
|
|
|
|
!
|
2008-12-07 12:56:00 -06:00
|
|
|
type(block), pointer, save :: plist, plast
|
2008-11-07 00:10:09 -06:00
|
|
|
integer(kind=4) , save :: nblocks
|
2008-11-04 21:00:50 -06:00
|
|
|
|
2008-11-11 16:12:26 -06:00
|
|
|
! stored last id (should always increase)
|
|
|
|
!
|
|
|
|
integer(kind=4) , save :: last_id
|
|
|
|
|
2008-11-04 21:00:50 -06:00
|
|
|
contains
|
|
|
|
!
|
2008-11-05 22:16:24 -06:00
|
|
|
!======================================================================
|
2008-11-04 21:00:50 -06:00
|
|
|
!
|
2008-11-11 16:12:26 -06:00
|
|
|
! list_allocated: function checks if the block list is empty and
|
|
|
|
! returns true or false
|
|
|
|
!
|
|
|
|
!======================================================================
|
|
|
|
!
|
|
|
|
function list_allocated
|
|
|
|
|
|
|
|
implicit none
|
|
|
|
|
|
|
|
! output arguments
|
|
|
|
!
|
|
|
|
logical :: list_allocated
|
|
|
|
!
|
|
|
|
!----------------------------------------------------------------------
|
|
|
|
!
|
2008-12-07 12:56:00 -06:00
|
|
|
list_allocated = associated(plist)
|
2008-11-11 16:12:26 -06:00
|
|
|
|
|
|
|
return
|
|
|
|
|
|
|
|
!----------------------------------------------------------------------
|
|
|
|
!
|
|
|
|
end function list_allocated
|
|
|
|
!
|
|
|
|
!======================================================================
|
|
|
|
!
|
2008-11-07 00:10:09 -06:00
|
|
|
! allocate_block: subroutine allocates space for one block and returns
|
|
|
|
! pointer to this block
|
|
|
|
!
|
|
|
|
!======================================================================
|
|
|
|
!
|
|
|
|
subroutine allocate_block(pblock)
|
|
|
|
|
|
|
|
use config, only : ngrids
|
|
|
|
|
|
|
|
implicit none
|
|
|
|
|
|
|
|
! output arguments
|
|
|
|
!
|
|
|
|
type(block), pointer, intent(out) :: pblock
|
2008-12-05 15:13:16 -06:00
|
|
|
|
|
|
|
! local variables
|
|
|
|
!
|
|
|
|
integer :: i, j, k
|
2008-11-07 00:10:09 -06:00
|
|
|
!
|
|
|
|
!----------------------------------------------------------------------
|
|
|
|
!
|
|
|
|
! allocate block structure
|
|
|
|
!
|
|
|
|
allocate(pblock)
|
|
|
|
|
2008-11-11 16:12:26 -06:00
|
|
|
! set unique ID
|
|
|
|
!
|
|
|
|
pblock%id = increase_id()
|
|
|
|
|
2008-12-05 14:04:12 -06:00
|
|
|
! set configuration and leaf flags
|
|
|
|
!
|
|
|
|
pblock%config = 'N'
|
|
|
|
pblock%leaf = 'F'
|
|
|
|
|
2008-12-05 14:24:01 -06:00
|
|
|
! initialize refinement flag
|
|
|
|
!
|
|
|
|
pblock%refine = 0
|
|
|
|
|
2008-12-06 20:11:36 -06:00
|
|
|
! nullify pointers
|
|
|
|
!
|
|
|
|
nullify(pblock%next)
|
|
|
|
nullify(pblock%prev)
|
|
|
|
nullify(pblock%parent)
|
|
|
|
|
2008-11-11 16:12:26 -06:00
|
|
|
! reset neighbors
|
|
|
|
!
|
2008-12-05 14:04:12 -06:00
|
|
|
pblock%neigh(:,:,:) = -1
|
2008-12-05 15:13:16 -06:00
|
|
|
do i = 1, ndims
|
|
|
|
do j = 1, 2
|
|
|
|
do k = 1, 2
|
|
|
|
nullify(pblock%pneigh(i,j,k)%p)
|
|
|
|
end do
|
|
|
|
end do
|
|
|
|
end do
|
2008-11-11 16:12:26 -06:00
|
|
|
|
2008-11-07 00:10:09 -06:00
|
|
|
! allocate space for variables
|
|
|
|
!
|
2008-12-08 15:31:35 -06:00
|
|
|
#if NDIMS == 3
|
2008-12-08 12:14:13 -06:00
|
|
|
allocate(pblock%u(nvars,ngrids,ngrids,1))
|
2008-12-08 15:31:35 -06:00
|
|
|
#else /* NDIMS == 3 */
|
2008-12-08 12:14:13 -06:00
|
|
|
allocate(pblock%u(nvars,ngrids,ngrids,ngrids))
|
2008-12-08 15:31:35 -06:00
|
|
|
#endif /* NDIMS == 3 */
|
2008-11-07 00:10:09 -06:00
|
|
|
|
|
|
|
!----------------------------------------------------------------------
|
|
|
|
!
|
|
|
|
end subroutine allocate_block
|
|
|
|
!
|
|
|
|
!======================================================================
|
|
|
|
!
|
|
|
|
! deallocate_block: subroutine deallocates space ocuppied by a given
|
|
|
|
! block
|
|
|
|
!
|
|
|
|
!======================================================================
|
|
|
|
!
|
|
|
|
subroutine deallocate_block(pblock)
|
|
|
|
|
|
|
|
implicit none
|
|
|
|
|
|
|
|
! input arguments
|
|
|
|
!
|
|
|
|
type(block), pointer, intent(inout) :: pblock
|
|
|
|
!
|
|
|
|
!----------------------------------------------------------------------
|
|
|
|
!
|
|
|
|
! deallocate variables
|
|
|
|
!
|
2008-12-08 12:14:13 -06:00
|
|
|
deallocate(pblock%u)
|
2008-11-07 00:10:09 -06:00
|
|
|
|
|
|
|
! free and nullify the block
|
|
|
|
!
|
|
|
|
deallocate(pblock)
|
|
|
|
nullify(pblock)
|
|
|
|
|
|
|
|
!----------------------------------------------------------------------
|
|
|
|
!
|
|
|
|
end subroutine deallocate_block
|
|
|
|
!
|
|
|
|
!======================================================================
|
|
|
|
!
|
2008-11-11 16:12:26 -06:00
|
|
|
! append_block: subroutine allocates space for one block and appends
|
|
|
|
! it to the list
|
|
|
|
!
|
|
|
|
!======================================================================
|
|
|
|
!
|
|
|
|
subroutine append_block(pblock)
|
|
|
|
|
|
|
|
implicit none
|
|
|
|
|
|
|
|
! output arguments
|
|
|
|
!
|
|
|
|
type(block), pointer, intent(out) :: pblock
|
|
|
|
!
|
|
|
|
!----------------------------------------------------------------------
|
|
|
|
!
|
|
|
|
! allocate block
|
|
|
|
!
|
|
|
|
call allocate_block(pblock)
|
|
|
|
|
|
|
|
! add to the list
|
|
|
|
!
|
|
|
|
if (list_allocated()) then
|
|
|
|
pblock%prev => plast
|
|
|
|
nullify(pblock%next)
|
|
|
|
plast%next => pblock
|
|
|
|
|
|
|
|
plast => pblock
|
|
|
|
else
|
2008-12-07 12:56:00 -06:00
|
|
|
plist => pblock
|
2008-11-11 16:12:26 -06:00
|
|
|
plast => pblock
|
|
|
|
nullify(pblock%prev)
|
|
|
|
nullify(pblock%next)
|
|
|
|
endif
|
|
|
|
|
|
|
|
!----------------------------------------------------------------------
|
|
|
|
!
|
|
|
|
end subroutine append_block
|
|
|
|
!
|
|
|
|
!======================================================================
|
|
|
|
!
|
|
|
|
! allocate_blocks: subroutine allocates a configuration of blocks
|
|
|
|
!
|
|
|
|
!======================================================================
|
|
|
|
!
|
2008-12-07 12:56:00 -06:00
|
|
|
subroutine allocate_blocks(block_config, xmn, xmx, ymn, ymx &
|
2008-11-11 16:12:26 -06:00
|
|
|
, zmn, zmx)
|
|
|
|
|
|
|
|
use error, only : print_error
|
|
|
|
|
|
|
|
implicit none
|
|
|
|
|
|
|
|
! input parameters
|
|
|
|
!
|
|
|
|
character(len=1), intent(in) :: block_config
|
|
|
|
real , intent(in) :: xmn, xmx, ymn, ymx, zmn, zmx
|
|
|
|
|
|
|
|
! local pointers
|
|
|
|
!
|
|
|
|
type(block), pointer :: pbl, pbr, ptl, ptr
|
|
|
|
|
|
|
|
! local variables
|
|
|
|
!
|
|
|
|
real :: xl, xc, xr, yl, yc, yr, zl, zc, zr
|
|
|
|
!
|
|
|
|
!----------------------------------------------------------------------
|
|
|
|
!
|
|
|
|
select case(block_config)
|
2008-12-06 20:11:36 -06:00
|
|
|
case('z', 'Z')
|
|
|
|
|
|
|
|
! create root blocks
|
|
|
|
!
|
|
|
|
call append_block(pbl)
|
|
|
|
call append_block(pbr)
|
|
|
|
call append_block(ptl)
|
|
|
|
call append_block(ptr)
|
2008-11-11 16:12:26 -06:00
|
|
|
|
2008-12-06 20:11:36 -06:00
|
|
|
! set configurations
|
|
|
|
!
|
|
|
|
pbl%config = 'Z'
|
|
|
|
pbr%config = 'Z'
|
|
|
|
ptl%config = 'Z'
|
|
|
|
ptr%config = 'Z'
|
2008-11-11 16:12:26 -06:00
|
|
|
|
2008-12-06 20:11:36 -06:00
|
|
|
! copy pointer of the first block in chain
|
|
|
|
!
|
2008-12-07 12:56:00 -06:00
|
|
|
plist => pbl
|
2008-12-06 20:11:36 -06:00
|
|
|
|
|
|
|
case('n', 'N')
|
|
|
|
|
|
|
|
! create root blocks
|
2008-11-11 16:12:26 -06:00
|
|
|
!
|
|
|
|
call append_block(pbl)
|
|
|
|
call append_block(ptl)
|
|
|
|
call append_block(ptr)
|
|
|
|
call append_block(pbr)
|
|
|
|
|
2008-12-05 14:04:12 -06:00
|
|
|
! set configurations
|
|
|
|
!
|
|
|
|
pbl%config = 'D'
|
|
|
|
ptl%config = 'N'
|
|
|
|
ptr%config = 'N'
|
|
|
|
pbr%config = 'C'
|
|
|
|
|
2008-12-06 20:11:36 -06:00
|
|
|
! copy pointer of the first block in chain
|
|
|
|
!
|
2008-12-07 12:56:00 -06:00
|
|
|
plist => pbl
|
2008-12-06 20:11:36 -06:00
|
|
|
|
|
|
|
case default
|
|
|
|
call print_error("blocks::allocate_blocks","Configuration '" // block_config // "' not supported! Terminating!")
|
|
|
|
end select
|
|
|
|
|
2008-12-05 14:04:12 -06:00
|
|
|
! set leaf flags
|
|
|
|
!
|
2008-12-06 20:11:36 -06:00
|
|
|
pbl%leaf = 'T'
|
|
|
|
pbr%leaf = 'T'
|
|
|
|
ptl%leaf = 'T'
|
|
|
|
ptr%leaf = 'T'
|
2008-12-05 14:04:12 -06:00
|
|
|
|
2008-11-11 16:12:26 -06:00
|
|
|
! set neighbors
|
|
|
|
!
|
2008-12-06 20:11:36 -06:00
|
|
|
pbl%neigh(1,2,:) = pbr%id
|
|
|
|
pbl%neigh(2,2,:) = ptl%id
|
2008-11-11 16:12:26 -06:00
|
|
|
|
2008-12-06 20:11:36 -06:00
|
|
|
pbr%neigh(1,1,:) = pbl%id
|
|
|
|
pbr%neigh(2,2,:) = ptr%id
|
2008-11-11 16:12:26 -06:00
|
|
|
|
2008-12-06 20:11:36 -06:00
|
|
|
ptl%neigh(1,2,:) = ptr%id
|
|
|
|
ptl%neigh(2,1,:) = pbl%id
|
2008-11-11 16:12:26 -06:00
|
|
|
|
2008-12-06 20:11:36 -06:00
|
|
|
ptr%neigh(1,1,:) = ptl%id
|
|
|
|
ptr%neigh(2,1,:) = pbr%id
|
2008-11-11 16:12:26 -06:00
|
|
|
|
2008-12-05 15:13:16 -06:00
|
|
|
! set neighbor pointers
|
|
|
|
!
|
2008-12-06 20:11:36 -06:00
|
|
|
pbl%pneigh(1,2,1)%p => pbr ! BL right -> BR
|
|
|
|
pbl%pneigh(1,2,2)%p => pbr
|
|
|
|
pbl%pneigh(2,2,1)%p => ptl ! BL top -> TL
|
|
|
|
pbl%pneigh(2,2,2)%p => ptl
|
2008-12-05 15:13:16 -06:00
|
|
|
|
2008-12-06 20:11:36 -06:00
|
|
|
pbr%pneigh(1,1,1)%p => pbl ! BR left -> BL
|
|
|
|
pbr%pneigh(1,1,2)%p => pbl
|
|
|
|
pbr%pneigh(2,2,1)%p => ptr ! BR top -> TR
|
|
|
|
pbr%pneigh(2,2,2)%p => ptr
|
2008-12-05 15:13:16 -06:00
|
|
|
|
2008-12-06 20:11:36 -06:00
|
|
|
ptl%pneigh(1,2,1)%p => ptr ! TL right -> TR
|
|
|
|
ptl%pneigh(1,2,2)%p => ptr
|
|
|
|
ptl%pneigh(2,1,1)%p => pbl ! TL bottom -> BL
|
|
|
|
ptl%pneigh(2,1,2)%p => pbl
|
2008-12-05 15:13:16 -06:00
|
|
|
|
2008-12-06 20:11:36 -06:00
|
|
|
ptr%pneigh(1,1,1)%p => ptl ! TR left -> TL
|
|
|
|
ptr%pneigh(1,1,2)%p => ptl
|
|
|
|
ptr%pneigh(2,1,1)%p => pbr ! TR bottom -> BR
|
|
|
|
ptr%pneigh(2,1,2)%p => pbr
|
2008-12-05 15:13:16 -06:00
|
|
|
|
2008-11-11 16:12:26 -06:00
|
|
|
! set block bounds
|
|
|
|
!
|
2008-12-06 20:11:36 -06:00
|
|
|
xl = xmn
|
|
|
|
xc = xmn + (xmx - xmn) / 2
|
|
|
|
xr = xmx
|
|
|
|
yl = ymn
|
|
|
|
yc = ymn + (ymx - ymn) / 2
|
|
|
|
yr = ymx
|
|
|
|
|
|
|
|
pbl%xmin = xl
|
|
|
|
pbl%xmax = xc
|
|
|
|
pbl%ymin = yl
|
|
|
|
pbl%ymax = yc
|
|
|
|
|
|
|
|
ptl%xmin = xl
|
|
|
|
ptl%xmax = xc
|
|
|
|
ptl%ymin = yc
|
|
|
|
ptl%ymax = yr
|
|
|
|
|
|
|
|
ptr%xmin = xc
|
|
|
|
ptr%xmax = xr
|
|
|
|
ptr%ymin = yc
|
|
|
|
ptr%ymax = yr
|
|
|
|
|
|
|
|
pbr%xmin = xc
|
|
|
|
pbr%xmax = xr
|
|
|
|
pbr%ymin = yl
|
|
|
|
pbr%ymax = yc
|
2008-11-11 16:12:26 -06:00
|
|
|
|
|
|
|
!----------------------------------------------------------------------
|
|
|
|
!
|
|
|
|
end subroutine allocate_blocks
|
|
|
|
!
|
|
|
|
!======================================================================
|
|
|
|
!
|
2008-11-04 21:00:50 -06:00
|
|
|
! init_blocks: subroutine initializes the structure of blocks
|
|
|
|
!
|
2008-11-05 22:16:24 -06:00
|
|
|
!======================================================================
|
2008-11-04 21:00:50 -06:00
|
|
|
!
|
2008-11-11 16:12:26 -06:00
|
|
|
subroutine init_blocks()
|
2008-11-04 21:00:50 -06:00
|
|
|
|
2008-11-11 16:12:26 -06:00
|
|
|
use config, only : ngrids, iblocks, jblocks, kblocks, nghost, ncells
|
|
|
|
! use problem, only : init_problem
|
2008-11-07 00:10:09 -06:00
|
|
|
|
2008-11-04 21:00:50 -06:00
|
|
|
implicit none
|
|
|
|
|
2008-11-11 16:12:26 -06:00
|
|
|
! local variables
|
|
|
|
!
|
|
|
|
integer(kind=4) :: i, j, k
|
|
|
|
|
2008-11-04 21:00:50 -06:00
|
|
|
! pointers
|
|
|
|
!
|
|
|
|
type(block), pointer :: pcurr
|
|
|
|
!
|
|
|
|
!----------------------------------------------------------------------
|
|
|
|
!
|
|
|
|
! first check if block list is empty
|
|
|
|
!
|
2008-12-07 12:56:00 -06:00
|
|
|
if (associated(plist)) then
|
2008-11-04 21:00:50 -06:00
|
|
|
write(*,*) 'ERROR: Block list already associated!'
|
|
|
|
endif
|
|
|
|
|
|
|
|
! nullify all pointers
|
|
|
|
!
|
2008-12-07 12:56:00 -06:00
|
|
|
nullify(plist)
|
2008-11-04 21:00:50 -06:00
|
|
|
|
2008-11-07 00:10:09 -06:00
|
|
|
! reset number of blocks
|
|
|
|
!
|
|
|
|
nblocks = 0
|
|
|
|
|
2008-11-11 16:12:26 -06:00
|
|
|
! reset ID
|
2008-11-04 21:00:50 -06:00
|
|
|
!
|
2008-11-11 16:12:26 -06:00
|
|
|
last_id = 0
|
2008-11-04 21:00:50 -06:00
|
|
|
|
2008-11-05 22:16:24 -06:00
|
|
|
!----------------------------------------------------------------------
|
|
|
|
!
|
2008-11-04 21:00:50 -06:00
|
|
|
end subroutine init_blocks
|
|
|
|
!
|
2008-11-05 22:16:24 -06:00
|
|
|
!======================================================================
|
2008-11-04 21:00:50 -06:00
|
|
|
!
|
|
|
|
! clear_blocks: subroutine clears the structure of blocks
|
|
|
|
!
|
2008-11-05 22:16:24 -06:00
|
|
|
!======================================================================
|
2008-11-04 21:00:50 -06:00
|
|
|
!
|
|
|
|
subroutine clear_blocks
|
|
|
|
|
|
|
|
implicit none
|
|
|
|
|
|
|
|
! pointers
|
|
|
|
!
|
|
|
|
type(block), pointer :: pcurr
|
|
|
|
!
|
|
|
|
!----------------------------------------------------------------------
|
|
|
|
!
|
|
|
|
! until list is free, reiterate over all chunks
|
|
|
|
!
|
2008-12-07 12:56:00 -06:00
|
|
|
do while(associated(plist))
|
2008-11-04 21:00:50 -06:00
|
|
|
|
|
|
|
! assign temporary pointer to the next chunk
|
|
|
|
!
|
2008-12-07 12:56:00 -06:00
|
|
|
pcurr => plist%next
|
2008-11-04 21:00:50 -06:00
|
|
|
|
|
|
|
! deallocate the content of current block
|
|
|
|
!
|
2008-12-07 12:56:00 -06:00
|
|
|
! write (*,"(i9.9,2x,i2,1x,4(1x,f6.3))") plist%id, plist%level, plist%xmin, plist%xmax, plist%ymin, plist%ymax
|
2008-11-04 21:00:50 -06:00
|
|
|
|
|
|
|
! deallocate and nullify the current block
|
|
|
|
!
|
2008-12-07 12:56:00 -06:00
|
|
|
call deallocate_block(plist)
|
2008-11-04 21:00:50 -06:00
|
|
|
|
|
|
|
! assign pointer to the current chunk
|
|
|
|
!
|
2008-12-07 12:56:00 -06:00
|
|
|
plist => pcurr
|
2008-11-04 21:00:50 -06:00
|
|
|
|
|
|
|
end do
|
|
|
|
|
2008-11-05 22:16:24 -06:00
|
|
|
!----------------------------------------------------------------------
|
|
|
|
!
|
2008-11-04 21:00:50 -06:00
|
|
|
end subroutine clear_blocks
|
2008-11-11 16:12:26 -06:00
|
|
|
!
|
|
|
|
!======================================================================
|
|
|
|
!
|
|
|
|
! increase_id: function increases last ID by 1 and returns it
|
|
|
|
!
|
|
|
|
!======================================================================
|
|
|
|
!
|
|
|
|
function increase_id
|
|
|
|
|
|
|
|
implicit none
|
|
|
|
|
|
|
|
! return variable
|
|
|
|
!
|
|
|
|
integer(kind=4) :: increase_id
|
|
|
|
!
|
|
|
|
!----------------------------------------------------------------------
|
|
|
|
!
|
|
|
|
! increase ID by 1
|
|
|
|
!
|
|
|
|
last_id = last_id + 1
|
|
|
|
|
|
|
|
! return ID
|
|
|
|
!
|
|
|
|
increase_id = last_id
|
|
|
|
|
|
|
|
return
|
|
|
|
|
|
|
|
!----------------------------------------------------------------------
|
|
|
|
!
|
|
|
|
end function increase_id
|
2008-12-05 14:04:12 -06:00
|
|
|
!
|
|
|
|
!======================================================================
|
|
|
|
!
|
|
|
|
! refine_block: subroutine refines selected block
|
|
|
|
!
|
|
|
|
!======================================================================
|
|
|
|
!
|
|
|
|
subroutine refine_block(pblock)
|
|
|
|
|
|
|
|
use error, only : print_error
|
|
|
|
|
|
|
|
implicit none
|
|
|
|
|
|
|
|
! input parameters
|
|
|
|
!
|
|
|
|
type(block), pointer, intent(inout) :: pblock
|
|
|
|
|
|
|
|
! pointers
|
|
|
|
!
|
2008-12-06 20:11:36 -06:00
|
|
|
type(block), pointer :: pb, pbl, pbr, ptl, ptr, pneigh
|
2008-12-05 14:04:12 -06:00
|
|
|
!
|
|
|
|
!----------------------------------------------------------------------
|
|
|
|
!
|
|
|
|
! check if pointer is associated
|
|
|
|
!
|
|
|
|
if (associated(pblock)) then
|
|
|
|
|
2008-12-06 20:11:36 -06:00
|
|
|
! unset the refinement and leaf flags for the parent block
|
2008-12-05 14:04:12 -06:00
|
|
|
!
|
2008-12-06 20:11:36 -06:00
|
|
|
pblock%refine = 0
|
|
|
|
pblock%leaf = 'F'
|
2008-12-05 14:04:12 -06:00
|
|
|
|
|
|
|
! create 4 blocks
|
|
|
|
!
|
|
|
|
call allocate_block(pbl)
|
2008-12-06 20:11:36 -06:00
|
|
|
call allocate_block(pbr)
|
2008-12-05 14:04:12 -06:00
|
|
|
call allocate_block(ptl)
|
|
|
|
call allocate_block(ptr)
|
|
|
|
|
|
|
|
! set parent
|
|
|
|
!
|
|
|
|
pbl%parent => pblock
|
|
|
|
pbr%parent => pblock
|
|
|
|
ptl%parent => pblock
|
|
|
|
ptr%parent => pblock
|
|
|
|
|
2008-12-05 14:22:02 -06:00
|
|
|
! set level
|
|
|
|
!
|
|
|
|
pbl%level = pblock%level + 1
|
|
|
|
pbr%level = pbl%level
|
|
|
|
ptl%level = pbl%level
|
|
|
|
ptr%level = pbl%level
|
|
|
|
|
2008-12-05 14:04:12 -06:00
|
|
|
! set leaf flags
|
|
|
|
!
|
|
|
|
pbl%leaf = 'T'
|
2008-12-06 20:11:36 -06:00
|
|
|
pbr%leaf = 'T'
|
2008-12-05 14:04:12 -06:00
|
|
|
ptl%leaf = 'T'
|
|
|
|
ptr%leaf = 'T'
|
|
|
|
|
|
|
|
! set bounds
|
|
|
|
!
|
|
|
|
pbl%xmin = pblock%xmin
|
|
|
|
pbl%xmax = 0.5 * (pblock%xmin + pblock%xmax)
|
|
|
|
pbl%ymin = pblock%ymin
|
|
|
|
pbl%ymax = 0.5 * (pblock%ymin + pblock%ymax)
|
|
|
|
|
|
|
|
pbr%xmin = pbl%xmax
|
|
|
|
pbr%xmax = pblock%xmax
|
|
|
|
pbr%ymin = pblock%ymin
|
|
|
|
pbr%ymax = pbl%ymax
|
|
|
|
|
|
|
|
ptl%xmin = pblock%xmin
|
|
|
|
ptl%xmax = pbl%xmax
|
|
|
|
ptl%ymin = pbl%ymax
|
|
|
|
ptl%ymax = pblock%ymax
|
|
|
|
|
|
|
|
ptr%xmin = ptl%xmax
|
|
|
|
ptr%xmax = pblock%xmax
|
|
|
|
ptr%ymin = ptl%ymin
|
|
|
|
ptr%ymax = pblock%ymax
|
|
|
|
|
2008-12-06 20:11:36 -06:00
|
|
|
! set neighbor pointers to the refined blocks
|
2008-12-05 14:04:12 -06:00
|
|
|
!
|
2008-12-06 20:11:36 -06:00
|
|
|
pbl%pneigh(1,2,1)%p => pbr ! BL right -> BR
|
2008-12-05 15:13:16 -06:00
|
|
|
pbl%pneigh(1,2,2)%p => pbr
|
2008-12-06 20:11:36 -06:00
|
|
|
pbl%pneigh(2,2,1)%p => ptl ! BL top -> TL
|
2008-12-05 15:13:16 -06:00
|
|
|
pbl%pneigh(2,2,2)%p => ptl
|
2008-12-06 20:11:36 -06:00
|
|
|
|
|
|
|
pbr%pneigh(1,1,1)%p => pbl ! BR left -> BL
|
2008-12-05 15:13:16 -06:00
|
|
|
pbr%pneigh(1,1,2)%p => pbl
|
2008-12-06 20:11:36 -06:00
|
|
|
pbr%pneigh(2,2,1)%p => ptr ! BR top -> TR
|
2008-12-05 15:13:16 -06:00
|
|
|
pbr%pneigh(2,2,2)%p => ptr
|
2008-12-06 20:11:36 -06:00
|
|
|
|
|
|
|
ptl%pneigh(1,2,1)%p => ptr ! TL right -> TR
|
2008-12-05 15:13:16 -06:00
|
|
|
ptl%pneigh(1,2,2)%p => ptr
|
2008-12-06 20:11:36 -06:00
|
|
|
ptl%pneigh(2,1,1)%p => pbl ! TL bottom -> BL
|
2008-12-05 15:13:16 -06:00
|
|
|
ptl%pneigh(2,1,2)%p => pbl
|
2008-12-06 20:11:36 -06:00
|
|
|
|
|
|
|
ptr%pneigh(1,1,1)%p => ptl ! TR left -> TL
|
2008-12-05 15:13:16 -06:00
|
|
|
ptr%pneigh(1,1,2)%p => ptl
|
2008-12-06 20:11:36 -06:00
|
|
|
ptr%pneigh(2,1,1)%p => pbr ! TR bottom -> BR
|
2008-12-05 15:13:16 -06:00
|
|
|
ptr%pneigh(2,1,2)%p => pbr
|
|
|
|
|
2008-12-06 20:11:36 -06:00
|
|
|
! set pointer to the neighbors of the parent block
|
|
|
|
!
|
|
|
|
pneigh => pblock%pneigh(1,1,1)%p ! left lower neighbor
|
|
|
|
if (associated(pneigh)) then
|
|
|
|
pbl%pneigh(1,1,1)%p => pneigh
|
|
|
|
pbl%pneigh(1,1,2)%p => pneigh
|
|
|
|
|
|
|
|
if (pneigh%level .eq. pblock%level) then
|
|
|
|
pneigh%pneigh(1,2,1)%p => pbl
|
|
|
|
pneigh%pneigh(1,2,2)%p => ptl
|
|
|
|
endif
|
|
|
|
if (pneigh%level .eq. pbl%level) then
|
|
|
|
pneigh%pneigh(1,2,1)%p => pbl
|
|
|
|
pneigh%pneigh(1,2,2)%p => pbl
|
|
|
|
endif
|
|
|
|
endif
|
|
|
|
|
|
|
|
pneigh => pblock%pneigh(1,1,2)%p ! left upper neighbor
|
|
|
|
if (associated(pneigh)) then
|
|
|
|
ptl%pneigh(1,1,1)%p => pneigh
|
|
|
|
ptl%pneigh(1,1,2)%p => pneigh
|
|
|
|
|
|
|
|
if (pneigh%level .eq. pblock%level) then
|
|
|
|
pneigh%pneigh(1,2,1)%p => pbl
|
|
|
|
pneigh%pneigh(1,2,2)%p => ptl
|
|
|
|
endif
|
|
|
|
if (pneigh%level .eq. ptl%level) then
|
|
|
|
pneigh%pneigh(1,2,1)%p => ptl
|
|
|
|
pneigh%pneigh(1,2,2)%p => ptl
|
|
|
|
endif
|
|
|
|
endif
|
|
|
|
|
|
|
|
pneigh => pblock%pneigh(1,2,1)%p ! right lower neighbor
|
|
|
|
if (associated(pneigh)) then
|
|
|
|
pbr%pneigh(1,2,1)%p => pneigh
|
|
|
|
pbr%pneigh(1,2,2)%p => pneigh
|
|
|
|
|
|
|
|
if (pneigh%level .eq. pblock%level) then
|
|
|
|
pneigh%pneigh(1,1,1)%p => pbr
|
|
|
|
pneigh%pneigh(1,1,2)%p => ptr
|
|
|
|
endif
|
|
|
|
if (pneigh%level .eq. pbr%level) then
|
|
|
|
pneigh%pneigh(1,1,1)%p => pbr
|
|
|
|
pneigh%pneigh(1,1,2)%p => pbr
|
|
|
|
endif
|
|
|
|
endif
|
|
|
|
|
|
|
|
pneigh => pblock%pneigh(1,2,2)%p ! right upper neighbor
|
|
|
|
if (associated(pneigh)) then
|
|
|
|
ptr%pneigh(1,2,1)%p => pneigh
|
|
|
|
ptr%pneigh(1,2,2)%p => pneigh
|
|
|
|
|
|
|
|
if (pneigh%level .eq. pblock%level) then
|
|
|
|
pneigh%pneigh(1,1,1)%p => pbr
|
|
|
|
pneigh%pneigh(1,1,2)%p => ptr
|
|
|
|
endif
|
|
|
|
if (pneigh%level .eq. ptr%level) then
|
|
|
|
pneigh%pneigh(1,1,1)%p => ptr
|
|
|
|
pneigh%pneigh(1,1,2)%p => ptr
|
|
|
|
endif
|
|
|
|
endif
|
|
|
|
|
|
|
|
pneigh => pblock%pneigh(2,1,1)%p ! bottom left neighbor
|
|
|
|
if (associated(pneigh)) then
|
|
|
|
pbl%pneigh(2,1,1)%p => pneigh
|
|
|
|
pbl%pneigh(2,1,2)%p => pneigh
|
|
|
|
|
|
|
|
if (pneigh%level .eq. pblock%level) then
|
|
|
|
pneigh%pneigh(2,2,1)%p => pbl
|
|
|
|
pneigh%pneigh(2,2,2)%p => pbr
|
|
|
|
endif
|
|
|
|
if (pneigh%level .eq. pbl%level) then
|
|
|
|
pneigh%pneigh(2,2,1)%p => pbl
|
|
|
|
pneigh%pneigh(2,2,2)%p => pbl
|
|
|
|
endif
|
|
|
|
endif
|
|
|
|
|
|
|
|
pneigh => pblock%pneigh(2,1,2)%p ! bottom right neighbor
|
|
|
|
if (associated(pneigh)) then
|
|
|
|
pbr%pneigh(2,1,1)%p => pneigh
|
|
|
|
pbr%pneigh(2,1,2)%p => pneigh
|
|
|
|
|
|
|
|
if (pneigh%level .eq. pblock%level) then
|
|
|
|
pneigh%pneigh(2,2,1)%p => pbl
|
|
|
|
pneigh%pneigh(2,2,2)%p => pbr
|
|
|
|
endif
|
|
|
|
if (pneigh%level .eq. pbr%level) then
|
|
|
|
pneigh%pneigh(2,2,1)%p => pbr
|
|
|
|
pneigh%pneigh(2,2,2)%p => pbr
|
|
|
|
endif
|
|
|
|
endif
|
|
|
|
|
|
|
|
pneigh => pblock%pneigh(2,2,1)%p ! top left neighbor
|
|
|
|
if (associated(pneigh)) then
|
|
|
|
ptl%pneigh(2,2,1)%p => pneigh
|
|
|
|
ptl%pneigh(2,2,2)%p => pneigh
|
|
|
|
|
|
|
|
if (pneigh%level .eq. pblock%level) then
|
|
|
|
pneigh%pneigh(2,1,1)%p => ptl
|
|
|
|
pneigh%pneigh(2,1,2)%p => ptr
|
|
|
|
endif
|
|
|
|
if (pneigh%level .eq. ptl%level) then
|
|
|
|
pneigh%pneigh(2,1,1)%p => ptl
|
|
|
|
pneigh%pneigh(2,1,2)%p => ptl
|
|
|
|
endif
|
|
|
|
endif
|
|
|
|
|
|
|
|
pneigh => pblock%pneigh(2,2,2)%p ! top right neighbor
|
|
|
|
if (associated(pneigh)) then
|
|
|
|
ptr%pneigh(2,2,1)%p => pneigh
|
|
|
|
ptr%pneigh(2,2,2)%p => pneigh
|
|
|
|
|
|
|
|
if (pneigh%level .eq. pblock%level) then
|
|
|
|
pneigh%pneigh(2,1,1)%p => ptl
|
|
|
|
pneigh%pneigh(2,1,2)%p => ptr
|
|
|
|
endif
|
|
|
|
if (pneigh%level .eq. ptr%level) then
|
|
|
|
pneigh%pneigh(2,1,1)%p => ptr
|
|
|
|
pneigh%pneigh(2,1,2)%p => ptr
|
|
|
|
endif
|
|
|
|
endif
|
2008-12-05 14:04:12 -06:00
|
|
|
|
|
|
|
! set children
|
|
|
|
!
|
2008-12-05 14:13:21 -06:00
|
|
|
pblock%child(1)%p => pbl
|
|
|
|
pblock%child(2)%p => pbr
|
|
|
|
pblock%child(3)%p => ptl
|
|
|
|
pblock%child(4)%p => ptr
|
2008-12-05 14:04:12 -06:00
|
|
|
|
|
|
|
! depending on the configuration of the parent block
|
|
|
|
!
|
|
|
|
select case(pblock%config)
|
2008-12-06 20:11:36 -06:00
|
|
|
case('z', 'Z')
|
|
|
|
|
|
|
|
! set blocks configurations
|
|
|
|
!
|
|
|
|
pbl%config = 'Z'
|
|
|
|
pbr%config = 'Z'
|
|
|
|
ptl%config = 'Z'
|
|
|
|
ptr%config = 'Z'
|
|
|
|
|
|
|
|
! connect blocks in a chain
|
|
|
|
!
|
|
|
|
pbl%next => pbr
|
|
|
|
pbr%next => ptl
|
|
|
|
ptl%next => ptr
|
|
|
|
|
|
|
|
pbr%prev => pbl
|
|
|
|
ptl%prev => pbr
|
|
|
|
ptr%prev => ptl
|
|
|
|
|
|
|
|
! insert this chain after the parent block
|
|
|
|
!
|
|
|
|
pb => pblock%next
|
|
|
|
if (associated(pb)) then
|
|
|
|
pb%prev => ptr
|
|
|
|
ptr%next => pb
|
|
|
|
else
|
|
|
|
plast => ptr
|
|
|
|
nullify(ptr%next)
|
|
|
|
endif
|
|
|
|
pblock%next => pbl
|
|
|
|
pbl%prev => pblock
|
|
|
|
|
|
|
|
pblock => ptr
|
|
|
|
|
2008-12-05 14:04:12 -06:00
|
|
|
case('n', 'N')
|
|
|
|
|
|
|
|
! set blocks configurations
|
|
|
|
!
|
|
|
|
pbl%config = 'D'
|
|
|
|
ptl%config = 'N'
|
|
|
|
ptr%config = 'N'
|
|
|
|
pbr%config = 'C'
|
|
|
|
|
|
|
|
! connect blocks in a chain
|
|
|
|
!
|
|
|
|
pbl%next => ptl
|
|
|
|
ptl%next => ptr
|
|
|
|
ptr%next => pbr
|
|
|
|
|
|
|
|
ptl%prev => pbl
|
|
|
|
ptr%prev => ptl
|
|
|
|
pbr%prev => ptr
|
|
|
|
|
2008-12-06 20:11:36 -06:00
|
|
|
! insert this chain after the parent the block
|
2008-12-05 14:04:12 -06:00
|
|
|
!
|
2008-12-06 20:11:36 -06:00
|
|
|
pb => pblock%next
|
2008-12-05 14:04:12 -06:00
|
|
|
if (associated(pb)) then
|
2008-12-06 20:11:36 -06:00
|
|
|
pb%prev => pbr
|
|
|
|
pbr%next => pb
|
2008-12-05 14:04:12 -06:00
|
|
|
endif
|
2008-12-06 20:11:36 -06:00
|
|
|
pbl%prev => pblock
|
|
|
|
pblock%next => pbl
|
|
|
|
|
|
|
|
pblock => pbr
|
2008-12-05 14:04:12 -06:00
|
|
|
|
|
|
|
case('d', 'D')
|
|
|
|
|
|
|
|
! set blocks configurations
|
|
|
|
!
|
|
|
|
pbl%config = 'N'
|
|
|
|
pbr%config = 'D'
|
|
|
|
ptr%config = 'D'
|
|
|
|
ptl%config = 'U'
|
|
|
|
|
|
|
|
! connect blocks in a chain
|
|
|
|
!
|
|
|
|
pbl%next => pbr
|
|
|
|
pbr%next => ptr
|
|
|
|
ptr%next => ptl
|
|
|
|
|
|
|
|
pbr%prev => pbl
|
|
|
|
ptr%prev => pbr
|
|
|
|
ptl%prev => ptr
|
|
|
|
|
|
|
|
! insert this chain in the block list
|
|
|
|
!
|
2008-12-06 20:11:36 -06:00
|
|
|
pb => pblock%next
|
2008-12-05 14:04:12 -06:00
|
|
|
if (associated(pb)) then
|
2008-12-06 20:11:36 -06:00
|
|
|
pb%prev => ptl
|
|
|
|
ptl%next => pb
|
2008-12-05 14:04:12 -06:00
|
|
|
endif
|
2008-12-06 20:11:36 -06:00
|
|
|
pbl%prev => pblock
|
|
|
|
pblock%next => pbl
|
|
|
|
|
|
|
|
pblock => ptl
|
2008-12-05 14:04:12 -06:00
|
|
|
|
|
|
|
case('c', 'C')
|
|
|
|
|
|
|
|
! set blocks configurations
|
|
|
|
!
|
|
|
|
ptr%config = 'U'
|
|
|
|
ptl%config = 'C'
|
|
|
|
pbl%config = 'C'
|
|
|
|
pbr%config = 'N'
|
|
|
|
|
|
|
|
! connect blocks in a chain
|
|
|
|
!
|
|
|
|
ptr%next => ptl
|
|
|
|
ptl%next => pbl
|
|
|
|
pbl%next => pbr
|
|
|
|
|
|
|
|
ptl%prev => ptr
|
|
|
|
pbl%prev => ptl
|
|
|
|
pbr%prev => pbl
|
|
|
|
|
|
|
|
! insert this chain in the block list
|
|
|
|
!
|
2008-12-06 20:11:36 -06:00
|
|
|
pb => pblock%next
|
2008-12-05 14:04:12 -06:00
|
|
|
if (associated(pb)) then
|
2008-12-06 20:11:36 -06:00
|
|
|
pb%prev => pbr
|
|
|
|
pbr%next => pb
|
2008-12-05 14:04:12 -06:00
|
|
|
endif
|
2008-12-06 20:11:36 -06:00
|
|
|
ptr%prev => pblock
|
|
|
|
pblock%next => ptr
|
|
|
|
|
|
|
|
pblock => pbr
|
2008-12-05 14:04:12 -06:00
|
|
|
|
|
|
|
case('u', 'U')
|
|
|
|
|
|
|
|
! set blocks configurations
|
|
|
|
!
|
|
|
|
ptr%config = 'C'
|
|
|
|
pbr%config = 'U'
|
|
|
|
pbl%config = 'U'
|
|
|
|
ptl%config = 'D'
|
|
|
|
|
|
|
|
! connect blocks in a chain
|
|
|
|
!
|
|
|
|
ptr%next => pbr
|
|
|
|
pbr%next => pbl
|
|
|
|
pbl%next => ptl
|
|
|
|
|
|
|
|
pbr%prev => ptr
|
|
|
|
pbl%prev => pbr
|
|
|
|
ptl%prev => pbl
|
|
|
|
|
|
|
|
! insert this chain in the block list
|
|
|
|
!
|
2008-12-06 20:11:36 -06:00
|
|
|
pb => pblock%next
|
2008-12-05 14:04:12 -06:00
|
|
|
if (associated(pb)) then
|
2008-12-06 20:11:36 -06:00
|
|
|
pb%prev => ptl
|
|
|
|
ptl%next => pb
|
2008-12-05 14:04:12 -06:00
|
|
|
endif
|
2008-12-06 20:11:36 -06:00
|
|
|
ptr%prev => pblock
|
|
|
|
pblock%next => ptr
|
|
|
|
|
|
|
|
pblock => ptl
|
2008-12-05 14:04:12 -06:00
|
|
|
|
|
|
|
end select
|
|
|
|
|
|
|
|
else
|
|
|
|
|
|
|
|
! terminate program if the pointer passed by argument is not associated
|
|
|
|
!
|
|
|
|
call print_error("blocks::refine_blocks","Input pointer is not associated! Terminating!")
|
|
|
|
endif
|
|
|
|
|
|
|
|
!----------------------------------------------------------------------
|
|
|
|
!
|
|
|
|
end subroutine refine_block
|
2008-11-04 21:00:50 -06:00
|
|
|
|
2008-11-05 22:16:24 -06:00
|
|
|
!======================================================================
|
|
|
|
!
|
2008-11-04 21:00:50 -06:00
|
|
|
end module
|