- Timestamp:
- 01/10/20 12:20:52 (4 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
codes/icosagcm/trunk/src/parallel/transfert_mpi.f90
r1003 r1004 233 233 allocate( message%mpi_requests_in(0:mpi_size-1) ) 234 234 allocate( message%mpi_requests_out(0:mpi_size-1) ) 235 message%mpi_requests_in(0:mpi_size-1) = MPI_REQUEST_NULL 236 message%mpi_requests_out(0:mpi_size-1) = MPI_REQUEST_NULL 235 237 do i = 0, mpi_size-1 236 238 if( size(message%mpi_buffer_in(i)%buff) /= message%mpi_buffer_in(i)%n & 237 239 .or. size(message%mpi_buffer_out(i)%buff) /= message%mpi_buffer_out(i)%n)& 238 240 call dynamico_abort("Internal error in transfert_mpi : mpi buffer size different than expected") 239 call MPI_Send_Init( message%mpi_buffer_out(i)%buff, message%mpi_buffer_out(i)%n, MPI_REAL8, i,& 240 100, comm_icosa, message%mpi_requests_out(i), ierr ) 241 call MPI_Recv_Init( message%mpi_buffer_in(i)%buff, message%mpi_buffer_in(i)%n, MPI_REAL8, i,& 242 100, comm_icosa, message%mpi_requests_in(i), ierr ) 241 if( message%mpi_buffer_out(i)%n > 0) then 242 call MPI_Send_Init( message%mpi_buffer_out(i)%buff, message%mpi_buffer_out(i)%n, MPI_REAL8, i,& 243 100, comm_icosa, message%mpi_requests_out(i), ierr ) 244 endif 245 if( message%mpi_buffer_in(i)%n > 0) then 246 call MPI_Recv_Init( message%mpi_buffer_in(i)%buff, message%mpi_buffer_in(i)%n, MPI_REAL8, i,& 247 100, comm_icosa, message%mpi_requests_in(i), ierr ) 248 endif 243 249 end do 244 250 … … 437 443 !$acc wait 438 444 do i = 0, mpi_size-1 439 call MPI_Request_free(message%mpi_requests_out(i), ierr) 440 call MPI_Request_free(message%mpi_requests_in(i), ierr) 441 !$acc host_data use_device(message%mpi_buffer_out(i)%buff) 442 ! /!\ buff(1) is important for PGI to avoid temporary array copy 443 call MPI_Send_Init( message%mpi_buffer_out(i)%buff(1), message%mpi_buffer_out(i)%n, MPI_REAL8, i,& 444 0, comm_icosa, message%mpi_requests_out(i), ierr ) 445 !$acc end host_data 446 !$acc host_data use_device(message%mpi_buffer_in(i)%buff) 447 call MPI_Recv_Init( message%mpi_buffer_in(i)%buff(1), message%mpi_buffer_in(i)%n, MPI_REAL8, i,& 448 0, comm_icosa, message%mpi_requests_in(i), ierr ) 449 !$acc end host_data 450 end do 451 445 if( message%mpi_requests_out(i) /= MPI_REQUEST_NULL ) then 446 call MPI_Request_free(message%mpi_requests_out(i), ierr) 447 !$acc host_data use_device(message%mpi_buffer_out(i)%buff) 448 ! /!\ buff(1) is important for PGI to avoid temporary array copy 449 call MPI_Send_Init( message%mpi_buffer_out(i)%buff(1), message%mpi_buffer_out(i)%n, MPI_REAL8, i,& 450 0, comm_icosa, message%mpi_requests_out(i), ierr ) 451 !$acc end host_data 452 end if 453 if( message%mpi_requests_in(i) /= MPI_REQUEST_NULL ) then 454 call MPI_Request_free(message%mpi_requests_in(i), ierr) 455 !$acc host_data use_device(message%mpi_buffer_in(i)%buff) 456 call MPI_Recv_Init( message%mpi_buffer_in(i)%buff(1), message%mpi_buffer_in(i)%n, MPI_REAL8, i,& 457 0, comm_icosa, message%mpi_requests_in(i), ierr ) 458 !$acc end host_data 459 endif 460 end do 452 461 message%ondevice=.true. 453 462 !!$acc update device(message%ondevice) … … 516 525 517 526 subroutine finalize_message(message) 527 use mpi_mod 518 528 use mpipara, only : mpi_size 519 529 type(t_message), intent(inout) :: message … … 529 539 deallocate(message%message_local) 530 540 do i=0, mpi_size-1 531 call MPI_Request_free(message%mpi_requests_in(i), ierr)532 call MPI_Request_free(message%mpi_requests_out(i), ierr)541 if(message%mpi_requests_in(i) /= MPI_REQUEST_NULL) call MPI_Request_free(message%mpi_requests_in(i), ierr) 542 if(message%mpi_requests_out(i) /= MPI_REQUEST_NULL)call MPI_Request_free(message%mpi_requests_out(i), ierr) 533 543 deallocate(message%mpi_buffer_in(i)%buff) 534 544 deallocate(message%mpi_buffer_out(i)%buff) … … 622 632 subroutine send_message(field, message) 623 633 use mpi_mod 634 use mpipara , only : mpi_size 624 635 type(t_field),pointer :: field(:) 625 636 type(t_message), target :: message 626 integer :: ierr 637 integer :: ierr, i 627 638 628 639 call enter_profile(profile_mpi) … … 648 659 call enter_profile(profile_mpi_copies) 649 660 call copy_HtoB(message) 661 call exit_profile(profile_mpi_copies) 662 663 !$omp master 664 do i=0, mpi_size-1 665 if(message%mpi_requests_in(i) /= MPI_REQUEST_NULL) call MPI_Start( message%mpi_requests_in(i), ierr ) 666 end do 667 !$omp end master 668 669 call enter_profile(profile_mpi_barrier) 670 !$acc wait 671 !$omp barrier 672 call exit_profile(profile_mpi_barrier) 673 674 !$omp master 675 do i=0, mpi_size-1 676 if(message%mpi_requests_out(i) /= MPI_REQUEST_NULL) call MPI_Start( message%mpi_requests_out(i), ierr ) 677 end do 678 !$omp end master 679 680 call enter_profile(profile_mpi_copies) 650 681 call copy_HtoH(message) 651 682 call exit_profile(profile_mpi_copies) 652 653 call enter_profile(profile_mpi_barrier)654 !$acc wait655 !$omp barrier656 call exit_profile(profile_mpi_barrier)657 658 !$omp master659 call MPI_Startall( size(message%mpi_requests_out), message%mpi_requests_out, ierr )660 call MPI_Startall( size(message%mpi_requests_in), message%mpi_requests_in, ierr )661 !$omp end master662 683 663 684 call exit_profile(profile_mpi) … … 670 691 logical :: completed 671 692 672 ! $omp master673 call MPI_Testall( size(message%mpi_requests_out), message%mpi_requests_out, completed, MPI_STATUSES_IGNORE, ierr )674 call MPI_Testall( size(message%mpi_requests_in), message%mpi_requests_in, completed, MPI_STATUSES_IGNORE, ierr )675 ! $omp end master693 !!$omp master 694 !call MPI_Testall( size(message%mpi_requests_out), message%mpi_requests_out, completed, MPI_STATUSES_IGNORE, ierr ) 695 !call MPI_Testall( size(message%mpi_requests_in), message%mpi_requests_in, completed, MPI_STATUSES_IGNORE, ierr ) 696 !!$omp end master 676 697 end subroutine 677 698
Note: See TracChangeset
for help on using the changeset viewer.