Changeset 1002

Timestamp:

01/10/20 12:20:52 (4 years ago)

Author:

adurocher

Message:

transfert_mpi : Moved buffer copies in separate subroutines

new routines to transfer data between Halos to Buffers are 'copy_HtoB', 'copy_HtoH', 'copy_BtoH'

File:

• codes/icosagcm/trunk/src/parallel/transfert_mpi.f90 (modified) (7 diffs)

codes/icosagcm/trunk/src/parallel/transfert_mpi.f90

@@ -414 +414 @@
   end subroutine
 
-  subroutine send_message(field, message)
-    use mpi_mod
+  ! Halo to Buffer : copy outbound message to MPI buffers
+  subroutine copy_HtoB(message)
     use domain_mod, only : assigned_domain
     use omp_para, only : distrib_level
-    type(t_field),pointer :: field(:)
-    type(t_message), target :: message
-    integer :: i, k, d3, d4, local_displ
-    integer :: ierr, d3_begin, d3_end, dim4, dim3
-
-    call enter_profile(profile_mpi)
-
-    ! Needed because rval4d is set in init_message
-    if( .not. associated( message%field, field ) ) &
-      call dynamico_abort("send_message must be called with the same field used in init_message")
-
-    !Prepare 'message' for on-device copies if field is on device
-    !$omp master
-    if( field(1)%ondevice .and. .not. message%ondevice ) call message_create_ondevice(message)
-    if( field(1)%ondevice .neqv. message%ondevice ) call dynamico_abort("send_message : internal device/host memory synchronization error")
-    ! Check if previous message has been waited
-    if(message%send_seq /= message%wait_seq) &
-      call dynamico_abort("No matching wait_message before new send_message")
-    message%send_seq = message%send_seq + 1
-    !$omp end master
-
-    call enter_profile(profile_mpi_barrier)
-    !$omp barrier
-    call exit_profile(profile_mpi_barrier)
+    type(t_message), intent(inout) :: message
+    integer :: dim3, dim4, d3_begin, d3_end
+    integer :: k, d3, d4, i
+    integer :: local_displ
 
     dim4 = size(message%field(1)%rval4d, 3)
     dim3 = size(message%field(1)%rval4d, 2)
     CALL distrib_level( 1, dim3, d3_begin, d3_end )
-
-    call enter_profile(profile_mpi_copies)
-    !$acc data present(message) async if(message%ondevice)
-
-    ! Halo to Buffer : copy outbound message to MPI buffers
+    
     !$acc parallel loop default(none) present(message, assigned_domain) async if(message%ondevice)
     do i = 1, size( message%message_out )
@@ -460 +436 @@
             !$acc loop
              do k = 1, message%message_out(i)%npoints
-              !print *, "buff", message%message_out(i)%remote_rank, k+local_displ, "<- field", message%message_out(i)%ind_loc, message%message_out(i)%displs(k), d3, d4, message%field(message%message_out(i)%ind_loc)%rval4d(message%message_out(i)%displs(k),d3, d4)
               message%mpi_buffer_out(message%message_out(i)%remote_rank)%buff(k+local_displ) = message%field(message%message_out(i)%ind_loc)%rval4d(message%message_out(i)%displs(k),d3, d4)
             end do
@@ -467 +442 @@
       endif
     end do
-
-    ! Halo to Halo : copy local messages from source field to destination field
+  end subroutine
+
+  ! Halo to Halo : copy local messages from source field to destination field
+  subroutine copy_HtoH(message)
+    use domain_mod, only : assigned_domain
+    use omp_para, only : distrib_level
+    type(t_message), intent(inout) :: message
+    integer :: dim3, dim4, d3_begin, d3_end
+    integer :: k, d3, d4, i
+
+    dim4 = size(message%field(1)%rval4d, 3)
+    dim3 = size(message%field(1)%rval4d, 2)
+    CALL distrib_level( 1, dim3, d3_begin, d3_end )
+
     !$acc parallel loop default(none) present(message, assigned_domain) async if(message%ondevice)
     do i = 1, size( message%message_local )
