Changeset 1004

Timestamp:

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

Author:

adurocher

Message:

transfert_mpi : Send only necessary messages + overlap HtoH

File:

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

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

@@ -233 +233 @@
     allocate( message%mpi_requests_in(0:mpi_size-1) )
     allocate( message%mpi_requests_out(0:mpi_size-1) )
+    message%mpi_requests_in(0:mpi_size-1) = MPI_REQUEST_NULL
+    message%mpi_requests_out(0:mpi_size-1) = MPI_REQUEST_NULL
     do i = 0, mpi_size-1
       if(  size(message%mpi_buffer_in(i)%buff) /= message%mpi_buffer_in(i)%n &
       .or. size(message%mpi_buffer_out(i)%buff) /= message%mpi_buffer_out(i)%n)&
         call dynamico_abort("Internal error in transfert_mpi : mpi buffer size different than expected")
-      call MPI_Send_Init( message%mpi_buffer_out(i)%buff, message%mpi_buffer_out(i)%n, MPI_REAL8, i,&
-                          100, comm_icosa, message%mpi_requests_out(i), ierr )
-      call MPI_Recv_Init( message%mpi_buffer_in(i)%buff, message%mpi_buffer_in(i)%n, MPI_REAL8, i,&
-                          100, comm_icosa, message%mpi_requests_in(i), ierr )
+      if( message%mpi_buffer_out(i)%n > 0) then 
+        call MPI_Send_Init( message%mpi_buffer_out(i)%buff, message%mpi_buffer_out(i)%n, MPI_REAL8, i,&
+                            100, comm_icosa, message%mpi_requests_out(i), ierr )
+      endif
+      if( message%mpi_buffer_in(i)%n > 0) then 
+        call MPI_Recv_Init( message%mpi_buffer_in(i)%buff, message%mpi_buffer_in(i)%n, MPI_REAL8, i,&
+                            100, comm_icosa, message%mpi_requests_in(i), ierr )
+      endif
     end do
     
@@ -437 +443 @@
     !$acc wait
     do i = 0, mpi_size-1
-      call MPI_Request_free(message%mpi_requests_out(i), ierr)
-      call MPI_Request_free(message%mpi_requests_in(i), ierr)
-      !$acc host_data use_device(message%mpi_buffer_out(i)%buff)
-      ! /!\ buff(1) is important for PGI to avoid temporary array copy
-      call MPI_Send_Init( message%mpi_buffer_out(i)%buff(1), message%mpi_buffer_out(i)%n, MPI_REAL8, i,&
-                          0, comm_icosa, message%mpi_requests_out(i), ierr )
-      !$acc end host_data
-      !$acc host_data use_device(message%mpi_buffer_in(i)%buff)
-      call MPI_Recv_Init( message%mpi_buffer_in(i)%buff(1), message%mpi_buffer_in(i)%n, MPI_REAL8, i,&
-                          0, comm_icosa, message%mpi_requests_in(i), ierr )
-      !$acc end host_data
-    end do
-
+      if( message%mpi_requests_out(i) /= MPI_REQUEST_NULL ) then
+        call MPI_Request_free(message%mpi_requests_out(i), ierr)
+        !$acc host_data use_device(message%mpi_buffer_out(i)%buff)
+          ! /!\ buff(1) is important for PGI to avoid temporary array copy
+          call MPI_Send_Init( message%mpi_buffer_out(i)%buff(1), message%mpi_buffer_out(i)%n, MPI_REAL8, i,&
+                              0, comm_icosa, message%mpi_requests_out(i), ierr )
+        !$acc end host_data
+      end if
+      if( message%mpi_requests_in(i) /= MPI_REQUEST_NULL ) then 
+        call MPI_Request_free(message%mpi_requests_in(i), ierr)
+        !$acc host_data use_device(message%mpi_buffer_in(i)%buff)
+          call MPI_Recv_Init( message%mpi_buffer_in(i)%buff(1), message%mpi_buffer_in(i)%n, MPI_REAL8, i,&
+                              0, comm_icosa, message%mpi_requests_in(i), ierr )
+        !$acc end host_data
+      endif
+    end do
     message%ondevice=.true.
     !!$acc update device(message%ondevice)
@@ -516 +525 @@
 
   subroutine finalize_message(message)
+    use mpi_mod    
     use mpipara, only : mpi_size
     type(t_message), intent(inout) :: message
@@ -529 +539 @@
     deallocate(message%message_local)
     do i=0, mpi_size-1
-      call MPI_Request_free(message%mpi_requests_in(i), ierr)
-      call MPI_Request_free(message%mpi_requests_out(i), ierr)
+      if(message%mpi_requests_in(i) /= MPI_REQUEST_NULL) call MPI_Request_free(message%mpi_requests_in(i), ierr)
+      if(message%mpi_requests_out(i) /= MPI_REQUEST_NULL)call MPI_Request_free(message%mpi_requests_out(i), ierr)
       deallocate(message%mpi_buffer_in(i)%buff)
       deallocate(message%mpi_buffer_out(i)%buff)
@@ -622 +632 @@
   subroutine send_message(field, message)
     use mpi_mod
+    use mpipara , only : mpi_size
     type(t_field),pointer :: field(:)
     type(t_message), target :: message
-    integer :: ierr
+    integer :: ierr, i
 
     call enter_profile(profile_mpi)
@@ -648 +659 @@
     call enter_profile(profile_mpi_copies)
     call copy_HtoB(message)
+    call exit_profile(profile_mpi_copies)
+
+    !$omp master
+    do i=0, mpi_size-1
+      if(message%mpi_requests_in(i) /= MPI_REQUEST_NULL) call MPI_Start( message%mpi_requests_in(i), ierr )
+    end do
+    !$omp end master
+
+    call enter_profile(profile_mpi_barrier)
+    !$acc wait
+    !$omp barrier
+    call exit_profile(profile_mpi_barrier)
+
+    !$omp master
+    do i=0, mpi_size-1
+      if(message%mpi_requests_out(i) /= MPI_REQUEST_NULL) call MPI_Start( message%mpi_requests_out(i), ierr )
+    end do
+    !$omp end master
+
+    call enter_profile(profile_mpi_copies)
     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)
@@ -670 +691 @@
     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
+    !!$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