gkowal/amun-code
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Rewrite subroutine restrict_block.

Browse Source 
MESH

 - subroutine restrict_block has been rewritten to use one big array for
   storage variables from all children and them restricting this array
   and putting resulted variables in a new data block;
This commit is contained in:
Grzegorz Kowal 2010-07-04 01:15:34 -03:00
parent c057d098de
commit 26e103ce86
1 changed files with 65 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

125
src/mesh.F90
View File

@ -928,11 +928,11 @@ module mesh
! !
subroutine restrict_block(pblock) subroutine restrict_block(pblock)
use blocks , only : block_meta, nchild, nfl use blocks , only : block_meta, nchild, nfl, nqt
#ifdef MHD #ifdef MHD
use blocks , only : ibx, iby, ibz use blocks , only : ibx, iby, ibz
#endif /* MHD */ #endif /* MHD */
use config , only : ng, im, jm, km, ib, jb, kb use config , only : ng, in, jn, kn, im, jm, km
use interpolation, only : shrink use interpolation, only : shrink
implicit none implicit none
@ -944,16 +944,17 @@ module mesh
! local variables ! local variables
! !
integer :: i, j, k, q, p integer :: i, j, k, q, p
integer :: il, iu, jl, ju, kl, ku, i1, i2, j1, j2, k1, k2
integer :: is, js, ks integer :: is, js, ks
integer :: ib, jb, kb, ie, je, ke
integer :: il, iu, jl, ju, kl, ku
! local arrays ! local arrays
! !
integer, dimension(3) :: dm, fm, pm integer, dimension(3) :: dm, pm, fm
! local allocatable arrays ! local allocatable arrays
! !
real, dimension(:,:,:), allocatable :: u real, dimension(:,:,:,:), allocatable :: u, w
! local pointers ! local pointers
! !
@ -964,22 +965,23 @@ module mesh
! prepare dimensions ! prepare dimensions
! !
dm(:) = (/ im, jm, km /) dm(:) = (/ im, jm, km /)
pm(:) = dm(:) / 2 pm(:) = dm(:) - ng
fm(:) = (dm(:) - ng) / 2 fm(:) = 2 * pm(:)
#if NDIMS == 2 #if NDIMS == 2
pm(3) = 1 pm(3) = 1
fm(3) = 1 fm(3) = 1
kb = 1
ke = 1
ks = 0 ks = 0
kl = 1 kl = 1
ku = 1 ku = 1
k1 = 1
k2 = 1
k = 1 k = 1
#endif /* NDIMS == 2 */ #endif /* NDIMS == 2 */
! allocate temporary array ! allocate temporary arrays
! !
allocate(u(pm(1), pm(2), pm(3))) allocate(u(nqt, fm(1), fm(2), fm(3)))
allocate(w(nqt, pm(1), pm(2), pm(3)))
! iterate over all children ! iterate over all children
! !
@ -1001,87 +1003,88 @@ module mesh
! calculate the bounds of the input array indices ! calculate the bounds of the input array indices
! !
i1 = 1 + ng / 2 * is ib = 1 + ng * is
j1 = 1 + ng / 2 * js jb = 1 + ng * js
#if NDIMS == 3 #if NDIMS == 2
k1 = 1 + ng / 2 * ks kb = 1 + ng * ks
#endif /* NDIMS == 3 */ #endif /* NDIMS == 2 */
i2 = i1 + fm(1) - 1 ie = ib + pm(1) - 1
j2 = j1 + fm(2) - 1 je = jb + pm(2) - 1
#if NDIMS == 3 #if NDIMS == 2
k2 = k1 + fm(3) - 1 ke = kb + pm(3) - 1
#endif /* NDIMS == 3 */ #endif /* NDIMS == 2 */
! calculate the bounds of the destination array indices ! calculate the bounds of the destination array indices
! !
il = 1 + ng / 2 + is * fm(1) il = 1 + pm(1) * is
jl = 1 + ng / 2 + js * fm(2) jl = 1 + pm(2) * js
#if NDIMS == 3 #if NDIMS == 2
kl = 1 + ng / 2 + ks * fm(3) kl = 1 + pm(3) * ks
#endif /* NDIMS == 3 */ #endif /* NDIMS == 2 */
iu = il + fm(1) - 1 iu = il + pm(1) - 1
ju = jl + fm(2) - 1 ju = jl + pm(2) - 1
#if NDIMS == 3 #if NDIMS == 2
ku = kl + fm(3) - 1 ku = kl + pm(3) - 1
#endif /* NDIMS == 3 */ #endif /* NDIMS == 2 */
! iterate over all quantities ! copy variables from the current child to the proper location of the array u
! !
do q = 1, nfl u(1:nqt,il:iu,jl:ju,kl:ku) = pchild%data%u(1:nqt,ib:ie,jb:je,kb:je)
! shrink the current child
!
call shrink(dm, pm, pchild%data%u(q,:,:,:), u(:,:,:), 'm', 'm', 'm')
! fill the parent block
!
pblock%data%u(q,il:iu,jl:ju,kl:ku) = u(i1:i2,j1:j2,k1:k2)
end do end do
! iterate over all quantities and shrink them and substitute to the new block
!
do q = 1, nfl
call shrink(fm, pm, u(q,:,:,:), w(q,:,:,:), 'm', 'm', 'm')
end do
#ifdef MHD #ifdef MHD
#ifdef FIELDCD #ifdef FIELDCD
! iterate over magnetic field components ! iterate over magnetic field components
! !
do q = ibx, ibz do q = ibx, ibz
call shrink(fm, pm, u(q,:,:,:), w(q,:,:,:), 'm', 'm', 'm')
! shrink the current child
!
call shrink(dm, pm, pchild%data%u(q,:,:,:), u(:,:,:), 'm', 'm', 'm')
! fill the parent block
!
pblock%data%u(q,il:iu,jl:ju,kl:ku) = u(i1:i2,j1:j2,k1:k2)
end do end do
#endif /* FIELDCD */ #endif /* FIELDCD */
#ifdef FLUXCT #ifdef FLUXCT
! restrict the X component of magnetic field ! restrict the X component of magnetic field
! !
call shrink(dm, pm, pchild%data%u(ibx,:,:,:), u(:,:,:), 'c', 'm', 'm') call shrink(fm, pm, u(ibx,:,:,:), w(ibx,:,:,:), 'c', 'm', 'm')
pblock%data%u(ibx,il:iu,jl:ju,kl:ku) = u(i1:i2,j1:j2,k1:k2)
! restrict the Y component of magnetic field ! restrict the Y component of magnetic field
! !
call shrink(dm, pm, pchild%data%u(iby,:,:,:), u(:,:,:), 'm', 'c', 'm') call shrink(fm, pm, u(iby,:,:,:), w(iby,:,:,:), 'm', 'c', 'm')
pblock%data%u(iby,il:iu,jl:ju,kl:ku) = u(i1:i2,j1:j2,k1:k2)
! restrict the Z component of magnetic field ! restrict the Z component of magnetic field
! !
call shrink(dm, pm, pchild%data%u(ibz,:,:,:), u(:,:,:), 'm', 'm', 'c') call shrink(fm, pm, u(ibz,:,:,:), w(ibz,:,:,:), 'm', 'm', 'c')
pblock%data%u(ibz,il:iu,jl:ju,kl:ku) = u(i1:i2,j1:j2,k1:k2)
#endif /* FLUXCT */ #endif /* FLUXCT */
#endif /* MHD */ #endif /* MHD */
end do ! calculate substitution indices
!
ib = ng / 2 + 1
jb = ng / 2 + 1
kb = ng / 2 + 1
ie = ib + in + ng - 1
je = jb + jn + ng - 1
ke = kb + kn + ng - 1
#if NDIMS == 2
kb = 1
ke = 1
#endif /* NDIMS == 2 */
! deallocate temporary array ! substitute shrinked variables to the new data block
!
pblock%data%u(1:nqt,ib:ie,jb:je,kb:ke) = w(1:nqt,:,:,:)
! deallocate temporary arrays
! !
deallocate(u) deallocate(u)
deallocate(w)
! !
!------------------------------------------------------------------------------- !-------------------------------------------------------------------------------
! !