| c--------------------------------------------------------------------- |
| c--------------------------------------------------------------------- |
| |
| subroutine copy_faces |
| |
| c--------------------------------------------------------------------- |
| c--------------------------------------------------------------------- |
| |
| c--------------------------------------------------------------------- |
| c |
| c This function copies the face values of a variable defined on a set |
| c of cells to the overlap locations of the adjacent sets of cells. |
| c Because a set of cells interfaces in each direction with exactly one |
| c other set, we only need to fill six different buffers. We could try to |
| c overlap communication with computation, by computing |
| c some internal values while communicating boundary values, but this |
| c adds so much overhead that it's not clearly useful. |
| c--------------------------------------------------------------------- |
| |
| include 'header.h' |
| include 'mpinpb.h' |
| |
| integer i, j, k, c, m, requests(0:11), p0, p1, |
| > p2, p3, p4, p5, b_size(0:5), ss(0:5), |
| > sr(0:5), error, statuses(MPI_STATUS_SIZE, 0:11) |
| |
| c--------------------------------------------------------------------- |
| c exit immediately if there are no faces to be copied |
| c--------------------------------------------------------------------- |
| if (no_nodes .eq. 1) then |
| call compute_rhs |
| return |
| endif |
| |
| ss(0) = start_send_east |
| ss(1) = start_send_west |
| ss(2) = start_send_north |
| ss(3) = start_send_south |
| ss(4) = start_send_top |
| ss(5) = start_send_bottom |
| |
| sr(0) = start_recv_east |
| sr(1) = start_recv_west |
| sr(2) = start_recv_north |
| sr(3) = start_recv_south |
| sr(4) = start_recv_top |
| sr(5) = start_recv_bottom |
| |
| b_size(0) = east_size |
| b_size(1) = west_size |
| b_size(2) = north_size |
| b_size(3) = south_size |
| b_size(4) = top_size |
| b_size(5) = bottom_size |
| |
| c--------------------------------------------------------------------- |
| c because the difference stencil for the diagonalized scheme is |
| c orthogonal, we do not have to perform the staged copying of faces, |
| c but can send all face information simultaneously to the neighboring |
| c cells in all directions |
| c--------------------------------------------------------------------- |
| if (timeron) call timer_start(t_bpack) |
| p0 = 0 |
| p1 = 0 |
| p2 = 0 |
| p3 = 0 |
| p4 = 0 |
| p5 = 0 |
| |
| do c = 1, ncells |
| |
| c--------------------------------------------------------------------- |
| c fill the buffer to be sent to eastern neighbors (i-dir) |
| c--------------------------------------------------------------------- |
| if (cell_coord(1,c) .ne. ncells) then |
| do k = 0, cell_size(3,c)-1 |
| do j = 0, cell_size(2,c)-1 |
| do i = cell_size(1,c)-2, cell_size(1,c)-1 |
| do m = 1, 5 |
| out_buffer(ss(0)+p0) = u(m,i,j,k,c) |
| p0 = p0 + 1 |
| end do |
| end do |
| end do |
| end do |
| endif |
| |
| c--------------------------------------------------------------------- |
| c fill the buffer to be sent to western neighbors |
| c--------------------------------------------------------------------- |
| if (cell_coord(1,c) .ne. 1) then |
| do k = 0, cell_size(3,c)-1 |
| do j = 0, cell_size(2,c)-1 |
| do i = 0, 1 |
| do m = 1, 5 |
| out_buffer(ss(1)+p1) = u(m,i,j,k,c) |
| p1 = p1 + 1 |
| end do |
| end do |
| end do |
| end do |
| |
| endif |
| |
| c--------------------------------------------------------------------- |
| c fill the buffer to be sent to northern neighbors (j_dir) |
| c--------------------------------------------------------------------- |
| if (cell_coord(2,c) .ne. ncells) then |
| do k = 0, cell_size(3,c)-1 |
| do j = cell_size(2,c)-2, cell_size(2,c)-1 |
| do i = 0, cell_size(1,c)-1 |
| do m = 1, 5 |
| out_buffer(ss(2)+p2) = u(m,i,j,k,c) |
| p2 = p2 + 1 |
| end do |
| end do |
| end do |
| end do |
| endif |
| |
| c--------------------------------------------------------------------- |
| c fill the buffer to be sent to southern neighbors |
| c--------------------------------------------------------------------- |
| if (cell_coord(2,c).ne. 1) then |
| do k = 0, cell_size(3,c)-1 |
| do j = 0, 1 |
| do i = 0, cell_size(1,c)-1 |
| do m = 1, 5 |
| out_buffer(ss(3)+p3) = u(m,i,j,k,c) |
| p3 = p3 + 1 |
| end do |
| end do |
| end do |
| end do |
| endif |
| |
| c--------------------------------------------------------------------- |
| c fill the buffer to be sent to top neighbors (k-dir) |
| c--------------------------------------------------------------------- |
| if (cell_coord(3,c) .ne. ncells) then |
| do k = cell_size(3,c)-2, cell_size(3,c)-1 |
| do j = 0, cell_size(2,c)-1 |
| do i = 0, cell_size(1,c)-1 |
| do m = 1, 5 |
| out_buffer(ss(4)+p4) = u(m,i,j,k,c) |
| p4 = p4 + 1 |
| end do |
| end do |
| end do |
| end do |
| endif |
| |
| c--------------------------------------------------------------------- |
| c fill the buffer to be sent to bottom neighbors |
| c--------------------------------------------------------------------- |
| if (cell_coord(3,c).ne. 1) then |
| do k=0, 1 |
| do j = 0, cell_size(2,c)-1 |
| do i = 0, cell_size(1,c)-1 |
| do m = 1, 5 |
| out_buffer(ss(5)+p5) = u(m,i,j,k,c) |
| p5 = p5 + 1 |
| end do |
| end do |
| end do |
| end do |
| endif |
| |
| c--------------------------------------------------------------------- |
| c cell loop |
| c--------------------------------------------------------------------- |
| end do |
| if (timeron) call timer_stop(t_bpack) |
| |
| if (timeron) call timer_start(t_exch) |
| call mpi_irecv(in_buffer(sr(0)), b_size(0), |
| > dp_type, successor(1), WEST, |
| > comm_rhs, requests(0), error) |
| call mpi_irecv(in_buffer(sr(1)), b_size(1), |
| > dp_type, predecessor(1), EAST, |
| > comm_rhs, requests(1), error) |
| call mpi_irecv(in_buffer(sr(2)), b_size(2), |
| > dp_type, successor(2), SOUTH, |
| > comm_rhs, requests(2), error) |
| call mpi_irecv(in_buffer(sr(3)), b_size(3), |
| > dp_type, predecessor(2), NORTH, |
| > comm_rhs, requests(3), error) |
| call mpi_irecv(in_buffer(sr(4)), b_size(4), |
| > dp_type, successor(3), BOTTOM, |
| > comm_rhs, requests(4), error) |
| call mpi_irecv(in_buffer(sr(5)), b_size(5), |
| > dp_type, predecessor(3), TOP, |
| > comm_rhs, requests(5), error) |
| |
| call mpi_isend(out_buffer(ss(0)), b_size(0), |
| > dp_type, successor(1), EAST, |
| > comm_rhs, requests(6), error) |
| call mpi_isend(out_buffer(ss(1)), b_size(1), |
| > dp_type, predecessor(1), WEST, |
| > comm_rhs, requests(7), error) |
| call mpi_isend(out_buffer(ss(2)), b_size(2), |
| > dp_type,successor(2), NORTH, |
| > comm_rhs, requests(8), error) |
| call mpi_isend(out_buffer(ss(3)), b_size(3), |
| > dp_type,predecessor(2), SOUTH, |
| > comm_rhs, requests(9), error) |
| call mpi_isend(out_buffer(ss(4)), b_size(4), |
| > dp_type,successor(3), TOP, |
| > comm_rhs, requests(10), error) |
| call mpi_isend(out_buffer(ss(5)), b_size(5), |
| > dp_type,predecessor(3), BOTTOM, |
| > comm_rhs,requests(11), error) |
| |
| |
| call mpi_waitall(12, requests, statuses, error) |
| if (timeron) call timer_stop(t_exch) |
| |
| c--------------------------------------------------------------------- |
| c unpack the data that has just been received; |
| c--------------------------------------------------------------------- |
| if (timeron) call timer_start(t_bpack) |
| p0 = 0 |
| p1 = 0 |
| p2 = 0 |
| p3 = 0 |
| p4 = 0 |
| p5 = 0 |
| |
| do c = 1, ncells |
| |
| if (cell_coord(1,c) .ne. 1) then |
| do k = 0, cell_size(3,c)-1 |
| do j = 0, cell_size(2,c)-1 |
| do i = -2, -1 |
| do m = 1, 5 |
| u(m,i,j,k,c) = in_buffer(sr(1)+p0) |
| p0 = p0 + 1 |
| end do |
| end do |
| end do |
| end do |
| endif |
| |
| if (cell_coord(1,c) .ne. ncells) then |
| do k = 0, cell_size(3,c)-1 |
| do j = 0, cell_size(2,c)-1 |
| do i = cell_size(1,c), cell_size(1,c)+1 |
| do m = 1, 5 |
| u(m,i,j,k,c) = in_buffer(sr(0)+p1) |
| p1 = p1 + 1 |
| end do |
| end do |
| end do |
| end do |
| end if |
| |
| if (cell_coord(2,c) .ne. 1) then |
| do k = 0, cell_size(3,c)-1 |
| do j = -2, -1 |
| do i = 0, cell_size(1,c)-1 |
| do m = 1, 5 |
| u(m,i,j,k,c) = in_buffer(sr(3)+p2) |
| p2 = p2 + 1 |
| end do |
| end do |
| end do |
| end do |
| |
| endif |
| |
| if (cell_coord(2,c) .ne. ncells) then |
| do k = 0, cell_size(3,c)-1 |
| do j = cell_size(2,c), cell_size(2,c)+1 |
| do i = 0, cell_size(1,c)-1 |
| do m = 1, 5 |
| u(m,i,j,k,c) = in_buffer(sr(2)+p3) |
| p3 = p3 + 1 |
| end do |
| end do |
| end do |
| end do |
| endif |
| |
| if (cell_coord(3,c) .ne. 1) then |
| do k = -2, -1 |
| do j = 0, cell_size(2,c)-1 |
| do i = 0, cell_size(1,c)-1 |
| do m = 1, 5 |
| u(m,i,j,k,c) = in_buffer(sr(5)+p4) |
| p4 = p4 + 1 |
| end do |
| end do |
| end do |
| end do |
| endif |
| |
| if (cell_coord(3,c) .ne. ncells) then |
| do k = cell_size(3,c), cell_size(3,c)+1 |
| do j = 0, cell_size(2,c)-1 |
| do i = 0, cell_size(1,c)-1 |
| do m = 1, 5 |
| u(m,i,j,k,c) = in_buffer(sr(4)+p5) |
| p5 = p5 + 1 |
| end do |
| end do |
| end do |
| end do |
| endif |
| |
| c--------------------------------------------------------------------- |
| c cells loop |
| c--------------------------------------------------------------------- |
| end do |
| if (timeron) call timer_stop(t_bpack) |
| |
| c--------------------------------------------------------------------- |
| c do the rest of the rhs that uses the copied face values |
| c--------------------------------------------------------------------- |
| call compute_rhs |
| |
| return |
| end |