@@ -485 +472 @@
       endif
     end do
-
-    !$acc end data
-    call exit_profile(profile_mpi_copies)
-
-
-    call enter_profile(profile_mpi_barrier)
-    !$acc wait
-    !$omp barrier
-    call exit_profile(profile_mpi_barrier)
-
-    !$omp master
-    call MPI_Startall( size(message%mpi_requests_out), message%mpi_requests_out, ierr )
-    call MPI_Startall( size(message%mpi_requests_in), message%mpi_requests_in, ierr )
-    !$omp end master
-
-    call exit_profile(profile_mpi)
-  end subroutine
-
-  subroutine test_message(message)
-    use mpi_mod
-    type(t_message) :: message
-    integer :: ierr
-    logical :: completed
-
-    !$omp master
-    call MPI_Testall( size(message%mpi_requests_out), message%mpi_requests_out, completed, MPI_STATUSES_IGNORE, ierr )
-    call MPI_Testall( size(message%mpi_requests_in), message%mpi_requests_in, completed, MPI_STATUSES_IGNORE, ierr )
-    !$omp end master
-  end subroutine
-
-  subroutine wait_message(message)
-    use mpi_mod
+  end subroutine
+
+  ! Buffer to Halo : copy inbound message to field
+  subroutine copy_BtoH(message)
     use domain_mod, only : assigned_domain
     use omp_para, only : distrib_level
-    type(t_message), target :: message
-    integer :: d3_begin, d3_end, dim4, dim3, dim12
-    integer :: i, ierr, k, d3, d4, local_displ
-
-    ! Check if message has been sent and not recieved yet
-    ! note : barrier needed between this and send_seq increment, and this and wait_seq increment
-    ! note : watch out for integer overflow a = b+1 doesn't imply a>b
-    if(message%send_seq /= message%wait_seq+1) then
-      print*, "WARNING : wait_message called multiple times for one send_message, skipping"
-      return ! Don't recieve message if already recieved
-    end if
-
-    call enter_profile(profile_mpi)
+    type(t_message), intent(inout) :: message
+    integer :: dim3, dim4, d3_begin, d3_end
+    integer :: k, d3, d4, i
+    integer :: local_displ
 
     dim4 = size(message%field(1)%rval4d, 3)
     dim3 = size(message%field(1)%rval4d, 2)
-    dim12 = size(message%field(1)%rval4d, 1)
     CALL distrib_level( 1, dim3, d3_begin, d3_end )
-
-    call enter_profile(profile_mpi_waitall)
-    !$omp master
-    call MPI_Waitall( size(message%mpi_requests_out), message%mpi_requests_out, MPI_STATUSES_IGNORE, ierr )
-    call MPI_Waitall( size(message%mpi_requests_in), message%mpi_requests_in, MPI_STATUSES_IGNORE, ierr )
-    !$omp end master
-    call exit_profile(profile_mpi_waitall)
-
-    call enter_profile(profile_mpi_barrier)
-    !$omp barrier
-    call exit_profile(profile_mpi_barrier)
-
-    call enter_profile(profile_mpi_copies)
-    !$acc data present(message) async if(message%ondevice)
-
-    dim4 = size(message%field(1)%rval4d, 3)
-    ! Buffer to Halo : copy inbound message to field
+    
     !$acc parallel loop default(none) present(message, assigned_domain) async if(message%ondevice)
     do i = 1, size( message%message_in )
@@ -563 +496 @@
             !$acc loop
             do k = 1, message%message_in(i)%npoints 
-              !print *, "field", message%message_in(i)%ind_loc, message%message_in(i)%displs(k), d3, d4, "-> buff", message%message_in(i)%remote_rank, k+local_displ, message%mpi_buffer_in(message%message_in(i)%remote_rank)%buff(k+local_displ)
               message%field(message%message_in(i)%ind_loc)%rval4d(message%message_in(i)%displs(k),d3,d4) &
                   = message%message_in(i)%sign(k)*message%mpi_buffer_in(message%message_in(i)%remote_rank)%buff(k+local_displ)
