diff --git a/src/blocks.F90 b/src/blocks.F90 index bf97a29..c4bd216 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -277,11 +277,10 @@ module blocks ! type(block_meta) , pointer :: neigh - ! the direction, side and face numbers - ! indicating the neighbor block orientation - ! with respect to the block + ! the direction along which the neighbor + ! is located ! - integer(kind=4) :: direction, side, face + integer(kind=4) :: direction ! the corner index determining the position of ! the corner boundary and when direction is diff --git a/src/boundaries.F90 b/src/boundaries.F90 index ebca87d..b96bd76 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -29,9 +29,12 @@ ! module boundaries -#ifdef PROFILE ! import external subroutines ! +#ifdef MPI + use blocks, only : pointer_info +#endif /* MPI */ +#ifdef PROFILE use timers, only : set_timer, start_timer, stop_timer #endif /* PROFILE */ @@ -42,7 +45,7 @@ module boundaries #ifdef PROFILE ! timer indices ! - integer , save :: imi, imv, imf, ims, imc, imr, imp + integer , save :: imi, imv, imf, ims, imc, imr, imp, imu #endif /* PROFILE */ ! parameters corresponding to the boundary type @@ -57,6 +60,14 @@ module boundaries ! integer, dimension(3,2), save :: bnd_type = bnd_periodic +#ifdef MPI +! arrays to store information about blocks which need to be exchange between +! processes +! + type(pointer_info), dimension(:,:), allocatable, save :: barray + integer , dimension(:,:), allocatable, save :: bcount +#endif /* MPI */ + ! by default everything is private ! private @@ -96,7 +107,7 @@ module boundaries ! import external procedures and variables ! #ifdef MPI - use mpitools , only : pdims, pcoords, periodic + use mpitools , only : pdims, pcoords, periodic, npmax #endif /* MPI */ use parameters , only : get_parameter_string @@ -130,6 +141,7 @@ module boundaries call set_timer('boundaries:: copy' , imc) call set_timer('boundaries:: restrict' , imr) call set_timer('boundaries:: prolong' , imp) + call set_timer('boundaries:: update ghosts' , imu) ! start accounting time for module initialization/finalization ! @@ -221,6 +233,16 @@ module boundaries bnd_type(3,2) = bnd_periodic end select +#ifdef MPI +! allocate the exchange arrays +! + allocate(barray(0:npmax,0:npmax), bcount(0:npmax,0:npmax)) + +! prepare the exchange arrays +! + call prepare_exchange_array() +#endif /* MPI */ + ! print information about the boundary conditions ! if (verbose) then @@ -277,6 +299,16 @@ module boundaries call start_timer(imi) #endif /* PROFILE */ +#ifdef MPI +! release the exchange arrays +! + call release_exchange_array() + +! deallocate the exchange arrays +! + deallocate(barray, bcount) +#endif /* MPI */ + #ifdef PROFILE ! stop accounting time for module initialization/finalization ! @@ -425,9 +457,8 @@ module boundaries use coordinates , only : kb, ke, kbl use equations , only : nv #ifdef MPI - use mpitools , only : nprocs, nproc, npmax - use mpitools , only : npairs, pairs - use mpitools , only : send_real_array, receive_real_array + use mpitools , only : nproc, nprocs, npairs, pairs + use mpitools , only : exchange_real_arrays #endif /* MPI */ ! local variables are not implicit by default @@ -448,17 +479,13 @@ module boundaries integer :: j, js, jt, jl, ju, jh integer :: k, ks, kt, kl, ku, kh #ifdef MPI - integer :: irecv, isend, nblocks, itag, iret - integer :: l, p - -! local pointer arrays -! - type(pointer_info), dimension(0:nprocs-1,0:nprocs-1) :: block_array + integer :: sproc, scount, stag + integer :: rproc, rcount, rtag + integer :: l, p, iret ! local arrays ! - integer , dimension(0:nprocs-1,0:nprocs-1) :: block_counter - real(kind=8), dimension(:,:,:,:), allocatable :: rbuf + real(kind=8), dimension(:,:,:,:), allocatable :: sbuf, rbuf #endif /* MPI */ ! !------------------------------------------------------------------------------- @@ -489,17 +516,9 @@ module boundaries #ifdef MPI !! 1. PREPARE THE BLOCK EXCHANGE ARRAYS FOR MPI !! -! reset the block counter +! prepare the array of exchange block lists and its counters ! - block_counter(:,:) = 0 - -! nullify pointers to blocks which need to be exchanged between processes -! - do irecv = 0, npmax - do isend = 0, npmax - nullify(block_array(isend,irecv)%ptr) - end do ! isend - end do ! irecv + call prepare_exchange_array() #endif /* MPI */ !! 2. UPDATE THE FLUX BOUNDARIES BETWEEN LOCAL BLOCKS @@ -673,47 +692,9 @@ module boundaries ! else -! increase the counter for the number of blocks to exchange +! append the block to the exchange list ! - block_counter(pneigh%process,pmeta%process) = & - block_counter(pneigh%process,pmeta%process) + 1 - -! allocate a new info object -! - allocate(pinfo) - -! fill out its fields -! - pinfo%block => pmeta - pinfo%neigh => pneigh - pinfo%direction = n - pinfo%corner(1) = i - pinfo%corner(2) = j -#if NDIMS == 3 - pinfo%corner(3) = k -#endif /* NDIMS == 3 */ - pinfo%level_difference = pmeta%level - pneigh%level - -! nullify pointer fields -! - nullify(pinfo%prev) - nullify(pinfo%next) - -! check if the list is empty -! - if (associated(block_array(pneigh%process & - ,pmeta%process)%ptr)) then - -! if it is, associate the newly created block with it -! - pinfo%prev => & - block_array(pneigh%process,pmeta%process)%ptr - - end if ! %ptr associated - -! point the list to the newly created block -! - block_array(pneigh%process,pmeta%process)%ptr => pinfo + call append_exchange_block(pmeta, pneigh, n, i, j, k) end if ! pmeta and pneigh on local process #endif /* MPI */ @@ -744,38 +725,49 @@ module boundaries ! do p = 1, npairs -! get sending and receiving process identifiers +! process only pairs related to this process ! - isend = pairs(p,1) - irecv = pairs(p,2) + if (pairs(p,1) == nproc .or. pairs(p,2) == nproc) then + +! get sending and receiving process identifiers (depending on pair member) +! + if (pairs(p,1) == nproc) then + sproc = pairs(p,1) + rproc = pairs(p,2) + end if + if (pairs(p,2) == nproc) then + sproc = pairs(p,2) + rproc = pairs(p,1) + end if + +! get the number of blocks to exchange +! + scount = bcount(sproc,rproc) + rcount = bcount(rproc,sproc) ! process only pairs which have anything to exchange ! - if (block_counter(isend,irecv) > 0) then - -! obtain the number of blocks to exchange -! - nblocks = block_counter(isend,irecv) + if ((scount + rcount) > 0) then ! prepare the tag for communication ! - itag = 16 * (irecv * nprocs + isend) + 1 + stag = 16 * (rproc * nprocs + sproc) + 1 + rtag = 16 * (sproc * nprocs + rproc) + 1 -! allocate the buffer for variable exchange +! allocate buffers for variable exchange ! - allocate(rbuf(nblocks,nv,ih,kh)) - -! if isend == nproc we are sending data -! - if (isend == nproc) then + allocate(sbuf(scount,nv,ih,kh)) + allocate(rbuf(rcount,nv,ih,kh)) +!! PREPARE BLOCKS FOR SENDING +!! ! reset the block counter ! l = 0 ! associate pinfo with the first block in the exchange list ! - pinfo => block_array(isend,irecv)%ptr + pinfo => barray(sproc,rproc)%ptr ! scan all blocks on the list ! @@ -815,7 +807,7 @@ module boundaries ! call block_update_flux(i, j, k, n & , pneigh%data%f(n,1:nv,is,jb:je,kb:ke) & - , rbuf(l,1:nv,1:jh,1:kh)) + , sbuf(l,1:nv,1:jh,1:kh)) case(2) @@ -831,7 +823,7 @@ module boundaries ! call block_update_flux(i, j, k, n & , pneigh%data%f(n,1:nv,ib:ie,js,kb:ke) & - , rbuf(l,1:nv,1:ih,1:kh)) + , sbuf(l,1:nv,1:ih,1:kh)) #if NDIMS == 3 case(3) @@ -848,7 +840,7 @@ module boundaries ! call block_update_flux(i, j, k, n & , pneigh%data%f(n,1:nv,ib:ie,jb:je,ks) & - , rbuf(l,1:nv,1:ih,1:jh)) + , sbuf(l,1:nv,1:ih,1:jh)) #endif /* NDIMS == 3 */ end select @@ -859,29 +851,22 @@ module boundaries end do ! %ptr blocks -! send the data buffer to another process +!! SEND PREPARED BLOCKS AND RECEIVCE NEW ONES +!! +! exchange data ! - call send_real_array(size(rbuf(:,:,:,:)), irecv, itag & - , rbuf(:,:,:,:), iret) - - end if ! isend = nproc - -! if irecv == nproc we are receiving data -! - if (irecv == nproc) then - -! receive the data buffer -! - call receive_real_array(size(rbuf(:,:,:,:)), isend, itag & - , rbuf(:,:,:,:), iret) + call exchange_real_arrays(rproc, stag, size(sbuf), sbuf & + , rproc, rtag, size(rbuf), rbuf, iret) +!! PROCESS RECEIVED BLOCKS +!! ! reset the block counter ! l = 0 ! associate pinfo with the first block in the exchange list ! - pinfo => block_array(isend,irecv)%ptr + pinfo => barray(rproc,sproc)%ptr ! scan all blocks on the list ! @@ -1005,44 +990,19 @@ module boundaries end do ! %ptr blocks - end if ! irecv = nproc - ! deallocate data buffer ! - deallocate(rbuf) + deallocate(sbuf, rbuf) -! associate pinfo with the first block in the exchange list -! - pinfo => block_array(isend,irecv)%ptr + end if ! (scount + rcount) > 0 -! scan all blocks on the exchange list -! - do while(associated(pinfo)) - -! associate the exchange list pointer -! - block_array(isend,irecv)%ptr => pinfo%prev - -! nullify pointer fields -! - nullify(pinfo%prev) - nullify(pinfo%next) - nullify(pinfo%block) - nullify(pinfo%neigh) - -! deallocate info block -! - deallocate(pinfo) - -! associate pinfo with the next block -! - pinfo => block_array(isend,irecv)%ptr - - end do ! %ptr blocks - - end if ! if block_count > 0 + end if ! pairs(p,1) == nproc || pairs(p,2) == nproc end do ! p = 1, npairs + +! release the memory used by the array of exchange block lists +! + call release_exchange_array() #endif /* MPI */ #ifdef PROFILE @@ -1259,10 +1219,9 @@ module boundaries use coordinates , only : ibl, jbl, kbl use coordinates , only : ieu, jeu, keu use equations , only : nv - use mpitools , only : nproc, nprocs, npmax #ifdef MPI - use mpitools , only : npairs, pairs - use mpitools , only : send_real_array, receive_real_array + use mpitools , only : nproc, nprocs, npairs, pairs + use mpitools , only : exchange_real_arrays #endif /* MPI */ ! local variables are not implicit by default @@ -1286,19 +1245,14 @@ module boundaries integer :: ih, jh, kh integer :: il, jl, kl integer :: iu, ju, ku - integer :: iret #ifdef MPI - integer :: isend, irecv, nblocks, itag - integer :: l, p - -! local pointer arrays -! - type(pointer_info), dimension(0:npmax,0:npmax) :: block_array + integer :: sproc, scount, stag + integer :: rproc, rcount, rtag + integer :: l, p, iret ! local arrays ! - integer , dimension(0:npmax,0:npmax) :: block_counter - real(kind=8), dimension(:,:,:,:,:) , allocatable :: rbuf + real(kind=8), dimension(:,:,:,:,:), allocatable :: sbuf, rbuf #endif /* MPI */ ! !------------------------------------------------------------------------------- @@ -1318,17 +1272,9 @@ module boundaries #ifdef MPI !! 1. PREPARE THE BLOCK EXCHANGE ARRAYS FOR MPI !! -! reset the exchange block counters +! prepare the array of exchange block lists and its counters ! - block_counter(:,:) = 0 - -! nullify the info pointers -! - do irecv = 0, npmax - do isend = 0, npmax - nullify(block_array(isend,irecv)%ptr) - end do - end do + call prepare_exchange_array() #endif /* MPI */ !! 2. UPDATE VARIABLE FACE BOUNDARIES BETWEEN BLOCKS BELONGING TO THE SAME @@ -1462,39 +1408,9 @@ module boundaries else ! block and neighbor belong to different processes -! increase the counter for number of blocks to exchange +! append the block to the exchange list ! - block_counter(pneigh%process,pmeta%process) = & - block_counter(pneigh%process,pmeta%process) + 1 - -! allocate a new info object -! - allocate(pinfo) - -! fill out only fields which are used -! - pinfo%block => pmeta - pinfo%neigh => pneigh - pinfo%direction = idir - pinfo%corner(1) = i - pinfo%corner(2) = j - pinfo%corner(3) = k - -! nullify pointer fields of the object -! - nullify(pinfo%prev) - nullify(pinfo%next) - -! if the list is not empty append the newly created block to it -! - if (associated(block_array(pneigh%process & - ,pmeta%process)%ptr)) & - pinfo%prev => block_array(pneigh%process & - ,pmeta%process)%ptr - -! point the list to the newly created block -! - block_array(pneigh%process,pmeta%process)%ptr => pinfo + call append_exchange_block(pmeta, pneigh, idir, i, j, k) end if ! block and neighbor belong to different processes #endif /* MPI */ @@ -1524,45 +1440,58 @@ module boundaries ! do p = 1, npairs -! get sending and receiving process identifiers +! process only pairs related to this process ! - isend = pairs(p,1) - irecv = pairs(p,2) + if (pairs(p,1) == nproc .or. pairs(p,2) == nproc) then + +! get sending and receiving process identifiers (depending on pair member) +! + if (pairs(p,1) == nproc) then + sproc = pairs(p,1) + rproc = pairs(p,2) + end if + if (pairs(p,2) == nproc) then + sproc = pairs(p,2) + rproc = pairs(p,1) + end if + +! get the number of blocks to exchange +! + scount = bcount(sproc,rproc) + rcount = bcount(rproc,sproc) ! process only pairs which have anything to exchange ! - if (block_counter(isend,irecv) > 0) then - -! obtain the number of blocks to exchange -! - nblocks = block_counter(isend,irecv) + if ((scount + rcount) > 0) then ! prepare the tag for communication ! - itag = 16 * (irecv * nprocs + isend) + 2 + stag = 16 * (rproc * nprocs + sproc) + 2 + rtag = 16 * (sproc * nprocs + rproc) + 2 ! allocate data buffer for variables to exchange ! - select case(idir) - case(1) - allocate(rbuf(nblocks,nv,ng,jh,kh)) - case(2) - allocate(rbuf(nblocks,nv,ih,ng,kh)) - case(3) - allocate(rbuf(nblocks,nv,ih,jh,ng)) - end select - -! if isend == nproc we are sending data -! - if (isend == nproc) then + select case(idir) + case(1) + allocate(sbuf(scount,nv,ng,jh,kh)) + allocate(rbuf(rcount,nv,ng,jh,kh)) + case(2) + allocate(sbuf(scount,nv,ih,ng,kh)) + allocate(rbuf(rcount,nv,ih,ng,kh)) + case(3) + allocate(sbuf(scount,nv,ih,jh,ng)) + allocate(rbuf(rcount,nv,ih,jh,ng)) + end select +!! PREPARE BLOCKS FOR SENDING +!! ! reset the block counter ! l = 0 -! associate pinfo with the first block in the exchange list +! associate the pointer with the first block in the exchange list ! - pinfo => block_array(isend,irecv)%ptr + pinfo => barray(sproc,rproc)%ptr ! scan over all blocks on the block exchange list ! @@ -1572,7 +1501,7 @@ module boundaries ! l = l + 1 -! associate pneigh with pinfo%neigh +! assign pneigh to the associated neighbor block ! pneigh => pinfo%neigh @@ -1589,45 +1518,39 @@ module boundaries case(1) call block_face_copy(idir, i, j, k & , pneigh%data%q(1:nv,1:im,1:jm,1:km) & - , rbuf(l,1:nv,1:ng,1:jh,1:kh)) + , sbuf(l,1:nv,1:ng,1:jh,1:kh)) case(2) call block_face_copy(idir, i, j, k & , pneigh%data%q(1:nv,1:im,1:jm,1:km) & - , rbuf(l,1:nv,1:ih,1:ng,1:kh)) + , sbuf(l,1:nv,1:ih,1:ng,1:kh)) case(3) call block_face_copy(idir, i, j, k & , pneigh%data%q(1:nv,1:im,1:jm,1:km) & - , rbuf(l,1:nv,1:ih,1:jh,1:ng)) + , sbuf(l,1:nv,1:ih,1:jh,1:ng)) end select -! associate pinfo with the next block +! associate the pointer with the next block ! pinfo => pinfo%prev end do ! %ptr block list -! send the data buffer to another process +!! SEND PREPARED BLOCKS AND RECEIVCE NEW ONES +!! +! exchange data ! - call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) - - end if ! isend = nproc - -! if irecv == nproc we are receiving data -! - if (irecv == nproc) then - -! receive the data buffer -! - call receive_real_array(size(rbuf(:,:,:,:,:)), isend, itag & - , rbuf(:,:,:,:,:), iret) + call exchange_real_arrays(rproc, stag, size(sbuf), sbuf & + , rproc, rtag, size(rbuf), rbuf, iret) +!! PROCESS RECEIVED BLOCKS +!! ! reset the block counter ! l = 0 -! associate pinfo with the first block in the exchange list +! associate the pointer with the first block in the exchange list ! - pinfo => block_array(isend,irecv)%ptr + pinfo => barray(rproc,sproc)%ptr ! iterate over all received blocks and update boundaries of the corresponding ! data blocks @@ -1638,7 +1561,7 @@ module boundaries ! l = l + 1 -! associate pmeta with pinfo%block +! assign a pointer to the associated data block ! pmeta => pinfo%block @@ -1673,8 +1596,7 @@ module boundaries kl = ke - kh + 1 ku = ke end if - pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = & - rbuf(l,1:nv,1:ng,1:jh,1:kh) + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = rbuf(l,1:nv,1:ng,1:jh,1:kh) case(2) if (i == 1) then il = ib @@ -1697,8 +1619,7 @@ module boundaries kl = ke - kh + 1 ku = ke end if - pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = & - rbuf(l,1:nv,1:ih,1:ng,1:kh) + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = rbuf(l,1:nv,1:ih,1:ng,1:kh) case(3) if (i == 1) then il = ib @@ -1721,54 +1642,28 @@ module boundaries kl = keu ku = km end if - pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = & - rbuf(l,1:nv,1:ih,1:jh,1:ng) + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = rbuf(l,1:nv,1:ih,1:jh,1:ng) end select -! associate pinfo with the next block +! associate the pointer with the next block ! pinfo => pinfo%prev end do ! %ptr block list - end if ! irecv = nproc - ! deallocate data buffer ! - if (allocated(rbuf)) deallocate(rbuf) + deallocate(sbuf, rbuf) -! associate pinfo with the first block in the exchange list -! - pinfo => block_array(isend,irecv)%ptr + end if ! (scount + rcount) > 0 -! scan over all blocks on the exchange block list -! - do while(associated(pinfo)) - -! associate the exchange list pointer with the previous block on the list -! - block_array(isend,irecv)%ptr => pinfo%prev - -! nullify the current pointer fields -! - nullify(pinfo%prev) - nullify(pinfo%next) - nullify(pinfo%block) - nullify(pinfo%neigh) - -! deallocate the object -! - deallocate(pinfo) - -! associate pinfo with the next block -! - pinfo => block_array(isend,irecv)%ptr - - end do ! %ptr block list - - end if ! if block_count > 0 + end if ! pairs(p,1) == nproc || pairs(p,2) == nproc end do ! p = 1, npairs + +! release the memory used by the array of exchange block lists +! + call release_exchange_array() #endif /* MPI */ #ifdef PROFILE @@ -1812,10 +1707,9 @@ module boundaries use coordinates , only : ibl, jbl, kbl use coordinates , only : ieu, jeu, keu use equations , only : nv - use mpitools , only : nproc, nprocs, npmax #ifdef MPI - use mpitools , only : npairs, pairs - use mpitools , only : send_real_array, receive_real_array + use mpitools , only : nproc, nprocs, npairs, pairs + use mpitools , only : exchange_real_arrays #endif /* MPI */ ! local variables are not implicit by default @@ -1839,19 +1733,14 @@ module boundaries integer :: ih, jh, kh integer :: il, jl, kl integer :: iu, ju, ku - integer :: iret #ifdef MPI - integer :: isend, irecv, nblocks, itag - integer :: l, p - -! local pointer arrays -! - type(pointer_info), dimension(0:npmax,0:npmax) :: block_array + integer :: sproc, scount, stag + integer :: rproc, rcount, rtag + integer :: l, p, iret ! local arrays ! - integer , dimension(0:npmax,0:npmax) :: block_counter - real(kind=8), dimension(:,:,:,:,:) , allocatable :: rbuf + real(kind=8), dimension(:,:,:,:,:), allocatable :: sbuf, rbuf #endif /* MPI */ ! !------------------------------------------------------------------------------- @@ -1871,17 +1760,9 @@ module boundaries #ifdef MPI !! 1. PREPARE THE BLOCK EXCHANGE ARRAYS FOR MPI !! -! reset the exchange block counters +! prepare the array of exchange block lists and its counters ! - block_counter(:,:) = 0 - -! nullify the info pointers -! - do irecv = 0, npmax - do isend = 0, npmax - nullify(block_array(isend,irecv)%ptr) - end do - end do + call prepare_exchange_array() #endif /* MPI */ !! 2. UPDATE VARIABLE FACE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT @@ -2015,39 +1896,9 @@ module boundaries else ! block and neighbor belong to different processes -! increase the counter for number of blocks to exchange +! append the block to the exchange list ! - block_counter(pneigh%process,pmeta%process) = & - block_counter(pneigh%process,pmeta%process) + 1 - -! allocate a new info object -! - allocate(pinfo) - -! fill out only fields which are used -! - pinfo%block => pmeta - pinfo%neigh => pneigh - pinfo%direction = idir - pinfo%corner(1) = i - pinfo%corner(2) = j - pinfo%corner(3) = k - -! nullify pointer fields of the object -! - nullify(pinfo%prev) - nullify(pinfo%next) - -! if the list is not empty append the newly created block to it -! - if (associated(block_array(pneigh%process & - ,pmeta%process)%ptr)) & - pinfo%prev => block_array(pneigh%process & - ,pmeta%process)%ptr - -! point the list to the newly created block -! - block_array(pneigh%process,pmeta%process)%ptr => pinfo + call append_exchange_block(pmeta, pneigh, idir, i, j, k) end if ! block and neighbor belong to different processes #endif /* MPI */ @@ -2077,45 +1928,58 @@ module boundaries ! do p = 1, npairs -! get sending and receiving process identifiers +! process only pairs related to this process ! - isend = pairs(p,1) - irecv = pairs(p,2) + if (pairs(p,1) == nproc .or. pairs(p,2) == nproc) then -! process only pairs which have something to exchange +! get sending and receiving process identifiers (depending on pair member) ! - if (block_counter(isend,irecv) > 0) then + if (pairs(p,1) == nproc) then + sproc = pairs(p,1) + rproc = pairs(p,2) + end if + if (pairs(p,2) == nproc) then + sproc = pairs(p,2) + rproc = pairs(p,1) + end if -! obtain the number of blocks to exchange +! get the number of blocks to exchange ! - nblocks = block_counter(isend,irecv) + scount = bcount(sproc,rproc) + rcount = bcount(rproc,sproc) + +! process only pairs which have anything to exchange +! + if ((scount + rcount) > 0) then ! prepare the tag for communication ! - itag = 16 * (irecv * nprocs + isend) + 3 + stag = 16 * (rproc * nprocs + sproc) + 3 + rtag = 16 * (sproc * nprocs + rproc) + 3 ! allocate data buffer for variables to exchange ! - select case(idir) - case(1) - allocate(rbuf(nblocks,nv,ng,jh,kh)) - case(2) - allocate(rbuf(nblocks,nv,ih,ng,kh)) - case(3) - allocate(rbuf(nblocks,nv,ih,jh,ng)) - end select - -! if isend == nproc we are sending data -! - if (isend == nproc) then + select case(idir) + case(1) + allocate(sbuf(scount,nv,ng,jh,kh)) + allocate(rbuf(rcount,nv,ng,jh,kh)) + case(2) + allocate(sbuf(scount,nv,ih,ng,kh)) + allocate(rbuf(rcount,nv,ih,ng,kh)) + case(3) + allocate(sbuf(scount,nv,ih,jh,ng)) + allocate(rbuf(rcount,nv,ih,jh,ng)) + end select +!! PREPARE BLOCKS FOR SENDING +!! ! reset the block counter ! l = 0 -! associate pinfo with the first block in the exchange list +! associate the pointer with the first block in the exchange list ! - pinfo => block_array(isend,irecv)%ptr + pinfo => barray(sproc,rproc)%ptr ! scan over all blocks on the block exchange list ! @@ -2125,7 +1989,7 @@ module boundaries ! l = l + 1 -! associate pneigh with pinfo%neigh +! assign pneigh to the associated neighbor block ! pneigh => pinfo%neigh @@ -2135,52 +1999,46 @@ module boundaries j = pinfo%corner(2) k = pinfo%corner(3) -! extract the corresponding face region from the neighbor and insert it +! restrict the corresponding face region from the neighbor and insert it ! to the buffer ! select case(idir) case(1) call block_face_restrict(idir, i, j, k & , pneigh%data%q(1:nv,1:im,1:jm,1:km) & - , rbuf(l,1:nv,1:ng,1:jh,1:kh)) + , sbuf(l,1:nv,1:ng,1:jh,1:kh)) case(2) call block_face_restrict(idir, i, j, k & , pneigh%data%q(1:nv,1:im,1:jm,1:km) & - , rbuf(l,1:nv,1:ih,1:ng,1:kh)) + , sbuf(l,1:nv,1:ih,1:ng,1:kh)) case(3) call block_face_restrict(idir, i, j, k & , pneigh%data%q(1:nv,1:im,1:jm,1:km) & - , rbuf(l,1:nv,1:ih,1:jh,1:ng)) + , sbuf(l,1:nv,1:ih,1:jh,1:ng)) end select -! associate pinfo with the next block +! associate the pointer with the next block ! pinfo => pinfo%prev end do ! %ptr block list -! send the data buffer to another process +!! SEND PREPARED BLOCKS AND RECEIVCE NEW ONES +!! +! exchange data ! - call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) - - end if ! isend = nproc - -! if irecv == nproc we are receiving data -! - if (irecv == nproc) then - -! receive the data buffer -! - call receive_real_array(size(rbuf(:,:,:,:,:)), isend, itag & - , rbuf(:,:,:,:,:), iret) + call exchange_real_arrays(rproc, stag, size(sbuf), sbuf & + , rproc, rtag, size(rbuf), rbuf, iret) +!! PROCESS RECEIVED BLOCKS +!! ! reset the block counter ! l = 0 -! associate pinfo with the first block in the exchange list +! associate the pointer with the first block in the exchange list ! - pinfo => block_array(isend,irecv)%ptr + pinfo => barray(rproc,sproc)%ptr ! iterate over all received blocks and update boundaries of the corresponding ! data blocks @@ -2191,7 +2049,7 @@ module boundaries ! l = l + 1 -! associate pmeta with pinfo%block +! assign a pointer to the associated data block ! pmeta => pinfo%block @@ -2278,50 +2136,25 @@ module boundaries rbuf(l,1:nv,1:ih,1:jh,1:ng) end select -! associate pinfo with the next block +! associate the pointer with the next block ! pinfo => pinfo%prev end do ! %ptr block list - end if ! irecv = nproc - ! deallocate data buffer ! - if (allocated(rbuf)) deallocate(rbuf) + deallocate(sbuf, rbuf) -! associate pinfo with the first block in the exchange list -! - pinfo => block_array(isend,irecv)%ptr + end if ! (scount + rcount) > 0 -! scan over all blocks on the exchange block list -! - do while(associated(pinfo)) - -! associate the exchange list pointer with the previous block -! - block_array(isend,irecv)%ptr => pinfo%prev - -! nullify the pointer fields -! - nullify(pinfo%prev) - nullify(pinfo%next) - nullify(pinfo%block) - nullify(pinfo%neigh) - -! deallocate the object -! - deallocate(pinfo) - -! associate pinfo with the next block -! - pinfo => block_array(isend,irecv)%ptr - - end do ! %ptr block list - - end if ! if block_count > 0 + end if ! pairs(p,1) == nproc || pairs(p,2) == nproc end do ! p = 1, npairs + +! release the memory used by the array of exchange block lists +! + call release_exchange_array() #endif /* MPI */ #ifdef PROFILE @@ -2365,10 +2198,9 @@ module boundaries use coordinates , only : ibl, jbl, kbl use coordinates , only : ieu, jeu, keu use equations , only : nv - use mpitools , only : nproc, nprocs, npmax #ifdef MPI - use mpitools , only : npairs, pairs - use mpitools , only : send_real_array, receive_real_array + use mpitools , only : nproc, nprocs, npairs, pairs + use mpitools , only : exchange_real_arrays #endif /* MPI */ ! local variables are not implicit by default @@ -2393,19 +2225,14 @@ module boundaries integer :: ih, jh, kh integer :: il, jl, kl integer :: iu, ju, ku - integer :: iret #ifdef MPI - integer :: isend, irecv, nblocks, itag - integer :: l, p - -! local pointer arrays -! - type(pointer_info), dimension(0:npmax,0:npmax) :: block_array + integer :: sproc, scount, stag + integer :: rproc, rcount, rtag + integer :: l, p, iret ! local arrays ! - integer , dimension(0:npmax,0:npmax) :: block_counter - real(kind=8), dimension(:,:,:,:,:) , allocatable :: rbuf + real(kind=8), dimension(:,:,:,:,:), allocatable :: sbuf, rbuf #endif /* MPI */ ! !------------------------------------------------------------------------------- @@ -2425,17 +2252,9 @@ module boundaries #ifdef MPI !! 1. PREPARE THE BLOCK EXCHANGE ARRAYS FOR MPI !! -! reset the exchange block counters +! prepare the array of exchange block lists and its counters ! - block_counter(:,:) = 0 - -! nullify the info pointers -! - do irecv = 0, npmax - do isend = 0, npmax - nullify(block_array(isend,irecv)%ptr) - end do - end do + call prepare_exchange_array() #endif /* MPI */ !! 2. UPDATE VARIABLE FACE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT @@ -2581,39 +2400,9 @@ module boundaries else ! block and neighbor belong to different processes -! increase the counter for number of blocks to exchange +! append the block to the exchange list ! - block_counter(pneigh%process,pmeta%process) = & - block_counter(pneigh%process,pmeta%process) + 1 - -! allocate a new info object -! - allocate(pinfo) - -! fill out only fields which are used -! - pinfo%block => pmeta - pinfo%neigh => pneigh - pinfo%direction = idir - pinfo%corner(1) = i - pinfo%corner(2) = j - pinfo%corner(3) = k - -! nullify pointer fields of the object -! - nullify(pinfo%prev) - nullify(pinfo%next) - -! if the list is not empty append the newly created block to it -! - if (associated(block_array(pneigh%process & - ,pmeta%process)%ptr)) & - pinfo%prev => block_array(pneigh%process & - ,pmeta%process)%ptr - -! point the list to the newly created block -! - block_array(pneigh%process,pmeta%process)%ptr => pinfo + call append_exchange_block(pmeta, pneigh, idir, i, j, k) end if ! block and neighbor belong to different processes #endif /* MPI */ @@ -2643,45 +2432,58 @@ module boundaries ! do p = 1, npairs -! get sending and receiving process identifiers +! process only pairs related to this process ! - isend = pairs(p,1) - irecv = pairs(p,2) + if (pairs(p,1) == nproc .or. pairs(p,2) == nproc) then -! process only pairs which have something to exchange +! get sending and receiving process identifiers (depending on pair member) ! - if (block_counter(isend,irecv) > 0) then + if (pairs(p,1) == nproc) then + sproc = pairs(p,1) + rproc = pairs(p,2) + end if + if (pairs(p,2) == nproc) then + sproc = pairs(p,2) + rproc = pairs(p,1) + end if -! obtain the number of blocks to exchange +! get the number of blocks to exchange ! - nblocks = block_counter(isend,irecv) + scount = bcount(sproc,rproc) + rcount = bcount(rproc,sproc) + +! process only pairs which have anything to exchange +! + if ((scount + rcount) > 0) then ! prepare the tag for communication ! - itag = 16 * (irecv * nprocs + isend) + 4 + stag = 16 * (rproc * nprocs + sproc) + 4 + rtag = 16 * (sproc * nprocs + rproc) + 4 ! allocate data buffer for variables to exchange ! - select case(idir) - case(1) - allocate(rbuf(nblocks,nv,ng,jh,kh)) - case(2) - allocate(rbuf(nblocks,nv,ih,ng,kh)) - case(3) - allocate(rbuf(nblocks,nv,ih,jh,ng)) - end select - -! if isend == nproc we are sending data -! - if (isend == nproc) then + select case(idir) + case(1) + allocate(sbuf(scount,nv,ng,jh,kh)) + allocate(rbuf(rcount,nv,ng,jh,kh)) + case(2) + allocate(sbuf(scount,nv,ih,ng,kh)) + allocate(rbuf(rcount,nv,ih,ng,kh)) + case(3) + allocate(sbuf(scount,nv,ih,jh,ng)) + allocate(rbuf(rcount,nv,ih,jh,ng)) + end select +!! PREPARE BLOCKS FOR SENDING +!! ! reset the block counter ! l = 0 -! associate pinfo with the first block in the exchange list +! associate the pointer with the first block in the exchange list ! - pinfo => block_array(isend,irecv)%ptr + pinfo => barray(sproc,rproc)%ptr ! scan over all blocks on the block exchange list ! @@ -2691,7 +2493,7 @@ module boundaries ! l = l + 1 -! prepare pointer for updated meta block and its neighbor +! assign pmeta and pneigh to the right blocks ! pmeta => pinfo%block pneigh => pinfo%neigh @@ -2711,49 +2513,43 @@ module boundaries k = pmeta%pos(3) call block_face_prolong(idir, i, j, k & , pneigh%data%q(1:nv,1:im,1:jm,1:km) & - , rbuf(l,1:nv,1:ng,1:jh,1:kh)) + , sbuf(l,1:nv,1:ng,1:jh,1:kh)) case(2) i = pmeta%pos(1) k = pmeta%pos(3) call block_face_prolong(idir, i, j, k & , pneigh%data%q(1:nv,1:im,1:jm,1:km) & - , rbuf(l,1:nv,1:ih,1:ng,1:kh)) + , sbuf(l,1:nv,1:ih,1:ng,1:kh)) case(3) i = pmeta%pos(1) j = pmeta%pos(2) call block_face_prolong(idir, i, j, k & , pneigh%data%q(1:nv,1:im,1:jm,1:km) & - , rbuf(l,1:nv,1:ih,1:jh,1:ng)) + , sbuf(l,1:nv,1:ih,1:jh,1:ng)) end select -! associate pinfo with the next block +! associate the pointer with the next block ! pinfo => pinfo%prev end do ! %ptr block list -! send the data buffer to another process +!! SEND PREPARED BLOCKS AND RECEIVCE NEW ONES +!! +! exchange data ! - call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) - - end if ! isend = nproc - -! if irecv == nproc we are receiving data -! - if (irecv == nproc) then - -! receive the data buffer -! - call receive_real_array(size(rbuf(:,:,:,:,:)), isend, itag & - , rbuf(:,:,:,:,:), iret) + call exchange_real_arrays(rproc, stag, size(sbuf), sbuf & + , rproc, rtag, size(rbuf), rbuf, iret) +!! PROCESS RECEIVED BLOCKS +!! ! reset the block counter ! l = 0 -! associate pinfo with the first block in the exchange list +! associate the pointer with the first block in the exchange list ! - pinfo => block_array(isend,irecv)%ptr + pinfo => barray(rproc,sproc)%ptr ! iterate over all received blocks and update boundaries of the corresponding ! data blocks @@ -2764,7 +2560,7 @@ module boundaries ! l = l + 1 -! prepare the pointer to updated block +! assign a pointer to the associated data block ! pmeta => pinfo%block @@ -2799,8 +2595,7 @@ module boundaries kl = 1 ku = ke end if - pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = & - rbuf(l,1:nv,1:ng,1:jh,1:kh) + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = rbuf(l,1:nv,1:ng,1:jh,1:kh) case(2) if (j == 1) then jl = 1 @@ -2823,8 +2618,7 @@ module boundaries kl = 1 ku = ke end if - pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = & - rbuf(l,1:nv,1:ih,1:ng,1:kh) + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = rbuf(l,1:nv,1:ih,1:ng,1:kh) case(3) if (k == 1) then kl = 1 @@ -2847,54 +2641,28 @@ module boundaries jl = 1 ju = je end if - pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = & - rbuf(l,1:nv,1:ih,1:jh,1:ng) + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = rbuf(l,1:nv,1:ih,1:jh,1:ng) end select -! associate pinfo with the next block +! associate the pointer with the next block ! pinfo => pinfo%prev end do ! %ptr block list - end if ! irecv = nproc - ! deallocate data buffer ! - if (allocated(rbuf)) deallocate(rbuf) + deallocate(sbuf, rbuf) -! associate pinfo with the first block in the exchange list -! - pinfo => block_array(isend,irecv)%ptr + end if ! (scount + rcount) > 0 -! scan over all blocks on the exchange block list -! - do while(associated(pinfo)) - -! associate the exchange list pointer -! - block_array(isend,irecv)%ptr => pinfo%prev - -! nullify the pointer fields -! - nullify(pinfo%prev) - nullify(pinfo%next) - nullify(pinfo%block) - nullify(pinfo%neigh) - -! deallocate the object -! - deallocate(pinfo) - -! associate pinfo with the next block -! - pinfo => block_array(isend,irecv)%ptr - - end do ! %ptr block list - - end if ! if block_count > 0 + end if ! pairs(p,1) == nproc || pairs(p,2) == nproc end do ! p = 1, npairs + +! release the memory used by the array of exchange block lists +! + call release_exchange_array() #endif /* MPI */ #ifdef PROFILE @@ -2945,10 +2713,9 @@ module boundaries use coordinates , only : ibl, jbl, kbl use coordinates , only : ieu, jeu, keu use equations , only : nv - use mpitools , only : nproc, nprocs, npmax #ifdef MPI - use mpitools , only : npairs, pairs - use mpitools , only : send_real_array, receive_real_array + use mpitools , only : nproc, nprocs, npairs, pairs + use mpitools , only : exchange_real_arrays #endif /* MPI */ ! local variables are not implicit by default @@ -2972,19 +2739,14 @@ module boundaries integer :: ih, jh, kh integer :: il, jl, kl integer :: iu, ju, ku - integer :: iret #ifdef MPI - integer :: isend, irecv, nblocks, itag - integer :: l, p - -! local pointer arrays -! - type(pointer_info), dimension(0:npmax,0:npmax) :: block_array + integer :: sproc, scount, stag + integer :: rproc, rcount, rtag + integer :: l, p, iret ! local arrays ! - integer , dimension(0:npmax,0:npmax) :: block_counter - real(kind=8), dimension(:,:,:,:,:) , allocatable :: rbuf + real(kind=8), dimension(:,:,:,:,:), allocatable :: sbuf, rbuf #endif /* MPI */ ! !------------------------------------------------------------------------------- @@ -3006,17 +2768,9 @@ module boundaries #ifdef MPI !! 1. PREPARE THE BLOCK EXCHANGE ARRAYS FOR MPI !! -! reset the exchange block counters +! prepare the array of exchange block lists and its counters ! - block_counter(:,:) = 0 - -! nullify the info pointers -! - do irecv = 0, npmax - do isend = 0, npmax - nullify(block_array(isend,irecv)%ptr) - end do - end do + call prepare_exchange_array() #endif /* MPI */ !! 2. UPDATE VARIABLE EDGE BOUNDARIES BETWEEN BLOCKS BELONGING TO THE SAME @@ -3147,41 +2901,9 @@ module boundaries else ! block and neighbor belong to different processes -! increase the counter for number of blocks to exchange +! append the block to the exchange list ! - block_counter(pneigh%process,pmeta%process) = & - block_counter(pneigh%process,pmeta%process) + 1 - -! allocate a new info object -! - allocate(pinfo) - -! fill out only fields which are used -! - pinfo%block => pmeta - pinfo%neigh => pneigh - pinfo%direction = idir - pinfo%corner(1) = i - pinfo%corner(2) = j -#if NDIMS == 3 - pinfo%corner(3) = k -#endif /* NDIMS == 3 */ - -! nullify pointer fields of the object -! - nullify(pinfo%prev) - nullify(pinfo%next) - -! if the list is not empty append the newly created block to it -! - if (associated(block_array(pneigh%process & - ,pmeta%process)%ptr)) & - pinfo%prev => block_array(pneigh%process & - ,pmeta%process)%ptr - -! point the list to the newly created block -! - block_array(pneigh%process,pmeta%process)%ptr => pinfo + call append_exchange_block(pmeta, pneigh, idir, i, j, k) end if ! block and neighbor belong to different processes #endif /* MPI */ @@ -3213,53 +2935,68 @@ module boundaries ! do p = 1, npairs -! get sending and receiving process identifiers +! process only pairs related to this process ! - isend = pairs(p,1) - irecv = pairs(p,2) + if (pairs(p,1) == nproc .or. pairs(p,2) == nproc) then -! process only pairs which have something to exchange +! get sending and receiving process identifiers (depending on pair member) ! - if (block_counter(isend,irecv) > 0) then + if (pairs(p,1) == nproc) then + sproc = pairs(p,1) + rproc = pairs(p,2) + end if + if (pairs(p,2) == nproc) then + sproc = pairs(p,2) + rproc = pairs(p,1) + end if -! obtain the number of blocks to exchange +! get the number of blocks to exchange ! - nblocks = block_counter(isend,irecv) + scount = bcount(sproc,rproc) + rcount = bcount(rproc,sproc) + +! process only pairs which have anything to exchange +! + if ((scount + rcount) > 0) then ! prepare the tag for communication ! - itag = 16 * (irecv * nprocs + isend) + 5 + stag = 16 * (rproc * nprocs + sproc) + 5 + rtag = 16 * (sproc * nprocs + rproc) + 5 -! allocate data buffer for variables to exchange +! allocate buffers for variable exchange ! - select case(idir) + select case(idir) #if NDIMS == 2 - case(1) - allocate(rbuf(nblocks,nv,ih,ng,km)) - case(2) - allocate(rbuf(nblocks,nv,ng,jh,km)) + case(1) + allocate(sbuf(scount,nv,ih,ng,km)) + allocate(rbuf(rcount,nv,ih,ng,km)) + case(2) + allocate(sbuf(scount,nv,ng,jh,km)) + allocate(rbuf(rcount,nv,ng,jh,km)) #endif /* NDIMS == 2 */ #if NDIMS == 3 - case(1) - allocate(rbuf(nblocks,nv,ih,ng,ng)) - case(2) - allocate(rbuf(nblocks,nv,ng,jh,ng)) - case(3) - allocate(rbuf(nblocks,nv,ng,ng,kh)) + case(1) + allocate(sbuf(scount,nv,ih,ng,ng)) + allocate(rbuf(rcount,nv,ih,ng,ng)) + case(2) + allocate(sbuf(scount,nv,ng,jh,ng)) + allocate(rbuf(rcount,nv,ng,jh,ng)) + case(3) + allocate(sbuf(scount,nv,ng,ng,kh)) + allocate(rbuf(rcount,nv,ng,ng,kh)) #endif /* NDIMS == 3 */ - end select - -! if isend == nproc we are sending data from the neighbor block -! - if (isend == nproc) then + end select +!! PREPARE BLOCKS FOR SENDING +!! ! reset the block counter ! l = 0 ! associate the pointer with the first block in the exchange list ! - pinfo => block_array(isend,irecv)%ptr + pinfo => barray(sproc,rproc)%ptr ! scan over all blocks on the block exchange list ! @@ -3289,29 +3026,29 @@ module boundaries #if NDIMS == 2 call block_edge_copy(idir, i, j, k & , pneigh%data%q(1:nv,1:im,1:jm,1:km) & - , rbuf(l,1:nv,1:ih,1:ng,1:km)) + , sbuf(l,1:nv,1:ih,1:ng,1:km)) #endif /* NDIMS == 2 */ #if NDIMS == 3 call block_edge_copy(idir, i, j, k & , pneigh%data%q(1:nv,1:im,1:jm,1:km) & - , rbuf(l,1:nv,1:ih,1:ng,1:ng)) + , sbuf(l,1:nv,1:ih,1:ng,1:ng)) #endif /* NDIMS == 3 */ case(2) #if NDIMS == 2 call block_edge_copy(idir, i, j, k & , pneigh%data%q(1:nv,1:im,1:jm,1:km) & - , rbuf(l,1:nv,1:ng,1:jh,1:km)) + , sbuf(l,1:nv,1:ng,1:jh,1:km)) #endif /* NDIMS == 2 */ #if NDIMS == 3 call block_edge_copy(idir, i, j, k & , pneigh%data%q(1:nv,1:im,1:jm,1:km) & - , rbuf(l,1:nv,1:ng,1:jh,1:ng)) + , sbuf(l,1:nv,1:ng,1:jh,1:ng)) #endif /* NDIMS == 3 */ #if NDIMS == 3 case(3) call block_edge_copy(idir, i, j, k & , pneigh%data%q(1:nv,1:im,1:jm,1:km) & - , rbuf(l,1:nv,1:ng,1:ng,1:kh)) + , sbuf(l,1:nv,1:ng,1:ng,1:kh)) #endif /* NDIMS == 3 */ end select @@ -3321,28 +3058,22 @@ module boundaries end do ! %ptr block list -! send the data buffer to another process +!! SEND PREPARED BLOCKS AND RECEIVCE NEW ONES +!! +! exchange data ! - call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) - - end if ! isend = nproc - -! if irecv == nproc we are receiving data from the neighbor block -! - if (irecv == nproc) then - -! receive the data buffer -! - call receive_real_array(size(rbuf(:,:,:,:,:)), isend, itag & - , rbuf(:,:,:,:,:), iret) + call exchange_real_arrays(rproc, stag, size(sbuf), sbuf & + , rproc, rtag, size(rbuf), rbuf, iret) +!! PROCESS RECEIVED BLOCKS +!! ! reset the block counter ! l = 0 ! associate the pointer with the first block in the exchange list ! - pinfo => block_array(isend,irecv)%ptr + pinfo => barray(rproc,sproc)%ptr ! iterate over all received blocks and update boundaries of the corresponding ! data blocks @@ -3446,44 +3177,19 @@ module boundaries end do ! %ptr block list - end if ! irecv = nproc - ! deallocate data buffer ! - if (allocated(rbuf)) deallocate(rbuf) + deallocate(sbuf, rbuf) -! associate the pointer with the first block in the exchange list -! - pinfo => block_array(isend,irecv)%ptr + end if ! (scount + rcount) > 0 -! scan over all blocks on the exchange block list -! - do while(associated(pinfo)) - -! associate the exchange list pointer -! - block_array(isend,irecv)%ptr => pinfo%prev - -! nullify the pointer fields -! - nullify(pinfo%prev) - nullify(pinfo%next) - nullify(pinfo%block) - nullify(pinfo%neigh) - -! deallocate the object -! - deallocate(pinfo) - -! associate the pointer with the next block -! - pinfo => block_array(isend,irecv)%ptr - - end do ! %ptr block list - - end if ! if block_count > 0 + end if ! pairs(p,1) == nproc || pairs(p,2) == nproc end do ! p = 1, npairs + +! release the memory used by the array of exchange block lists +! + call release_exchange_array() #endif /* MPI */ #ifdef PROFILE @@ -3527,10 +3233,9 @@ module boundaries use coordinates , only : ibl, jbl, kbl use coordinates , only : ieu, jeu, keu use equations , only : nv - use mpitools , only : nproc, nprocs, npmax #ifdef MPI - use mpitools , only : npairs, pairs - use mpitools , only : send_real_array, receive_real_array + use mpitools , only : nproc, nprocs, npairs, pairs + use mpitools , only : exchange_real_arrays #endif /* MPI */ ! local variables are not implicit by default @@ -3554,19 +3259,14 @@ module boundaries integer :: ih, jh, kh integer :: il, jl, kl integer :: iu, ju, ku - integer :: iret #ifdef MPI - integer :: isend, irecv, nblocks, itag - integer :: l, p - -! local pointer arrays -! - type(pointer_info), dimension(0:npmax,0:npmax) :: block_array + integer :: sproc, scount, stag + integer :: rproc, rcount, rtag + integer :: l, p, iret ! local arrays ! - integer , dimension(0:npmax,0:npmax) :: block_counter - real(kind=8), dimension(:,:,:,:,:) , allocatable :: rbuf + real(kind=8), dimension(:,:,:,:,:), allocatable :: sbuf, rbuf #endif /* MPI */ ! !------------------------------------------------------------------------------- @@ -3588,17 +3288,9 @@ module boundaries #ifdef MPI !! 1. PREPARE THE BLOCK EXCHANGE ARRAYS FOR MPI !! -! reset the exchange block counters +! prepare the array of exchange block lists and its counters ! - block_counter(:,:) = 0 - -! nullify the info pointers -! - do irecv = 0, npmax - do isend = 0, npmax - nullify(block_array(isend,irecv)%ptr) - end do - end do + call prepare_exchange_array() #endif /* MPI */ !! 2. UPDATE VARIABLE EDGE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT @@ -3729,41 +3421,9 @@ module boundaries else ! block and neighbor belong to different processes -! increase the counter for number of blocks to exchange +! append the block to the exchange list ! - block_counter(pneigh%process,pmeta%process) = & - block_counter(pneigh%process,pmeta%process) + 1 - -! allocate a new info object -! - allocate(pinfo) - -! fill out only fields which are used -! - pinfo%block => pmeta - pinfo%neigh => pneigh - pinfo%direction = idir - pinfo%corner(1) = i - pinfo%corner(2) = j -#if NDIMS == 3 - pinfo%corner(3) = k -#endif /* NDIMS == 3 */ - -! nullify pointer fields of the object -! - nullify(pinfo%prev) - nullify(pinfo%next) - -! if the list is not empty append the newly created block to it -! - if (associated(block_array(pneigh%process & - ,pmeta%process)%ptr)) & - pinfo%prev => block_array(pneigh%process & - ,pmeta%process)%ptr - -! point the list to the newly created block -! - block_array(pneigh%process,pmeta%process)%ptr => pinfo + call append_exchange_block(pmeta, pneigh, idir, i, j, k) end if ! block and neighbor belong to different processes #endif /* MPI */ @@ -3795,53 +3455,68 @@ module boundaries ! do p = 1, npairs -! get sending and receiving process identifiers +! process only pairs related to this process ! - isend = pairs(p,1) - irecv = pairs(p,2) + if (pairs(p,1) == nproc .or. pairs(p,2) == nproc) then -! process only pairs which have something to exchange +! get sending and receiving process identifiers (depending on pair member) ! - if (block_counter(isend,irecv) > 0) then + if (pairs(p,1) == nproc) then + sproc = pairs(p,1) + rproc = pairs(p,2) + end if + if (pairs(p,2) == nproc) then + sproc = pairs(p,2) + rproc = pairs(p,1) + end if -! obtain the number of blocks to exchange +! get the number of blocks to exchange ! - nblocks = block_counter(isend,irecv) + scount = bcount(sproc,rproc) + rcount = bcount(rproc,sproc) + +! process only pairs which have anything to exchange +! + if ((scount + rcount) > 0) then ! prepare the tag for communication ! - itag = 16 * (irecv * nprocs + isend) + 6 + stag = 16 * (rproc * nprocs + sproc) + 6 + rtag = 16 * (sproc * nprocs + rproc) + 6 -! allocate data buffer for variables to exchange +! allocate buffers for variable exchange ! - select case(idir) + select case(idir) #if NDIMS == 2 - case(1) - allocate(rbuf(nblocks,nv,ih,ng,km)) - case(2) - allocate(rbuf(nblocks,nv,ng,jh,km)) + case(1) + allocate(sbuf(scount,nv,ih,ng,km)) + allocate(rbuf(rcount,nv,ih,ng,km)) + case(2) + allocate(sbuf(scount,nv,ng,jh,km)) + allocate(rbuf(rcount,nv,ng,jh,km)) #endif /* NDIMS == 2 */ #if NDIMS == 3 - case(1) - allocate(rbuf(nblocks,nv,ih,ng,ng)) - case(2) - allocate(rbuf(nblocks,nv,ng,jh,ng)) - case(3) - allocate(rbuf(nblocks,nv,ng,ng,kh)) + case(1) + allocate(sbuf(scount,nv,ih,ng,ng)) + allocate(rbuf(rcount,nv,ih,ng,ng)) + case(2) + allocate(sbuf(scount,nv,ng,jh,ng)) + allocate(rbuf(rcount,nv,ng,jh,ng)) + case(3) + allocate(sbuf(scount,nv,ng,ng,kh)) + allocate(rbuf(rcount,nv,ng,ng,kh)) #endif /* NDIMS == 3 */ - end select - -! if isend == nproc we are sending data from the neighbor block -! - if (isend == nproc) then + end select +!! PREPARE BLOCKS FOR SENDING +!! ! reset the block counter ! l = 0 ! associate the pointer with the first block in the exchange list ! - pinfo => block_array(isend,irecv)%ptr + pinfo => barray(sproc,rproc)%ptr ! scan over all blocks on the block exchange list ! @@ -3871,29 +3546,29 @@ module boundaries #if NDIMS == 2 call block_edge_restrict(idir, i, j, k & , pneigh%data%q(1:nv,1:im,1:jm,1:km) & - , rbuf(l,1:nv,1:ih,1:ng,1:km)) + , sbuf(l,1:nv,1:ih,1:ng,1:km)) #endif /* NDIMS == 2 */ #if NDIMS == 3 call block_edge_restrict(idir, i, j, k & , pneigh%data%q(1:nv,1:im,1:jm,1:km) & - , rbuf(l,1:nv,1:ih,1:ng,1:ng)) + , sbuf(l,1:nv,1:ih,1:ng,1:ng)) #endif /* NDIMS == 3 */ case(2) #if NDIMS == 2 call block_edge_restrict(idir, i, j, k & , pneigh%data%q(1:nv,1:im,1:jm,1:km) & - , rbuf(l,1:nv,1:ng,1:jh,1:km)) + , sbuf(l,1:nv,1:ng,1:jh,1:km)) #endif /* NDIMS == 2 */ #if NDIMS == 3 call block_edge_restrict(idir, i, j, k & , pneigh%data%q(1:nv,1:im,1:jm,1:km) & - , rbuf(l,1:nv,1:ng,1:jh,1:ng)) + , sbuf(l,1:nv,1:ng,1:jh,1:ng)) #endif /* NDIMS == 3 */ #if NDIMS == 3 case(3) call block_edge_restrict(idir, i, j, k & , pneigh%data%q(1:nv,1:im,1:jm,1:km) & - , rbuf(l,1:nv,1:ng,1:ng,1:kh)) + , sbuf(l,1:nv,1:ng,1:ng,1:kh)) #endif /* NDIMS == 3 */ end select @@ -3903,28 +3578,22 @@ module boundaries end do ! %ptr block list -! send the data buffer to another process +!! SEND PREPARED BLOCKS AND RECEIVCE NEW ONES +!! +! exchange data ! - call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) - - end if ! isend = nproc - -! if irecv == nproc we are receiving data from the neighbor block -! - if (irecv == nproc) then - -! receive the data buffer -! - call receive_real_array(size(rbuf(:,:,:,:,:)), isend, itag & - , rbuf(:,:,:,:,:), iret) + call exchange_real_arrays(rproc, stag, size(sbuf), sbuf & + , rproc, rtag, size(rbuf), rbuf, iret) +!! PROCESS RECEIVED BLOCKS +!! ! reset the block counter ! l = 0 ! associate the pointer with the first block in the exchange list ! - pinfo => block_array(isend,irecv)%ptr + pinfo => barray(rproc,sproc)%ptr ! iterate over all received blocks and update boundaries of the corresponding ! data blocks @@ -4028,44 +3697,19 @@ module boundaries end do ! %ptr block list - end if ! irecv = nproc - ! deallocate data buffer ! - if (allocated(rbuf)) deallocate(rbuf) + deallocate(sbuf, rbuf) -! associate the pointer with the first block in the exchange list -! - pinfo => block_array(isend,irecv)%ptr + end if ! (scount + rcount) > 0 -! scan over all blocks on the exchange block list -! - do while(associated(pinfo)) - -! associate the exchange list pointer -! - block_array(isend,irecv)%ptr => pinfo%prev - -! nullify the pointer fields -! - nullify(pinfo%prev) - nullify(pinfo%next) - nullify(pinfo%block) - nullify(pinfo%neigh) - -! deallocate the object -! - deallocate(pinfo) - -! associate the pointer with the next block -! - pinfo => block_array(isend,irecv)%ptr - - end do ! %ptr block list - - end if ! if block_count > 0 + end if ! pairs(p,1) == nproc || pairs(p,2) == nproc end do ! p = 1, npairs + +! release the memory used by the array of exchange block lists +! + call release_exchange_array() #endif /* MPI */ #ifdef PROFILE @@ -4109,10 +3753,9 @@ module boundaries use coordinates , only : ibl, jbl, kbl use coordinates , only : ieu, jeu, keu use equations , only : nv - use mpitools , only : nproc, nprocs, npmax #ifdef MPI - use mpitools , only : npairs, pairs - use mpitools , only : send_real_array, receive_real_array + use mpitools , only : nproc, nprocs, npairs, pairs + use mpitools , only : exchange_real_arrays #endif /* MPI */ ! local variables are not implicit by default @@ -4137,19 +3780,14 @@ module boundaries integer :: ih, jh, kh integer :: il, jl, kl integer :: iu, ju, ku - integer :: iret #ifdef MPI - integer :: isend, irecv, nblocks, itag - integer :: l, p - -! local pointer arrays -! - type(pointer_info), dimension(0:npmax,0:npmax) :: block_array + integer :: sproc, scount, stag + integer :: rproc, rcount, rtag + integer :: l, p, iret ! local arrays ! - integer , dimension(0:npmax,0:npmax) :: block_counter - real(kind=8), dimension(:,:,:,:,:) , allocatable :: rbuf + real(kind=8), dimension(:,:,:,:,:), allocatable :: sbuf, rbuf #endif /* MPI */ ! !------------------------------------------------------------------------------- @@ -4171,17 +3809,9 @@ module boundaries #ifdef MPI !! 1. PREPARE THE BLOCK EXCHANGE ARRAYS FOR MPI !! -! reset the exchange block counters +! prepare the array of exchange block lists and its counters ! - block_counter(:,:) = 0 - -! nullify the info pointers -! - do irecv = 0, npmax - do isend = 0, npmax - nullify(block_array(isend,irecv)%ptr) - end do - end do + call prepare_exchange_array() #endif /* MPI */ !! 2. UPDATE VARIABLE EDGE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT @@ -4318,41 +3948,9 @@ module boundaries else ! block and neighbor belong to different processes -! increase the counter for number of blocks to exchange +! append the block to the exchange list ! - block_counter(pneigh%process,pmeta%process) = & - block_counter(pneigh%process,pmeta%process) + 1 - -! allocate a new info object -! - allocate(pinfo) - -! fill out only fields which are used -! - pinfo%block => pmeta - pinfo%neigh => pneigh - pinfo%direction = idir - pinfo%corner(1) = i - pinfo%corner(2) = j -#if NDIMS == 3 - pinfo%corner(3) = k -#endif /* NDIMS == 3 */ - -! nullify pointer fields of the object -! - nullify(pinfo%prev) - nullify(pinfo%next) - -! if the list is not empty append the newly created block to it -! - if (associated(block_array(pneigh%process & - ,pmeta%process)%ptr)) & - pinfo%prev => block_array(pneigh%process & - ,pmeta%process)%ptr - -! point the list to the newly created block -! - block_array(pneigh%process,pmeta%process)%ptr => pinfo + call append_exchange_block(pmeta, pneigh, idir, i, j, k) end if ! block and neighbor belong to different processes #endif /* MPI */ @@ -4384,53 +3982,68 @@ module boundaries ! do p = 1, npairs -! get sending and receiving process identifiers +! process only pairs related to this process ! - isend = pairs(p,1) - irecv = pairs(p,2) + if (pairs(p,1) == nproc .or. pairs(p,2) == nproc) then -! process only pairs which have something to exchange +! get sending and receiving process identifiers (depending on pair member) ! - if (block_counter(isend,irecv) > 0) then + if (pairs(p,1) == nproc) then + sproc = pairs(p,1) + rproc = pairs(p,2) + end if + if (pairs(p,2) == nproc) then + sproc = pairs(p,2) + rproc = pairs(p,1) + end if -! obtain the number of blocks to exchange +! get the number of blocks to exchange ! - nblocks = block_counter(isend,irecv) + scount = bcount(sproc,rproc) + rcount = bcount(rproc,sproc) + +! process only pairs which have anything to exchange +! + if ((scount + rcount) > 0) then ! prepare the tag for communication ! - itag = 16 * (irecv * nprocs + isend) + 7 + stag = 16 * (rproc * nprocs + sproc) + 7 + rtag = 16 * (sproc * nprocs + rproc) + 7 -! allocate data buffer for variables to exchange +! allocate buffers for variable exchange ! - select case(idir) + select case(idir) #if NDIMS == 2 - case(1) - allocate(rbuf(nblocks,nv,ih,ng,km)) - case(2) - allocate(rbuf(nblocks,nv,ng,jh,km)) + case(1) + allocate(sbuf(scount,nv,ih,ng,km)) + allocate(rbuf(rcount,nv,ih,ng,km)) + case(2) + allocate(sbuf(scount,nv,ng,jh,km)) + allocate(rbuf(rcount,nv,ng,jh,km)) #endif /* NDIMS == 2 */ #if NDIMS == 3 - case(1) - allocate(rbuf(nblocks,nv,ih,ng,ng)) - case(2) - allocate(rbuf(nblocks,nv,ng,jh,ng)) - case(3) - allocate(rbuf(nblocks,nv,ng,ng,kh)) + case(1) + allocate(sbuf(scount,nv,ih,ng,ng)) + allocate(rbuf(rcount,nv,ih,ng,ng)) + case(2) + allocate(sbuf(scount,nv,ng,jh,ng)) + allocate(rbuf(rcount,nv,ng,jh,ng)) + case(3) + allocate(sbuf(scount,nv,ng,ng,kh)) + allocate(rbuf(rcount,nv,ng,ng,kh)) #endif /* NDIMS == 3 */ - end select - -! if isend == nproc we are sending data from the neighbor block -! - if (isend == nproc) then + end select +!! PREPARE BLOCKS FOR SENDING +!! ! reset the block counter ! l = 0 ! associate the pointer with the first block in the exchange list ! - pinfo => block_array(isend,irecv)%ptr + pinfo => barray(sproc,rproc)%ptr ! scan over all blocks on the block exchange list ! @@ -4462,31 +4075,31 @@ module boundaries #if NDIMS == 2 call block_edge_prolong(idir, i, j, k & , pneigh%data%q(1:nv,1:im,1:jm,1:km) & - , rbuf(l,1:nv,1:ih,1:ng,1:km)) + , sbuf(l,1:nv,1:ih,1:ng,1:km)) #endif /* NDIMS == 2 */ #if NDIMS == 3 call block_edge_prolong(idir, i, j, k & , pneigh%data%q(1:nv,1:im,1:jm,1:km) & - , rbuf(l,1:nv,1:ih,1:ng,1:ng)) + , sbuf(l,1:nv,1:ih,1:ng,1:ng)) #endif /* NDIMS == 3 */ case(2) j = pmeta%pos(2) #if NDIMS == 2 call block_edge_prolong(idir, i, j, k & , pneigh%data%q(1:nv,1:im,1:jm,1:km) & - , rbuf(l,1:nv,1:ng,1:jh,1:km)) + , sbuf(l,1:nv,1:ng,1:jh,1:km)) #endif /* NDIMS == 2 */ #if NDIMS == 3 call block_edge_prolong(idir, i, j, k & , pneigh%data%q(1:nv,1:im,1:jm,1:km) & - , rbuf(l,1:nv,1:ng,1:jh,1:ng)) + , sbuf(l,1:nv,1:ng,1:jh,1:ng)) #endif /* NDIMS == 3 */ #if NDIMS == 3 case(3) k = pmeta%pos(3) call block_edge_prolong(idir, i, j, k & , pneigh%data%q(1:nv,1:im,1:jm,1:km) & - , rbuf(l,1:nv,1:ng,1:ng,1:kh)) + , sbuf(l,1:nv,1:ng,1:ng,1:kh)) #endif /* NDIMS == 3 */ end select @@ -4496,28 +4109,22 @@ module boundaries end do ! %ptr block list -! send the data buffer to another process +!! SEND PREPARED BLOCKS AND RECEIVCE NEW ONES +!! +! exchange data ! - call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) - - end if ! isend = nproc - -! if irecv == nproc we are receiving data from the neighbor block -! - if (irecv == nproc) then - -! receive the data buffer -! - call receive_real_array(size(rbuf(:,:,:,:,:)), isend, itag & - , rbuf(:,:,:,:,:), iret) + call exchange_real_arrays(rproc, stag, size(sbuf), sbuf & + , rproc, rtag, size(rbuf), rbuf, iret) +!! PROCESS RECEIVED BLOCKS +!! ! reset the block counter ! l = 0 ! associate the pointer with the first block in the exchange list ! - pinfo => block_array(isend,irecv)%ptr + pinfo => barray(rproc,sproc)%ptr ! iterate over all received blocks and update boundaries of the corresponding ! data blocks @@ -4621,44 +4228,19 @@ module boundaries end do ! %ptr block list - end if ! irecv = nproc - ! deallocate data buffer ! - if (allocated(rbuf)) deallocate(rbuf) + deallocate(sbuf, rbuf) -! associate the pointer with the first block in the exchange list -! - pinfo => block_array(isend,irecv)%ptr + end if ! (scount + rcount) > 0 -! scan over all blocks on the exchange block list -! - do while(associated(pinfo)) - -! associate the exchange list pointer -! - block_array(isend,irecv)%ptr => pinfo%prev - -! nullify the pointer fields -! - nullify(pinfo%prev) - nullify(pinfo%next) - nullify(pinfo%block) - nullify(pinfo%neigh) - -! deallocate the object -! - deallocate(pinfo) - -! associate the pointer with the next block -! - pinfo => block_array(isend,irecv)%ptr - - end do ! %ptr block list - - end if ! if block_count > 0 + end if ! pairs(p,1) == nproc || pairs(p,2) == nproc end do ! p = 1, npairs + +! release the memory used by the array of exchange block lists +! + call release_exchange_array() #endif /* MPI */ #ifdef PROFILE @@ -4702,10 +4284,9 @@ module boundaries use coordinates , only : ibl, jbl, kbl use coordinates , only : ieu, jeu, keu use equations , only : nv - use mpitools , only : nproc, nprocs, npmax #ifdef MPI - use mpitools , only : npairs, pairs - use mpitools , only : send_real_array, receive_real_array + use mpitools , only : nproc, nprocs, npairs, pairs + use mpitools , only : exchange_real_arrays #endif /* MPI */ ! local variables are not implicit by default @@ -4724,19 +4305,14 @@ module boundaries integer :: i , j , k integer :: il, jl, kl integer :: iu, ju, ku - integer :: iret #ifdef MPI - integer :: isend, irecv, nblocks, itag - integer :: l, p - -! local pointer arrays -! - type(pointer_info), dimension(0:npmax,0:npmax) :: block_array + integer :: sproc, scount, stag + integer :: rproc, rcount, rtag + integer :: l, p, iret ! local arrays ! - integer , dimension(0:npmax,0:npmax) :: block_counter - real(kind=8), dimension(:,:,:,:,:) , allocatable :: rbuf + real(kind=8), dimension(:,:,:,:,:), allocatable :: sbuf, rbuf #endif /* MPI */ ! !------------------------------------------------------------------------------- @@ -4750,17 +4326,9 @@ module boundaries #ifdef MPI !! 1. PREPARE THE BLOCK EXCHANGE ARRAYS FOR MPI !! -! reset the exchange block counters +! prepare the array of exchange block lists and its counters ! - block_counter(:,:) = 0 - -! nullify the info pointers -! - do irecv = 0, npmax - do isend = 0, npmax - nullify(block_array(isend,irecv)%ptr) - end do - end do + call prepare_exchange_array() #endif /* MPI */ !! 2. UPDATE VARIABLE CORNER BOUNDARIES BETWEEN BLOCKS BELONGING TO THE SAME @@ -4863,40 +4431,9 @@ module boundaries else ! block and neighbor belong to different processes -! increase the counter for number of blocks to exchange +! append the block to the exchange list ! - block_counter(pneigh%process,pmeta%process) = & - block_counter(pneigh%process,pmeta%process) + 1 - -! allocate a new info object -! - allocate(pinfo) - -! fill out only fields which are used -! - pinfo%block => pmeta - pinfo%neigh => pneigh - pinfo%corner(1) = i - pinfo%corner(2) = j -#if NDIMS == 3 - pinfo%corner(3) = k -#endif /* NDIMS == 3 */ - -! nullify pointer fields of the object -! - nullify(pinfo%prev) - nullify(pinfo%next) - -! if the list is not empty append the newly created block to it -! - if (associated(block_array(pneigh%process & - ,pmeta%process)%ptr)) & - pinfo%prev => block_array(pneigh%process & - ,pmeta%process)%ptr - -! point the list to the newly created block -! - block_array(pneigh%process,pmeta%process)%ptr => pinfo + call append_exchange_block(pmeta, pneigh, -1, i, j, k) end if ! block and neighbor belong to different processes #endif /* MPI */ @@ -4928,43 +4465,55 @@ module boundaries ! do p = 1, npairs -! get sending and receiving process identifiers +! process only pairs related to this process ! - isend = pairs(p,1) - irecv = pairs(p,2) + if (pairs(p,1) == nproc .or. pairs(p,2) == nproc) then -! process only pairs which have something to exchange +! get sending and receiving process identifiers (depending on pair member) ! - if (block_counter(isend,irecv) > 0) then + if (pairs(p,1) == nproc) then + sproc = pairs(p,1) + rproc = pairs(p,2) + end if + if (pairs(p,2) == nproc) then + sproc = pairs(p,2) + rproc = pairs(p,1) + end if -! obtain the number of blocks to exchange +! get the number of blocks to exchange ! - nblocks = block_counter(isend,irecv) + scount = bcount(sproc,rproc) + rcount = bcount(rproc,sproc) + +! process only pairs which have anything to exchange +! + if ((scount + rcount) > 0) then ! prepare the tag for communication ! - itag = 16 * (irecv * nprocs + isend) + 8 + stag = 16 * (rproc * nprocs + sproc) + 8 + rtag = 16 * (sproc * nprocs + rproc) + 8 -! allocate data buffer for variables to exchange +! allocate buffers for variable exchange ! #if NDIMS == 2 - allocate(rbuf(nblocks,nv,ng,ng,km)) + allocate(sbuf(scount,nv,ng,ng,km)) + allocate(rbuf(rcount,nv,ng,ng,km)) #endif /* NDIMS == 2 */ #if NDIMS == 3 - allocate(rbuf(nblocks,nv,ng,ng,ng)) + allocate(sbuf(scount,nv,ng,ng,ng)) + allocate(rbuf(rcount,nv,ng,ng,ng)) #endif /* NDIMS == 3 */ -! if isend == nproc we are sending data from the neighbor block -! - if (isend == nproc) then - +!! PREPARE BLOCKS FOR SENDING +!! ! reset the block counter ! l = 0 ! associate the pointer with the first block in the exchange list ! - pinfo => block_array(isend,irecv)%ptr + pinfo => barray(sproc,rproc)%ptr ! scan over all blocks on the block exchange list ! @@ -4991,13 +4540,13 @@ module boundaries ! #if NDIMS == 2 call block_corner_copy(i, j, k & - , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & - , rbuf(l,1:nv,1:ng,1:ng,1:km)) + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , sbuf(l,1:nv,1:ng,1:ng,1:km)) #endif /* NDIMS == 2 */ #if NDIMS == 3 call block_corner_copy(i, j, k & - , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & - , rbuf(l,1:nv,1:ng,1:ng,1:ng)) + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , sbuf(l,1:nv,1:ng,1:ng,1:ng)) #endif /* NDIMS == 3 */ ! associate the pointer with the next block @@ -5006,28 +4555,22 @@ module boundaries end do ! %ptr block list -! send the data buffer to another process +!! SEND PREPARED BLOCKS AND RECEIVCE NEW ONES +!! +! exchange data ! - call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) - - end if ! isend = nproc - -! if irecv == nproc we are receiving data from the neighbor block -! - if (irecv == nproc) then - -! receive the data buffer -! - call receive_real_array(size(rbuf(:,:,:,:,:)), isend, itag & - , rbuf(:,:,:,:,:), iret) + call exchange_real_arrays(rproc, stag, size(sbuf), sbuf & + , rproc, rtag, size(rbuf), rbuf, iret) +!! PROCESS RECEIVED BLOCKS +!! ! reset the block counter ! l = 0 ! associate the pointer with the first block in the exchange list ! - pinfo => block_array(isend,irecv)%ptr + pinfo => barray(rproc,sproc)%ptr ! iterate over all received blocks and update boundaries of the corresponding ! data blocks @@ -5091,44 +4634,19 @@ module boundaries end do ! %ptr block list - end if ! irecv = nproc - ! deallocate data buffer ! - if (allocated(rbuf)) deallocate(rbuf) + deallocate(sbuf, rbuf) -! associate the pointer with the first block in the exchange list -! - pinfo => block_array(isend,irecv)%ptr + end if ! (scount + rcount) > 0 -! scan over all blocks on the exchange block list -! - do while(associated(pinfo)) - -! associate the exchange list pointer -! - block_array(isend,irecv)%ptr => pinfo%prev - -! nullify the pointer fields -! - nullify(pinfo%prev) - nullify(pinfo%next) - nullify(pinfo%block) - nullify(pinfo%neigh) - -! deallocate the object -! - deallocate(pinfo) - -! associate the pointer with the next block -! - pinfo => block_array(isend,irecv)%ptr - - end do ! %ptr block list - - end if ! if block_count > 0 + end if ! pairs(p,1) == nproc || pairs(p,2) == nproc end do ! p = 1, npairs + +! release the memory used by the array of exchange block lists +! + call release_exchange_array() #endif /* MPI */ #ifdef PROFILE @@ -5166,10 +4684,9 @@ module boundaries use coordinates , only : ibl, jbl, kbl use coordinates , only : ieu, jeu, keu use equations , only : nv - use mpitools , only : nproc, nprocs, npmax #ifdef MPI - use mpitools , only : npairs, pairs - use mpitools , only : send_real_array, receive_real_array + use mpitools , only : nproc, nprocs, npairs, pairs + use mpitools , only : exchange_real_arrays #endif /* MPI */ ! local variables are not implicit by default @@ -5188,19 +4705,14 @@ module boundaries integer :: i , j , k integer :: il, jl, kl integer :: iu, ju, ku - integer :: iret #ifdef MPI - integer :: isend, irecv, nblocks, itag - integer :: l, p - -! local pointer arrays -! - type(pointer_info), dimension(0:npmax,0:npmax) :: block_array + integer :: sproc, scount, stag + integer :: rproc, rcount, rtag + integer :: l, p, iret ! local arrays ! - integer , dimension(0:npmax,0:npmax) :: block_counter - real(kind=8), dimension(:,:,:,:,:) , allocatable :: rbuf + real(kind=8), dimension(:,:,:,:,:), allocatable :: sbuf, rbuf #endif /* MPI */ ! !------------------------------------------------------------------------------- @@ -5214,17 +4726,9 @@ module boundaries #ifdef MPI !! 1. PREPARE THE BLOCK EXCHANGE ARRAYS FOR MPI !! -! reset the exchange block counters +! prepare the array of exchange block lists and its counters ! - block_counter(:,:) = 0 - -! nullify the info pointers -! - do irecv = 0, npmax - do isend = 0, npmax - nullify(block_array(isend,irecv)%ptr) - end do - end do + call prepare_exchange_array() #endif /* MPI */ !! 2. UPDATE VARIABLE CORNER BOUNDARIES BETWEEN BLOCKS BELONGING TO THE SAME @@ -5327,40 +4831,9 @@ module boundaries else ! block and neighbor on different processors -! increase the counter for number of blocks to exchange +! append the block to the exchange list ! - block_counter(pneigh%process,pmeta%process) = & - block_counter(pneigh%process,pmeta%process) + 1 - -! allocate a new info object -! - allocate(pinfo) - -! fill out only fields which are used -! - pinfo%block => pmeta - pinfo%neigh => pneigh - pinfo%corner(1) = i - pinfo%corner(2) = j -#if NDIMS == 3 - pinfo%corner(3) = k -#endif /* NDIMS == 3 */ - -! nullify pointer fields of the object -! - nullify(pinfo%prev) - nullify(pinfo%next) - -! if the list is not empty append the newly created block to it -! - if (associated(block_array(pneigh%process & - ,pmeta%process)%ptr)) & - pinfo%prev => block_array(pneigh%process & - ,pmeta%process)%ptr - -! point the list to the newly created block -! - block_array(pneigh%process,pmeta%process)%ptr => pinfo + call append_exchange_block(pmeta, pneigh, -1, i, j, k) end if ! block and neighbor on different processors #endif /* MPI */ @@ -5391,43 +4864,55 @@ module boundaries ! do p = 1, npairs -! get sending and receiving process identifiers +! process only pairs related to this process ! - isend = pairs(p,1) - irecv = pairs(p,2) + if (pairs(p,1) == nproc .or. pairs(p,2) == nproc) then -! process only pairs which have something to exchange +! get sending and receiving process identifiers (depending on pair member) ! - if (block_counter(isend,irecv) > 0) then + if (pairs(p,1) == nproc) then + sproc = pairs(p,1) + rproc = pairs(p,2) + end if + if (pairs(p,2) == nproc) then + sproc = pairs(p,2) + rproc = pairs(p,1) + end if -! obtain the number of blocks to exchange +! get the number of blocks to exchange ! - nblocks = block_counter(isend,irecv) + scount = bcount(sproc,rproc) + rcount = bcount(rproc,sproc) + +! process only pairs which have anything to exchange +! + if ((scount + rcount) > 0) then ! prepare the tag for communication ! - itag = 16 * (irecv * nprocs + isend) + 9 + stag = 16 * (rproc * nprocs + sproc) + 9 + rtag = 16 * (sproc * nprocs + rproc) + 9 -! allocate data buffer for variables to exchange +! allocate buffers for variable exchange ! #if NDIMS == 2 - allocate(rbuf(nblocks,nv,ng,ng,km)) + allocate(sbuf(scount,nv,ng,ng,km)) + allocate(rbuf(rcount,nv,ng,ng,km)) #endif /* NDIMS == 2 */ #if NDIMS == 3 - allocate(rbuf(nblocks,nv,ng,ng,ng)) + allocate(sbuf(scount,nv,ng,ng,ng)) + allocate(rbuf(rcount,nv,ng,ng,ng)) #endif /* NDIMS == 3 */ -! if isend == nproc we are sending data from the neighbor block -! - if (isend == nproc) then - +!! PREPARE BLOCKS FOR SENDING +!! ! reset the block counter ! l = 0 ! associate the pointer with the first block in the exchange list ! - pinfo => block_array(isend,irecv)%ptr + pinfo => barray(sproc,rproc)%ptr ! scan over all blocks on the block exchange list ! @@ -5454,13 +4939,13 @@ module boundaries ! #if NDIMS == 2 call block_corner_restrict(i, j, k & - , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & - , rbuf(l,1:nv,1:ng,1:ng,1:km)) + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , sbuf(l,1:nv,1:ng,1:ng,1:km)) #endif /* NDIMS == 2 */ #if NDIMS == 3 call block_corner_restrict(i, j, k & - , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & - , rbuf(l,1:nv,1:ng,1:ng,1:ng)) + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , sbuf(l,1:nv,1:ng,1:ng,1:ng)) #endif /* NDIMS == 3 */ ! associate the pointer with the next block @@ -5469,28 +4954,22 @@ module boundaries end do ! %ptr block list -! send the data buffer to another process +!! SEND PREPARED BLOCKS AND RECEIVCE NEW ONES +!! +! exchange data ! - call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) - - end if ! isend = nproc - -! if irecv == nproc we are receiving data from the neighbor block -! - if (irecv == nproc) then - -! receive the data buffer -! - call receive_real_array(size(rbuf(:,:,:,:,:)), isend, itag & - , rbuf(:,:,:,:,:), iret) + call exchange_real_arrays(rproc, stag, size(sbuf), sbuf & + , rproc, rtag, size(rbuf), rbuf, iret) +!! PROCESS RECEIVED BLOCKS +!! ! reset the block counter ! l = 0 ! associate the pointer with the first block in the exchange list ! - pinfo => block_array(isend,irecv)%ptr + pinfo => barray(rproc,sproc)%ptr ! iterate over all received blocks and update boundaries of the corresponding ! data blocks @@ -5554,44 +5033,19 @@ module boundaries end do ! %ptr block list - end if ! irecv = nproc - ! deallocate data buffer ! - if (allocated(rbuf)) deallocate(rbuf) + deallocate(sbuf, rbuf) -! associate the pointer with the first block in the exchange list -! - pinfo => block_array(isend,irecv)%ptr + end if ! (scount + rcount) > 0 -! scan over all blocks on the exchange block list -! - do while(associated(pinfo)) - -! associate the exchange list pointer -! - block_array(isend,irecv)%ptr => pinfo%prev - -! nullify the pointer fields -! - nullify(pinfo%prev) - nullify(pinfo%next) - nullify(pinfo%block) - nullify(pinfo%neigh) - -! deallocate the object -! - deallocate(pinfo) - -! associate the pointer with the next block -! - pinfo => block_array(isend,irecv)%ptr - - end do ! %ptr block list - - end if ! if block_count > 0 + end if ! pairs(p,1) == nproc || pairs(p,2) == nproc end do ! p = 1, npairs + +! release the memory used by the array of exchange block lists +! + call release_exchange_array() #endif /* MPI */ #ifdef PROFILE @@ -5629,10 +5083,9 @@ module boundaries use coordinates , only : ibl, jbl, kbl use coordinates , only : ieu, jeu, keu use equations , only : nv - use mpitools , only : nproc, nprocs, npmax #ifdef MPI - use mpitools , only : npairs, pairs - use mpitools , only : send_real_array, receive_real_array + use mpitools , only : nproc, nprocs, npairs, pairs + use mpitools , only : exchange_real_arrays #endif /* MPI */ ! local variables are not implicit by default @@ -5651,19 +5104,14 @@ module boundaries integer :: i , j , k integer :: il, jl, kl integer :: iu, ju, ku - integer :: iret #ifdef MPI - integer :: isend, irecv, nblocks, itag - integer :: l, p - -! local pointer arrays -! - type(pointer_info), dimension(0:npmax,0:npmax) :: block_array + integer :: sproc, scount, stag + integer :: rproc, rcount, rtag + integer :: l, p, iret ! local arrays ! - integer , dimension(0:npmax,0:npmax) :: block_counter - real(kind=8), dimension(:,:,:,:,:) , allocatable :: rbuf + real(kind=8), dimension(:,:,:,:,:), allocatable :: sbuf, rbuf #endif /* MPI */ ! !------------------------------------------------------------------------------- @@ -5677,17 +5125,9 @@ module boundaries #ifdef MPI !! 1. PREPARE THE BLOCK EXCHANGE ARRAYS FOR MPI !! -! reset the exchange block counters +! prepare the array of exchange block lists and its counters ! - block_counter(:,:) = 0 - -! nullify the info pointers -! - do irecv = 0, npmax - do isend = 0, npmax - nullify(block_array(isend,irecv)%ptr) - end do - end do + call prepare_exchange_array() #endif /* MPI */ !! 2. UPDATE VARIABLE CORNER BOUNDARIES BETWEEN BLOCKS BELONGING TO THE SAME @@ -5790,40 +5230,9 @@ module boundaries else ! block and neighbor on different processors -! increase the counter for number of blocks to exchange +! append the block to the exchange list ! - block_counter(pneigh%process,pmeta%process) = & - block_counter(pneigh%process,pmeta%process) + 1 - -! allocate a new info object -! - allocate(pinfo) - -! fill out only fields which are used -! - pinfo%block => pmeta - pinfo%neigh => pneigh - pinfo%corner(1) = i - pinfo%corner(2) = j -#if NDIMS == 3 - pinfo%corner(3) = k -#endif /* NDIMS == 3 */ - -! nullify pointer fields of the object -! - nullify(pinfo%prev) - nullify(pinfo%next) - -! if the list is not empty append the newly created block to it -! - if (associated(block_array(pneigh%process & - ,pmeta%process)%ptr)) & - pinfo%prev => block_array(pneigh%process & - ,pmeta%process)%ptr - -! point the list to the newly created block -! - block_array(pneigh%process,pmeta%process)%ptr => pinfo + call append_exchange_block(pmeta, pneigh, -1, i, j, k) end if ! block and neighbor on different processors #endif /* MPI */ @@ -5854,43 +5263,55 @@ module boundaries ! do p = 1, npairs -! get sending and receiving process identifiers +! process only pairs related to this process ! - isend = pairs(p,1) - irecv = pairs(p,2) + if (pairs(p,1) == nproc .or. pairs(p,2) == nproc) then -! process only pairs which have something to exchange +! get sending and receiving process identifiers (depending on pair member) ! - if (block_counter(isend,irecv) > 0) then + if (pairs(p,1) == nproc) then + sproc = pairs(p,1) + rproc = pairs(p,2) + end if + if (pairs(p,2) == nproc) then + sproc = pairs(p,2) + rproc = pairs(p,1) + end if -! obtain the number of blocks to exchange +! get the number of blocks to exchange ! - nblocks = block_counter(isend,irecv) + scount = bcount(sproc,rproc) + rcount = bcount(rproc,sproc) + +! process only pairs which have anything to exchange +! + if ((scount + rcount) > 0) then ! prepare the tag for communication ! - itag = 16 * (irecv * nprocs + isend) + 10 + stag = 16 * (rproc * nprocs + sproc) + 10 + rtag = 16 * (sproc * nprocs + rproc) + 10 -! allocate data buffer for variables to exchange +! allocate buffers for variable exchange ! #if NDIMS == 2 - allocate(rbuf(nblocks,nv,ng,ng,km)) + allocate(sbuf(scount,nv,ng,ng,km)) + allocate(rbuf(rcount,nv,ng,ng,km)) #endif /* NDIMS == 2 */ #if NDIMS == 3 - allocate(rbuf(nblocks,nv,ng,ng,ng)) + allocate(sbuf(scount,nv,ng,ng,ng)) + allocate(rbuf(rcount,nv,ng,ng,ng)) #endif /* NDIMS == 3 */ -! if isend == nproc we are sending data from the neighbor block -! - if (isend == nproc) then - +!! PREPARE BLOCKS FOR SENDING +!! ! reset the block counter ! l = 0 ! associate the pointer with the first block in the exchange list ! - pinfo => block_array(isend,irecv)%ptr + pinfo => barray(sproc,rproc)%ptr ! scan over all blocks on the block exchange list ! @@ -5912,18 +5333,18 @@ module boundaries k = pinfo%corner(3) #endif /* NDIMS == 3 */ -! restrict and extract the corresponding corner region from the neighbor and -! insert it to the buffer +! prolong the corresponding corner region from the neighbor and insert it in +! the buffer ! #if NDIMS == 2 call block_corner_prolong(i, j, k & , pneigh%data%q(1:nv,1:im,1:jm,1:km) & - , rbuf(l,1:nv,1:ng,1:ng,1:km)) + , sbuf(l,1:nv,1:ng,1:ng,1:km)) #endif /* NDIMS == 2 */ #if NDIMS == 3 call block_corner_prolong(i, j, k & , pneigh%data%q(1:nv,1:im,1:jm,1:km) & - , rbuf(l,1:nv,1:ng,1:ng,1:ng)) + , sbuf(l,1:nv,1:ng,1:ng,1:ng)) #endif /* NDIMS == 3 */ ! associate the pointer with the next block @@ -5932,28 +5353,22 @@ module boundaries end do ! %ptr block list -! send the data buffer to another process +!! SEND PREPARED BLOCKS AND RECEIVCE NEW ONES +!! +! exchange data ! - call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) - - end if ! isend = nproc - -! if irecv == nproc we are receiving data from the neighbor block -! - if (irecv == nproc) then - -! receive the data buffer -! - call receive_real_array(size(rbuf(:,:,:,:,:)), isend, itag & - , rbuf(:,:,:,:,:), iret) + call exchange_real_arrays(rproc, stag, size(sbuf), sbuf & + , rproc, rtag, size(rbuf), rbuf, iret) +!! PROCESS RECEIVED BLOCKS +!! ! reset the block counter ! l = 0 ! associate the pointer with the first block in the exchange list ! - pinfo => block_array(isend,irecv)%ptr + pinfo => barray(rproc,sproc)%ptr ! iterate over all received blocks and update boundaries of the corresponding ! data blocks @@ -6017,44 +5432,19 @@ module boundaries end do ! %ptr block list - end if ! irecv = nproc - ! deallocate data buffer ! - if (allocated(rbuf)) deallocate(rbuf) + deallocate(sbuf, rbuf) -! associate the pointer with the first block in the exchange list -! - pinfo => block_array(isend,irecv)%ptr + end if ! (scount + rcount) > 0 -! scan over all blocks on the exchange block list -! - do while(associated(pinfo)) - -! associate the exchange list pointer -! - block_array(isend,irecv)%ptr => pinfo%prev - -! nullify the pointer fields -! - nullify(pinfo%prev) - nullify(pinfo%next) - nullify(pinfo%block) - nullify(pinfo%neigh) - -! deallocate the object -! - deallocate(pinfo) - -! associate the pointer with the next block -! - pinfo => block_array(isend,irecv)%ptr - - end do ! %ptr block list - - end if ! if block_count > 0 + end if ! pairs(p,1) == nproc || pairs(p,2) == nproc end do ! p = 1, npairs + +! release the memory used by the array of exchange block lists +! + call release_exchange_array() #endif /* MPI */ #ifdef PROFILE @@ -8461,6 +7851,12 @@ module boundaries ! !------------------------------------------------------------------------------- ! +#ifdef PROFILE +! start accounting time subroutine +! + call start_timer(imu) +#endif /* PROFILE */ + ! assign the pointer to the first block on the list ! pdata => list_data @@ -8525,9 +7921,225 @@ module boundaries end do ! data blocks +#ifdef PROFILE +! stop accounting time subroutine +! + call stop_timer(imu) +#endif /* PROFILE */ + !------------------------------------------------------------------------------- ! end subroutine update_ghost_cells +#ifdef MPI +! +!=============================================================================== +! +! subroutine PREPARE_EXCHANGE_ARRAY: +! --------------------------------- +! +! Subroutine prepares the arrays for block exchange lists and their counters. +! +! +!=============================================================================== +! + subroutine prepare_exchange_array() + +! include external variables +! + use mpitools , only : npmax + +! local variables are not implicit by default +! + implicit none + +! local variables +! + integer :: icol, irow +! +!------------------------------------------------------------------------------- +! +! iterate over all elements of the block exchange array +! + do irow = 0, npmax + do icol = 0, npmax + +! nullify the array element pointer +! + nullify(barray(irow,icol)%ptr) + +! reset the corresponding counter +! + bcount(irow,icol) = 0 + + end do ! icol = 0, npmax + end do ! irow = 0, npmax + +!------------------------------------------------------------------------------- +! + end subroutine prepare_exchange_array +! +!=============================================================================== +! +! subroutine RELEASE_EXCHANGE_ARRAY: +! --------------------------------- +! +! Subroutine releases objects on the array of block exchange lists. +! +! +!=============================================================================== +! + subroutine release_exchange_array() + +! include external variables +! + use blocks , only : block_info, pointer_info + use mpitools , only : npmax + +! local variables are not implicit by default +! + implicit none + +! local variables +! + integer :: icol, irow + +! local pointers +! + type(block_info), pointer :: pinfo +! +!------------------------------------------------------------------------------- +! +! iterate over all elements of the block exchange array +! + do irow = 0, npmax + do icol = 0, npmax + +! associate pinfo with the first block in the exchange list +! + pinfo => barray(irow,icol)%ptr + +! scan all elements on the exchange list +! + do while(associated(pinfo)) + +! associate the exchange list pointer +! + barray(irow,icol)%ptr => pinfo%prev + +! nullify pointer fields +! + nullify(pinfo%prev) + nullify(pinfo%next) + nullify(pinfo%block) + nullify(pinfo%neigh) + +! deallocate info block +! + deallocate(pinfo) + +! associate pinfo with the next block +! + pinfo => barray(irow,icol)%ptr + + end do ! %ptr blocks + + end do ! icol = 0, npmax + end do ! irow = 0, npmax + +!------------------------------------------------------------------------------- +! + end subroutine release_exchange_array +! +!=============================================================================== +! +! subroutine APPEND_EXCHANGE_BLOCK: +! --------------------------------- +! +! Subroutine appends an info block to the element of array of block +! exchange lists. The element is determined by the processes of the meta +! and neighbor blocks. +! +! Arguments: +! +! pmeta - the pointer to meta block; +! pneigh - the pointer to the neighbor of pmeta; +! n, i, j, k - the location of the neighbor; +! +!=============================================================================== +! + subroutine append_exchange_block(pmeta, pneigh, n, i, j, k) + +! include external variables +! + use blocks , only : block_info, block_meta + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + type(block_meta), pointer, intent(inout) :: pmeta, pneigh + integer , intent(in) :: n, i, j, k + +! local variables +! + integer :: icol, irow + +! local pointers +! + type(block_info), pointer :: pinfo +! +!------------------------------------------------------------------------------- +! +! get the column and row indices +! + irow = pneigh%process + icol = pmeta%process + +! increase the counter for the number of blocks to exchange +! + bcount(irow,icol) = bcount(irow,icol) + 1 + +! allocate a new info object +! + allocate(pinfo) + +! fill out its fields +! + pinfo%block => pmeta + pinfo%neigh => pneigh + pinfo%direction = n + pinfo%corner(1) = i + pinfo%corner(2) = j +#if NDIMS == 3 + pinfo%corner(3) = k +#endif /* NDIMS == 3 */ + pinfo%level_difference = pmeta%level - pneigh%level + +! nullify pointer fields +! + nullify(pinfo%prev) + nullify(pinfo%next) + +! check if the list is empty +! + if (associated(barray(irow,icol)%ptr)) then + +! if it is, associate the newly created block with it +! + pinfo%prev => barray(irow,icol)%ptr + + end if ! %ptr associated + +! point the list to the newly created block +! + barray(irow,icol)%ptr => pinfo + +!------------------------------------------------------------------------------- +! + end subroutine append_exchange_block +#endif /* MPI */ !=============================================================================== ! diff --git a/src/io.F90 b/src/io.F90 index 7ccdeed..0ce757e 100644 --- a/src/io.F90 +++ b/src/io.F90 @@ -525,7 +525,7 @@ module io #ifdef MPI use mesh , only : redistribute_blocks #endif /* MPI */ - use mpitools , only : nprocs, nproc + use mpitools , only : nprocs, npmax, nproc ! local variables are not implicit by default ! @@ -719,11 +719,11 @@ module io ! switch meta blocks from the read file to belong to the reading process ! - call change_blocks_process(lfile, nprocs - 1) + call change_blocks_process(lfile, npmax) ! read the remaining files by the last process only ! - if (nproc == nprocs - 1) then + if (nproc == npmax) then ! prepare the filename ! @@ -794,7 +794,7 @@ module io return end if - end if ! nproc == nprocs - 1 + end if ! nproc == npmax #ifdef MPI ! redistribute blocks between processors @@ -1775,7 +1775,7 @@ module io ! local variables ! integer(hid_t) :: gid - integer(kind=4) :: i, j, k, l, p, n, ip, lcpu + integer(kind=4) :: i, j, k, l, p, n, ip integer :: err integer(hsize_t), dimension(1) :: am integer(hsize_t), dimension(2) :: dm, pm @@ -1813,10 +1813,6 @@ module io ! !------------------------------------------------------------------------------- ! -! prepare last cpu index -! - lcpu = nprocs - 1 - ! open metablock group ! call h5gopen_f(fid, 'metablocks', gid, err) diff --git a/src/makefile b/src/makefile index 5589261..4a16d3a 100644 --- a/src/makefile +++ b/src/makefile @@ -147,7 +147,7 @@ io.o : io.F90 blocks.o coordinates.o equations.o error.o \ mesh.o : mesh.F90 blocks.o coordinates.o domains.o equations.o \ error.o interpolations.o mpitools.o problems.o refinement.o \ timers.o -mpitools.o : mpitools.F90 timers.o +mpitools.o : mpitools.F90 error.o timers.o operators.o : operators.F90 timers.o parameters.o : parameters.F90 mpitools.o problems.o : problems.F90 blocks.o constants.o coordinates.o equations.o \ diff --git a/src/mesh.F90 b/src/mesh.F90 index 8ba8cb6..0e8bd09 100644 --- a/src/mesh.F90 +++ b/src/mesh.F90 @@ -468,7 +468,7 @@ module mesh use coordinates , only : minlev, maxlev use domains , only : setup_domain use error , only : print_error - use mpitools , only : master, nproc, nprocs + use mpitools , only : master, nproc, nprocs, npmax use problems , only : setup_problem use refinement , only : check_refinement_criterion @@ -483,9 +483,9 @@ module mesh ! local variables ! - integer(kind=4) :: level, lev, idir, iside, iface - integer(kind=4) :: np, nl - integer(kind=4), dimension(0:nprocs-1) :: lb + integer(kind=4) :: level, lev, idir, iside, iface + integer(kind=4) :: np, nl + integer(kind=4), dimension(0:npmax) :: lb !------------------------------------------------------------------------------- ! @@ -726,7 +726,7 @@ module mesh ! increase the process number ! - np = min(nprocs - 1, np + 1) + np = min(npmax, np + 1) end if ! nl >= lb(np) @@ -849,7 +849,7 @@ module mesh use blocks , only : append_datablock, remove_datablock, link_blocks use coordinates , only : im, jm, km use equations , only : nv - use mpitools , only : nprocs, nproc + use mpitools , only : nprocs, npmax, nproc use mpitools , only : send_real_array, receive_real_array #endif /* MPI */ @@ -874,7 +874,7 @@ module mesh ! array for number of data block for autobalancing ! - integer(kind=4), dimension(0:nprocs-1) :: lb + integer(kind=4), dimension(0:npmax) :: lb ! local buffer for data block exchange ! @@ -996,7 +996,7 @@ module mesh ! increase the process number ! - np = min(nprocs - 1, np + 1) + np = min(npmax, np + 1) end if ! l >= lb(n) diff --git a/src/mpitools.F90 b/src/mpitools.F90 index 85f286b..027efc8 100644 --- a/src/mpitools.F90 +++ b/src/mpitools.F90 @@ -43,7 +43,7 @@ module mpitools ! integer , save :: imi, imc #ifdef PROFILE - integer , save :: imb, imm, ims, imr + integer , save :: imb, imm, ims, imr, ime #endif /* PROFILE */ ! MPI global variables @@ -115,6 +115,7 @@ module mpitools call set_timer('mpitools:: reduce' , imm) call set_timer('mpitools:: send' , ims) call set_timer('mpitools:: receive' , imr) + call set_timer('mpitools:: exchange' , ime) #endif /* PROFILE */ ! start time accounting for the MPI initialization @@ -178,17 +179,17 @@ module mpitools ! npmax = nprocs - 1 -! roung up the number of processors to even number +! round up the number of processors to even number ! mprocs = nprocs + mod(nprocs, 2) ! calculate the number of processor pairs for data exchange ! - npairs = nprocs * npmax + npairs = nprocs * npmax / 2 ! allocate space for all processor pairs ! - allocate(pairs(npairs, 2)) + allocate(pairs(2 * npairs, 2)) ! allocate space for the processor order ! @@ -238,7 +239,7 @@ module mpitools ! fill out the remaining pairs (swapped) ! - pairs(npairs/2+1:npairs,1:2) = pairs(1:npairs/2,2:1:-1) + pairs(npairs+1:2*npairs,1:2) = pairs(1:npairs,2:1:-1) ! allocate space for the processor order ! @@ -1545,6 +1546,90 @@ module mpitools end subroutine receive_real_array ! !=============================================================================== +! +! subroutine EXCHANGE_REAL_ARRAYS: +! ------------------------------- +! +! Subroutine exchanges real data buffers between two processes. +! +! Arguments: +! +! sproc - the process number to which send the buffer sbuf; +! stag - the tag identifying the send operation; +! ssize - the size of the send buffer sbuf; +! sbuf - the real array buffer to send; +! rproc - the process number from which receive the buffer rbuf; +! rtag - the tag identifying the receive operation; +! rsize - the size of the receive buffer rbuf; +! rbuf - the real array buffer to receive; +! iret - the result flag identifying if the operation was successful; +! +!=============================================================================== +! + subroutine exchange_real_arrays(sproc, stag, ssize, sbuffer & + , rproc, rtag, rsize, rbuffer, iret) + +! include external procedures and variables +! + use error, only : print_error + use mpi , only : mpi_real8, mpi_success, mpi_status_size + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer , intent(in) :: sproc, rproc + integer , intent(in) :: stag , rtag + integer , intent(in) :: ssize, rsize + real(kind=8), dimension(ssize), intent(in) :: sbuffer + real(kind=8), dimension(rsize), intent(in) :: rbuffer + integer , intent(out) :: iret + +! local variables +! + integer :: status(mpi_status_size) +! +!------------------------------------------------------------------------------- +! +! start time accounting for the MPI communication +! + call start_timer(imc) + +#ifdef PROFILE +! start time accounting for the MPI buffer exchange +! + call start_timer(ime) +#endif /* PROFILE */ + +! send sbuf and receive rbuf +! + call mpi_sendrecv(sbuffer(:), ssize, mpi_real8, sproc, stag & + , rbuffer(:), rsize, mpi_real8, rproc, rtag & + , comm3d, status, iret) + +#ifdef PROFILE +! stop time accounting for the MPI buffer exchange +! + call stop_timer(ime) +#endif /* PROFILE */ + +! check if the operation was successful +! + if (iret /= mpi_success) & + call print_error("mpitools::exchange_real_arrays" & + , "Could not exchange real data buffers!") + +! stop time accounting for the MPI communication +! + call stop_timer(imc) + +!------------------------------------------------------------------------------- +! + end subroutine exchange_real_arrays +! +!=============================================================================== !! !!*** PRIVATE SUBROUTINES **************************************************** !!