! -*-f90-*-
!***********************************************************************
!* GNU Lesser General Public License
!*
!* This file is part of the GFDL Flexible Modeling System (FMS).
!*
!* FMS is free software: you can redistribute it and/or modify it under
!* the terms of the GNU Lesser General Public License as published by
!* the Free Software Foundation, either version 3 of the License, or (at
!* your option) any later version.
!*
!* FMS is distributed in the hope that it will be useful, but WITHOUT
!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
!* for more details.
!*
!* You should have received a copy of the GNU Lesser General Public
!* License along with FMS. If not, see <http://www.gnu.org/licenses/>.
!***********************************************************************
subroutine MPP_DO_UPDATE_3D_( f_addrs, domain, update, d_type, ke, flags)
!updates data domain of 3D field whose computational domains have been computed
integer(LONG_KIND), intent(in) :: f_addrs(:,:)
type(domain2D), intent(in) :: domain
type(overlapSpec), intent(in) :: update
MPP_TYPE_, intent(in) :: d_type ! creates unique interface
integer, intent(in) :: ke
integer, optional, intent(in) :: flags
MPP_TYPE_ :: field(update%xbegin:update%xend, update%ybegin:update%yend,ke)
pointer(ptr_field, field)
integer :: update_flags
type(overlap_type), pointer :: overPtr => NULL()
character(len=8) :: text
!equate to mpp_domains_stack
MPP_TYPE_ :: buffer(size(mpp_domains_stack(:)))
pointer( ptr, buffer )
integer :: buffer_pos
!receive domains saved here for unpacking
!for non-blocking version, could be recomputed
integer, allocatable :: msg1(:), msg2(:), msg3(:)
logical :: send(8), recv(8), update_edge_only
integer :: to_pe, from_pe, pos, msgsize
integer :: n, l_size, l, m, i, j, k
integer :: is, ie, js, je, tMe, dir
integer :: start, start1, start2, index, is1, ie1, js1, je1, ni, nj, total
integer :: buffer_recv_size, nlist, outunit
integer :: send_start_pos
integer :: send_msgsize(MAXLIST)
outunit = stdout()
ptr = LOC(mpp_domains_stack)
l_size = size(f_addrs,1)
update_flags = XUPDATE+YUPDATE !default
if( PRESENT(flags) )update_flags = flags
update_edge_only = BTEST(update_flags, EDGEONLY)
recv = .false.
recv(1) = BTEST(update_flags,EAST)
recv(3) = BTEST(update_flags,SOUTH)
recv(5) = BTEST(update_flags,WEST)
recv(7) = BTEST(update_flags,NORTH)
if( update_edge_only ) then
if( .NOT. (recv(1) .OR. recv(3) .OR. recv(5) .OR. recv(7)) ) then
recv(1) = .true.
recv(3) = .true.
recv(5) = .true.
recv(7) = .true.
endif
else
recv(2) = recv(1) .AND. recv(3)
recv(4) = recv(3) .AND. recv(5)
recv(6) = recv(5) .AND. recv(7)
recv(8) = recv(7) .AND. recv(1)
endif
send = recv
if(debug_message_passing) then
nlist = size(domain%list(:))
allocate(msg1(0:nlist-1), msg2(0:nlist-1), msg3(0:nlist-1) )
msg1 = 0
msg2 = 0
msg3 = 0
do m = 1, update%nrecv
overPtr => update%recv(m)
msgsize = 0
do n = 1, overPtr%count
dir = overPtr%dir(n)
if(recv(dir)) then
is = overPtr%is(n); ie = overPtr%ie(n)
js = overPtr%js(n); je = overPtr%je(n)
msgsize = msgsize + (ie-is+1)*(je-js+1)
end if
end do
from_pe = update%recv(m)%pe
l = from_pe-mpp_root_pe()
msg2(l) = msgsize
enddo
do m = 1, update%nsend
overPtr => update%send(m)
msgsize = 0
do n = 1, overPtr%count
dir = overPtr%dir(n)
if(send(dir)) then
is = overPtr%is(n); ie = overPtr%ie(n)
js = overPtr%js(n); je = overPtr%je(n)
msgsize = msgsize + (ie-is+1)*(je-js+1)
end if
end do
l = overPtr%pe - mpp_root_pe()
msg3(l) = msgsize
enddo
call mpp_alltoall(msg3, 1, msg1, 1)
do m = 0, nlist-1
if(msg1(m) .NE. msg2(m)) then
print*, "My pe = ", mpp_pe(), ",domain name =", trim(domain%name), ",from pe=", &
domain%list(m)%pe, ":send size = ", msg1(m), ", recv size = ", msg2(m)
call mpp_error(FATAL, "mpp_do_update: mismatch on send and recv size")
endif
enddo
write(outunit,*)"NOTE from mpp_do_update: message sizes are matched between send and recv for domain " &
//trim(domain%name)
deallocate(msg1, msg2, msg3)
endif
!recv
buffer_pos = 0
call mpp_clock_begin(recv_clock)
do m = 1, update%nrecv
overPtr => update%recv(m)
if( overPtr%count == 0 )cycle
msgsize = 0
do n = 1, overPtr%count
dir = overPtr%dir(n)
if(recv(dir)) then
is = overPtr%is(n); ie = overPtr%ie(n)
js = overPtr%js(n); je = overPtr%je(n)
msgsize = msgsize + (ie-is+1)*(je-js+1)
end if
end do
msgsize = msgsize*ke*l_size
if( msgsize.GT.0 )then
from_pe = overPtr%pe
mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, (buffer_pos+msgsize) )
if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then
write( text,'(i8)' )mpp_domains_stack_hwm
call mpp_error( FATAL, 'MPP_DO_UPDATE: mpp_domains_stack overflow, '// &
'call mpp_domains_set_stack_size('//trim(text)//') from all PEs.' )
end if
call mpp_recv( buffer(buffer_pos+1), glen=msgsize, from_pe=from_pe, block=.FALSE., tag=COMM_TAG_2 )
buffer_pos = buffer_pos + msgsize
end if
end do ! end do m = 1, update%nrecv
call mpp_clock_end(recv_clock)
buffer_recv_size = buffer_pos
send_start_pos = buffer_pos
! pack
call mpp_clock_begin(pack_clock)
do m = 1, update%nsend
send_msgsize(m) = 0
overPtr => update%send(m)
if( overPtr%count == 0 )cycle
pos = buffer_pos
msgsize = 0
do n = 1, overPtr%count
dir = overPtr%dir(n)
if( send(dir) ) msgsize = msgsize + overPtr%msgsize(n)
enddo
if( msgsize.GT.0 )then
msgsize = msgsize*ke*l_size
mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, pos+msgsize )
if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then
write( text,'(i8)' )mpp_domains_stack_hwm
call mpp_error( FATAL, 'MPP_START_UPDATE_DOMAINS: mpp_domains_stack overflow, ' // &
'call mpp_domains_set_stack_size('//trim(text)//') from all PEs.')
end if
end if
do n = 1, overPtr%count
dir = overPtr%dir(n)
if( send(dir) ) then
tMe = overPtr%tileMe(n)
is = overPtr%is(n); ie = overPtr%ie(n)
js = overPtr%js(n); je = overPtr%je(n)
select case( overPtr%rotation(n) )
case(ZERO)
do l=1,l_size ! loop over number of fields
ptr_field = f_addrs(l, tMe)
do k = 1,ke
do j = js, je
do i = is, ie
pos = pos + 1
buffer(pos) = field(i,j,k)
end do
end do
end do
end do
case( MINUS_NINETY )
do l=1,l_size ! loop over number of fields
ptr_field = f_addrs(l, tMe)
do k = 1,ke
do i = is, ie
do j = je, js, -1
pos = pos + 1
buffer(pos) = field(i,j,k)
end do
end do
end do
end do
case( NINETY )
do l=1,l_size ! loop over number of fields
ptr_field = f_addrs(l, tMe)
do k = 1,ke
do i = ie, is, -1
do j = js, je
pos = pos + 1
buffer(pos) = field(i,j,k)
end do
end do
end do
end do
case( ONE_HUNDRED_EIGHTY )
do l=1,l_size ! loop over number of fields
ptr_field = f_addrs(l, tMe)
do k = 1,ke
do j = je, js, -1
do i = ie, is, -1
pos = pos + 1
buffer(pos) = field(i,j,k)
end do
end do
end do
end do
end select
endif
end do ! do n = 1, overPtr%count
send_msgsize(m) = pos-buffer_pos
buffer_pos = pos
end do ! end do m = 1, nsend
call mpp_clock_end(pack_clock)
buffer_pos = send_start_pos
call mpp_clock_begin(send_clock)
do m = 1, update%nsend
msgsize = send_msgsize(m)
if(msgsize == 0) cycle
to_pe = update%send(m)%pe
call mpp_send( buffer(buffer_pos+1), plen=msgsize, to_pe=to_pe, tag=COMM_TAG_2 )
buffer_pos = buffer_pos + msgsize
end do ! end do ist = 0,nlist-1
call mpp_clock_end(send_clock)
!unpack recv
!unpack halos in reverse order
! ptr_rfield = f_addrs(1)
call mpp_clock_begin(wait_clock)
call mpp_sync_self(check=EVENT_RECV)
call mpp_clock_end(wait_clock)
buffer_pos = buffer_recv_size
call mpp_clock_begin(unpk_clock)
do m = update%nrecv, 1, -1
overPtr => update%recv(m)
if( overPtr%count == 0 )cycle
pos = buffer_pos
do n = overPtr%count, 1, -1
dir = overPtr%dir(n)
if( recv(dir) ) then
tMe = overPtr%tileMe(n)
is = overPtr%is(n); ie = overPtr%ie(n)
js = overPtr%js(n); je = overPtr%je(n)
msgsize = (ie-is+1)*(je-js+1)*ke*l_size
pos = buffer_pos - msgsize
buffer_pos = pos
do l=1,l_size ! loop over number of fields
ptr_field = f_addrs(l, tMe)
do k = 1,ke
do j = js, je
do i = is, ie
pos = pos + 1
field(i,j,k) = buffer(pos)
end do
end do
end do
end do
endif
end do ! do n = 1, overPtr%count
end do
call mpp_clock_end(unpk_clock)
call mpp_clock_begin(wait_clock)
call mpp_sync_self( )
call mpp_clock_end(wait_clock)
return
end subroutine MPP_DO_UPDATE_3D_