@@ -571 +503 @@
       endif
     end do
-
-    !$acc end data
+  end subroutine
+
+  subroutine send_message(field, message)
+    use mpi_mod
+    type(t_field),pointer :: field(:)
+    type(t_message), target :: message
+    integer :: ierr
+
+    call enter_profile(profile_mpi)
+
+    ! Needed because rval4d is set in init_message
+    if( .not. associated( message%field, field ) ) &
+      call dynamico_abort("send_message must be called with the same field used in init_message")
+
+    !Prepare 'message' for on-device copies if field is on device
+    !$omp master
+    if( field(1)%ondevice .and. .not. message%ondevice ) call message_create_ondevice(message)
+    if( field(1)%ondevice .neqv. message%ondevice ) call dynamico_abort("send_message : internal device/host memory synchronization error")
+    ! Check if previous message has been waited
+    if(message%send_seq /= message%wait_seq) &
+      call dynamico_abort("No matching wait_message before new send_message")
+    message%send_seq = message%send_seq + 1
+    !$omp end master
+
+    call enter_profile(profile_mpi_barrier)
+    !$omp barrier
+    call exit_profile(profile_mpi_barrier)
+
+    call enter_profile(profile_mpi_copies)
+    call copy_HtoB(message)
+    call copy_HtoH(message)
     call exit_profile(profile_mpi_copies)
 
+    call enter_profile(profile_mpi_barrier)
+    !$acc wait
+    !$omp barrier
+    call exit_profile(profile_mpi_barrier)
+
+    !$omp master
+    call MPI_Startall( size(message%mpi_requests_out), message%mpi_requests_out, ierr )
+    call MPI_Startall( size(message%mpi_requests_in), message%mpi_requests_in, ierr )
+    !$omp end master
+
+    call exit_profile(profile_mpi)
+  end subroutine
+
+  subroutine test_message(message)
+    use mpi_mod
+    type(t_message) :: message
+    integer :: ierr
+    logical :: completed
+
+    !$omp master
+    call MPI_Testall( size(message%mpi_requests_out), message%mpi_requests_out, completed, MPI_STATUSES_IGNORE, ierr )
+    call MPI_Testall( size(message%mpi_requests_in), message%mpi_requests_in, completed, MPI_STATUSES_IGNORE, ierr )
+    !$omp end master
+  end subroutine
+
+  subroutine wait_message(message)
+    use mpi_mod
+    type(t_message), target :: message
+    integer :: ierr
+
+    ! Check if message has been sent and not recieved yet
+    ! note : barrier needed between this and send_seq increment, and this and wait_seq increment
+    ! note : watch out for integer overflow a = b+1 doesn't imply a>b
+    if(message%send_seq /= message%wait_seq+1) then
+      print*, "WARNING : wait_message called multiple times for one send_message, skipping"
+      return ! Don't recieve message if already recieved
+    end if
+
+    call enter_profile(profile_mpi)
+
+    call enter_profile(profile_mpi_waitall)
+    !$omp master
+    call MPI_Waitall( size(message%mpi_requests_out), message%mpi_requests_out, MPI_STATUSES_IGNORE, ierr )
+    call MPI_Waitall( size(message%mpi_requests_in), message%mpi_requests_in, MPI_STATUSES_IGNORE, ierr )
+    !$omp end master
+    call exit_profile(profile_mpi_waitall)
+
+    call enter_profile(profile_mpi_barrier)
+    !$omp barrier
+    call exit_profile(profile_mpi_barrier)
+
+    call enter_profile(profile_mpi_copies) 
+    call copy_BtoH(message)
+    call exit_profile(profile_mpi_copies)
+
     !$omp master
     message%wait_seq = message%wait_seq + 1
@@ -582 +598 @@
     !$omp barrier
     call exit_profile(profile_mpi_barrier)
+
     call exit_profile(profile_mpi)
   end subroutine