fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

[UPDATE] Updated buffer reuse in psb_dcg

Browse Source
communication_v2
Stack-1 3 months ago
parent 33477e4f03
commit 6b803fd759
13 changed files with 301 additions and 1948 deletions
Show Stats Download Patch File Download Diff File

75
base/comm/internals/psi_dswapdata.F90
Unescape Escape View File

@ -159,7 +159,7 @@ contains
end if end if
if (.not. allocated(y%comm_handle)) then if (.not. allocated(y%comm_handle)) then
call psb_comm_init(psb_comm_isend_irecv_, y%comm_handle, info) call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline')
goto 9999 goto 9999
@ -338,6 +338,16 @@ contains
snd_pt = 1+pnti+nerv+psb_n_elem_send_ snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_ rcv_pt = 1+pnti+psb_n_elem_recv_
idx_pt = snd_pt idx_pt = snd_pt
if ((idx_pt < 1) .or. (nesd < 0) .or. (idx_pt+max(0,nesd)-1 > size(comm_indexes%v))) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='baseline gather metadata out of bounds')
goto 9999
end if
if ((idx_pt < 1) .or. (nesd < 0) .or. (idx_pt+max(0,nesd)-1 > size(y%combuf))) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='baseline gather combuf bounds error')
goto 9999
end if
call y%gth(idx_pt,nesd,comm_indexes) call y%gth(idx_pt,nesd,comm_indexes)
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
@ -441,6 +451,17 @@ contains
snd_pt = 1+pnti+nerv+psb_n_elem_send_ snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_ rcv_pt = 1+pnti+psb_n_elem_recv_
if ((idx_pt < 1) .or. (nerv < 0) .or. (idx_pt+max(0,nerv)-1 > size(comm_indexes%v))) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='baseline scatter metadata out of bounds')
goto 9999
end if
if ((rcv_pt < 1) .or. (nerv < 0) .or. (rcv_pt+max(0,nerv)-1 > size(y%combuf))) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='baseline scatter combuf bounds error')
goto 9999
end if
if (debug) write(0,*)me,' Received from: ',prcid(i),& if (debug) write(0,*)me,' Received from: ',prcid(i),&
& y%combuf(rcv_pt:rcv_pt+nerv-1) & y%combuf(rcv_pt:rcv_pt+nerv-1)
call y%sct(rcv_pt,nerv,comm_indexes,beta) call y%sct(rcv_pt,nerv,comm_indexes,beta)
@ -547,6 +568,13 @@ contains
! --------------------------------------------------------- ! ---------------------------------------------------------
if (do_start) then if (do_start) then
if(debug) write(*,*) me,' nbr_vect: starting data exchange' if(debug) write(*,*) me,' nbr_vect: starting data exchange'
if (neighbor_comm_handle%use_persistent_buffers) then
if (neighbor_comm_handle%persistent_in_flight) then
info = psb_err_mpi_error_
call psb_errpush(info, name, a_err='Invalid START: persistent neighbor request already in flight')
goto 9999
end if
end if
if (.not. neighbor_comm_handle%is_initialized) then if (.not. neighbor_comm_handle%is_initialized) then
if (debug) write(*,*) me,' nbr_vect: building topology via handle' if (debug) write(*,*) me,' nbr_vect: building topology via handle'
call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info)
@ -571,6 +599,7 @@ contains
end if end if
neighbor_comm_handle%persistent_request = mpi_request_null neighbor_comm_handle%persistent_request = mpi_request_null
neighbor_comm_handle%persistent_request_ready = .false. neighbor_comm_handle%persistent_request_ready = .false.
neighbor_comm_handle%persistent_in_flight = .false.
neighbor_comm_handle%persistent_buffer_size = 0 neighbor_comm_handle%persistent_buffer_size = 0
end if end if
call y%new_buffer(buffer_size, info) call y%new_buffer(buffer_size, info)
@ -635,6 +664,7 @@ contains
call psb_errpush(info, name, m_err=(/iret/)) call psb_errpush(info, name, m_err=(/iret/))
goto 9999 goto 9999
end if end if
neighbor_comm_handle%persistent_in_flight = .true.
#else #else
call mpi_ineighbor_alltoallv( & call mpi_ineighbor_alltoallv( &
& y%combuf(1), & ! send buffer & y%combuf(1), & ! send buffer
@ -652,6 +682,7 @@ contains
call psb_errpush(info, name, m_err=(/iret/)) call psb_errpush(info, name, m_err=(/iret/))
goto 9999 goto 9999
end if end if
neighbor_comm_handle%persistent_in_flight = .true.
#endif #endif
else else
! Post non-blocking neighborhood alltoallv ! Post non-blocking neighborhood alltoallv
@ -682,19 +713,11 @@ contains
if (do_wait) then if (do_wait) then
if (neighbor_comm_handle%use_persistent_buffers) then if (neighbor_comm_handle%use_persistent_buffers) then
#ifdef PSB_HAVE_MPI_NEIGHBOR_PERSISTENT if (.not. neighbor_comm_handle%persistent_in_flight) then
if (.not. neighbor_comm_handle%persistent_request_ready) then
info = psb_err_mpi_error_ info = psb_err_mpi_error_
call psb_errpush(info, name, m_err=(/-2/)) call psb_errpush(info, name, a_err='Invalid WAIT: no persistent neighbor request in flight')
goto 9999 goto 9999
end if end if
#else
if (neighbor_comm_handle%comm_request == mpi_request_null) then
info = psb_err_mpi_error_
call psb_errpush(info, name, m_err=(/-2/))
goto 9999
end if
#endif
else else
if (neighbor_comm_handle%comm_request == mpi_request_null) then if (neighbor_comm_handle%comm_request == mpi_request_null) then
write(psb_err_unit,*) me, 'DBG: neighbor WAIT but comm_request is NULL; is_initialized=', & write(psb_err_unit,*) me, 'DBG: neighbor WAIT but comm_request is NULL; is_initialized=', &
@ -724,6 +747,9 @@ contains
call psb_errpush(info, name, m_err=(/iret/)) call psb_errpush(info, name, m_err=(/iret/))
goto 9999 goto 9999
end if end if
if (neighbor_comm_handle%use_persistent_buffers) then
neighbor_comm_handle%persistent_in_flight = .false.
end if
! Scatter received data to local vector positions (polymorphic for GPU) ! Scatter received data to local vector positions (polymorphic for GPU)
if (debug) write(*,*) me,' nbr_vect: scattering recv data,', topology_total_recv,' elems' if (debug) write(*,*) me,' nbr_vect: scattering recv data,', topology_total_recv,' elems'
@ -834,7 +860,7 @@ contains
end if end if
if (.not. allocated(y%comm_handle)) then if (.not. allocated(y%comm_handle)) then
call psb_comm_init(psb_comm_isend_irecv_, y%comm_handle, info) call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline')
goto 9999 goto 9999
@ -1202,6 +1228,13 @@ subroutine psi_dswap_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_in
! --------------------------------------------------------- ! ---------------------------------------------------------
if (do_start) then if (do_start) then
if(debug) write(*,*) me,' nbr_vect: starting data exchange' if(debug) write(*,*) me,' nbr_vect: starting data exchange'
if (neighbor_comm_handle%use_persistent_buffers) then
if (neighbor_comm_handle%persistent_in_flight) then
info = psb_err_mpi_error_
call psb_errpush(info, name, a_err='Invalid START: persistent neighbor request already in flight')
goto 9999
end if
end if
if (.not. neighbor_comm_handle%is_initialized) then if (.not. neighbor_comm_handle%is_initialized) then
if (debug) write(*,*) me,' nbr_vect: building topology via handle' if (debug) write(*,*) me,' nbr_vect: building topology via handle'
call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, & call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, &
@ -1227,6 +1260,7 @@ subroutine psi_dswap_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_in
end if end if
neighbor_comm_handle%persistent_request = mpi_request_null neighbor_comm_handle%persistent_request = mpi_request_null
neighbor_comm_handle%persistent_request_ready = .false. neighbor_comm_handle%persistent_request_ready = .false.
neighbor_comm_handle%persistent_in_flight = .false.
neighbor_comm_handle%persistent_buffer_size = 0 neighbor_comm_handle%persistent_buffer_size = 0
end if end if
call y%new_buffer(buffer_size, info) call y%new_buffer(buffer_size, info)
@ -1290,6 +1324,7 @@ subroutine psi_dswap_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_in
call psb_errpush(info, name, m_err=(/iret/)) call psb_errpush(info, name, m_err=(/iret/))
goto 9999 goto 9999
end if end if
neighbor_comm_handle%persistent_in_flight = .true.
#else #else
call mpi_ineighbor_alltoallv( & call mpi_ineighbor_alltoallv( &
& y%combuf(1), & ! send buffer & y%combuf(1), & ! send buffer
@ -1307,6 +1342,7 @@ subroutine psi_dswap_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_in
call psb_errpush(info, name, m_err=(/iret/)) call psb_errpush(info, name, m_err=(/iret/))
goto 9999 goto 9999
end if end if
neighbor_comm_handle%persistent_in_flight = .true.
#endif #endif
else else
! Post non-blocking neighborhood alltoallv ! Post non-blocking neighborhood alltoallv
@ -1337,19 +1373,11 @@ subroutine psi_dswap_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_in
if (do_wait) then if (do_wait) then
if (neighbor_comm_handle%use_persistent_buffers) then if (neighbor_comm_handle%use_persistent_buffers) then
#ifdef PSB_HAVE_MPI_NEIGHBOR_PERSISTENT if (.not. neighbor_comm_handle%persistent_in_flight) then
if (.not. neighbor_comm_handle%persistent_request_ready) then
info = psb_err_mpi_error_ info = psb_err_mpi_error_
call psb_errpush(info, name, m_err=(/-2/)) call psb_errpush(info, name, a_err='Invalid WAIT: no persistent neighbor request in flight')
goto 9999
end if
#else
if (neighbor_comm_handle%comm_request == mpi_request_null) then
info = psb_err_mpi_error_
call psb_errpush(info, name, m_err=(/-2/))
goto 9999 goto 9999
end if end if
#endif
else else
if (neighbor_comm_handle%comm_request == mpi_request_null) then if (neighbor_comm_handle%comm_request == mpi_request_null) then
info = psb_err_mpi_error_ info = psb_err_mpi_error_
@ -1377,6 +1405,9 @@ subroutine psi_dswap_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_in
call psb_errpush(info, name, m_err=(/iret/)) call psb_errpush(info, name, m_err=(/iret/))
goto 9999 goto 9999
end if end if
if (neighbor_comm_handle%use_persistent_buffers) then
neighbor_comm_handle%persistent_in_flight = .false.
end if
! Scatter received data to local vector positions (polymorphic for GPU) ! Scatter received data to local vector positions (polymorphic for GPU)
if (debug) write(*,*) me,' nbr_vect: scattering recv data,', topology_total_recv,' elems' if (debug) write(*,*) me,' nbr_vect: scattering recv data,', topology_total_recv,' elems'

4
base/comm/internals/psi_dswaptran.F90
Unescape Escape View File

@ -160,7 +160,7 @@ contains
end if end if
if (.not. allocated(y%comm_handle)) then if (.not. allocated(y%comm_handle)) then
call psb_comm_init(psb_comm_isend_irecv_, y%comm_handle, info) call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline')
goto 9999 goto 9999
@ -741,7 +741,7 @@ contains
end if end if
if (.not. allocated(y%comm_handle)) then if (.not. allocated(y%comm_handle)) then
call psb_comm_init(psb_comm_isend_irecv_, y%comm_handle, info) call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline')
goto 9999 goto 9999

23
base/modules/comm/comm_schemes/psb_comm_factory_mod.F90
Unescape Escape View File

@ -11,7 +11,7 @@ module psb_comm_factory_mod
contains contains
! Allocatable-based factory routines (preferred names) ! Allocatable-based factory routines (preferred names)
subroutine psb_comm_init(comm_type, handle, info) subroutine psb_comm_set(comm_type, handle, info)
implicit none implicit none
integer(psb_ipk_), intent(in) :: comm_type integer(psb_ipk_), intent(in) :: comm_type
class(psb_comm_handle_type), allocatable, intent(inout) :: handle class(psb_comm_handle_type), allocatable, intent(inout) :: handle
@ -68,7 +68,7 @@ contains
handle%id = old_id handle%id = old_id
handle%swap_status = old_swap_status handle%swap_status = old_swap_status
end select end select
end subroutine psb_comm_init end subroutine psb_comm_set
subroutine psb_comm_free(handle, info) subroutine psb_comm_free(handle, info)
implicit none implicit none
@ -83,25 +83,6 @@ contains
end if end if
end subroutine psb_comm_free end subroutine psb_comm_free
! Allocatable-based factory routines
subroutine psb_comm_create(comm_type, handle, info)
implicit none
integer(psb_ipk_), intent(in) :: comm_type
class(psb_comm_handle_type), allocatable, intent(inout) :: handle
integer(psb_ipk_), intent(out) :: info
call psb_comm_init(comm_type, handle, info)
end subroutine psb_comm_create
subroutine psb_comm_destroy(handle, info)
implicit none
class(psb_comm_handle_type), allocatable, intent(inout) :: handle
integer(psb_ipk_), intent(out) :: info
call psb_comm_free(handle, info)
end subroutine psb_comm_destroy
subroutine psb_comm_set_swap_status(handle, flag, info) subroutine psb_comm_set_swap_status(handle, flag, info)
implicit none implicit none
class(psb_comm_handle_type), allocatable, intent(inout) :: handle class(psb_comm_handle_type), allocatable, intent(inout) :: handle

5
base/modules/comm/comm_schemes/psb_comm_neighbor_impl_mod.F90
Unescape Escape View File

@ -28,6 +28,7 @@ module psb_comm_neighbor_impl_mod
integer(psb_mpk_) :: comm_request = mpi_request_null integer(psb_mpk_) :: comm_request = mpi_request_null
integer(psb_mpk_) :: persistent_request = mpi_request_null integer(psb_mpk_) :: persistent_request = mpi_request_null
logical :: persistent_request_ready = .false. logical :: persistent_request_ready = .false.
logical :: persistent_in_flight = .false.
integer(psb_ipk_) :: persistent_buffer_size = 0 integer(psb_ipk_) :: persistent_buffer_size = 0
contains contains
procedure, pass :: init => psb_comm_neighbor_init procedure, pass :: init => psb_comm_neighbor_init
@ -316,6 +317,7 @@ contains
end if end if
this%persistent_request = mpi_request_null this%persistent_request = mpi_request_null
this%persistent_request_ready = .false. this%persistent_request_ready = .false.
this%persistent_in_flight = .false.
this%persistent_buffer_size = 0 this%persistent_buffer_size = 0
end if end if
@ -372,6 +374,7 @@ contains
this%id = 0 this%id = 0
this%swap_status = 0 this%swap_status = 0
this%comm_request = mpi_request_null this%comm_request = mpi_request_null
this%persistent_in_flight = .false.
this%persistent_request = mpi_request_null this%persistent_request = mpi_request_null
this%persistent_request_ready = .false. this%persistent_request_ready = .false.
this%persistent_buffer_size = 0 this%persistent_buffer_size = 0
@ -388,6 +391,7 @@ contains
this%comm_request = mpi_request_null this%comm_request = mpi_request_null
this%persistent_request = mpi_request_null this%persistent_request = mpi_request_null
this%persistent_request_ready = .false. this%persistent_request_ready = .false.
this%persistent_in_flight = .false.
this%persistent_buffer_size = 0 this%persistent_buffer_size = 0
call this%free(info) call this%free(info)
end subroutine psb_comm_neighbor_destroy end subroutine psb_comm_neighbor_destroy
@ -424,6 +428,7 @@ contains
this%comm_request = mpi_request_null this%comm_request = mpi_request_null
this%persistent_request = mpi_request_null this%persistent_request = mpi_request_null
this%persistent_request_ready = .false. this%persistent_request_ready = .false.
this%persistent_in_flight = .false.
this%persistent_buffer_size = 0 this%persistent_buffer_size = 0
end subroutine psb_comm_neighbor_init end subroutine psb_comm_neighbor_init

6
base/modules/comm/comm_schemes/psb_comm_schemes_mod.F90
Unescape Escape View File

@ -21,15 +21,13 @@ module psb_comm_schemes_mod
end enum end enum
! (abstract interfaces moved below type definition)
! --- comm handle type --- ! --- comm handle type ---
type, abstract :: psb_comm_handle_type type, abstract :: psb_comm_handle_type
integer(psb_ipk_) :: id = -1 integer(psb_ipk_) :: id = -1
integer(psb_ipk_) :: comm_type = psb_comm_unknown_ integer(psb_ipk_) :: comm_type = psb_comm_unknown_
integer(psb_ipk_) :: swap_status = psb_comm_status_unknown_ integer(psb_ipk_) :: swap_status = psb_comm_status_unknown_
contains contains
procedure(psb_comm_init), deferred :: init procedure(psb_comm_set), deferred :: init
procedure(psb_comm_free), deferred :: free procedure(psb_comm_free), deferred :: free
procedure(psb_comm_set_swap_status), deferred :: set_swap_status procedure(psb_comm_set_swap_status), deferred :: set_swap_status
procedure(psb_comm_get_swap_status), deferred :: get_swap_status procedure(psb_comm_get_swap_status), deferred :: get_swap_status
@ -37,7 +35,7 @@ module psb_comm_schemes_mod
! --- abstract interfaces --- ! --- abstract interfaces ---
abstract interface abstract interface
subroutine psb_comm_init(this, info) subroutine psb_comm_set(this, info)
import :: psb_ipk_, psb_comm_handle_type import :: psb_ipk_, psb_comm_handle_type
class(psb_comm_handle_type), intent(inout) :: this class(psb_comm_handle_type), intent(inout) :: this
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info

21
base/modules/serial/psb_d_base_vect_mod.F90
Unescape Escape View File

@ -50,7 +50,7 @@ module psb_d_base_vect_mod
use psb_i_base_vect_mod use psb_i_base_vect_mod
use psb_l_base_vect_mod use psb_l_base_vect_mod
use psb_comm_schemes_mod, only: psb_comm_handle_type, psb_comm_isend_irecv_, psb_comm_unknown_ use psb_comm_schemes_mod, only: psb_comm_handle_type, psb_comm_isend_irecv_, psb_comm_unknown_
use psb_comm_factory_mod, only: psb_comm_init, psb_comm_free use psb_comm_factory_mod, only: psb_comm_set, psb_comm_free
!> \namespace psb_base_mod \class psb_d_base_vect_type !> \namespace psb_base_mod \class psb_d_base_vect_type
@ -176,13 +176,6 @@ module psb_d_base_vect_mod
procedure, pass(x) :: check_addr => d_base_check_addr procedure, pass(x) :: check_addr => d_base_check_addr
! Communication lifecycle split:
! - `create_comm`: allocate/select a fresh handle implementation via factory.
! - `init_comm`: configure the current handle instance from an existing one
! (e.g., copy `id` and swap status), and reset buffers;
! it recreates the handle only if missing or scheme changes.
! - `destroy_comm`/`free_comm`: release current handle resources.
! !
! Dot product and AXPBY ! Dot product and AXPBY
@ -414,7 +407,7 @@ contains
end if end if
if (info == psb_success_) then if (info == psb_success_) then
if (.not. allocated(x%comm_handle)) then if (.not. allocated(x%comm_handle)) then
call psb_comm_init(psb_comm_isend_irecv_, x%comm_handle, info) call psb_comm_set(psb_comm_isend_irecv_, x%comm_handle, info)
end if end if
end if end if
@ -436,7 +429,7 @@ contains
allocate(psb_d_base_vect_type :: y, stat=info) allocate(psb_d_base_vect_type :: y, stat=info)
if (info == psb_success_) then if (info == psb_success_) then
call psb_comm_init(psb_comm_isend_irecv_, y%comm_handle, info) call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info)
end if end if
end subroutine d_base_mold end subroutine d_base_mold
@ -464,7 +457,7 @@ contains
end if end if
if (info == psb_success_) then if (info == psb_success_) then
if (.not. allocated(x%comm_handle)) then if (.not. allocated(x%comm_handle)) then
call psb_comm_init(psb_comm_isend_irecv_, x%comm_handle, info) call psb_comm_set(psb_comm_isend_irecv_, x%comm_handle, info)
end if end if
end if end if
@ -1114,7 +1107,7 @@ contains
call y%set_ncfs(x%get_ncfs()) call y%set_ncfs(x%get_ncfs())
if (allocated(x%iv)) y%iv = x%iv if (allocated(x%iv)) y%iv = x%iv
if (allocated(x%comm_handle)) then if (allocated(x%comm_handle)) then
call psb_comm_init(x%comm_handle%comm_type, y%comm_handle, info) call psb_comm_set(x%comm_handle%comm_type, y%comm_handle, info)
if (info /= psb_success_) return if (info /= psb_success_) return
y%comm_handle%id = x%comm_handle%id y%comm_handle%id = x%comm_handle%id
call x%comm_handle%get_swap_status(swap_status, info) call x%comm_handle%get_swap_status(swap_status, info)
@ -1122,7 +1115,7 @@ contains
call y%comm_handle%set_swap_status(swap_status, info) call y%comm_handle%set_swap_status(swap_status, info)
if (info /= psb_success_) return if (info /= psb_success_) return
else else
call psb_comm_init(psb_comm_isend_irecv_, y%comm_handle, info) call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info)
end if end if
end subroutine d_base_cpy end subroutine d_base_cpy
@ -2409,7 +2402,7 @@ contains
end if end if
if (need_new_handle) then if (need_new_handle) then
call psb_comm_init(comm_type, x%comm_handle, info) call psb_comm_set(comm_type, x%comm_handle, info)
if (info /= psb_success_) return if (info /= psb_success_) return
end if end if

14
linsolve/impl/psb_dcg.F90
Unescape Escape View File

@ -120,6 +120,7 @@ subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,&
real(psb_dpk_) :: alpha, beta, rho, rho_old, sigma,alpha_old,beta_old real(psb_dpk_) :: alpha, beta, rho, rho_old, sigma,alpha_old,beta_old
integer(psb_ipk_) :: itmax_, istop_, it, itx, itrace_,& integer(psb_ipk_) :: itmax_, istop_, it, itx, itrace_,&
& n_col, n_row,err_act, ieg,nspl, istebz & n_col, n_row,err_act, ieg,nspl, istebz
integer(psb_ipk_) :: i, swap_status
integer(psb_lpk_) :: mglob integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
@ -173,6 +174,19 @@ subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,&
if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=5_psb_ipk_) if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=5_psb_ipk_)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info,mold=x%v,scratch=.true.) if (info == psb_success_) call psb_geasb(wwrk,desc_a,info,mold=x%v,scratch=.true.)
if ((info == psb_success_).and.allocated(x%v%comm_handle)) then
do i=1,size(wwrk)
if (allocated(wwrk(i)%v)) then
call psb_comm_set(x%v%comm_handle%comm_type,wwrk(i)%v%comm_handle,info)
if (info /= psb_success_) exit
wwrk(i)%v%comm_handle%id = x%v%comm_handle%id
call x%v%comm_handle%get_swap_status(swap_status,info)
if (info /= psb_success_) exit
call wwrk(i)%v%comm_handle%set_swap_status(swap_status,info)
if (info /= psb_success_) exit
end if
end do
end if
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_non_ info=psb_err_from_subroutine_non_
call psb_errpush(info,name) call psb_errpush(info,name)

1824
log.txt
View File

File diff suppressed because one or more lines are too long

249
test/comm/cg/psb_comm_cg_test.F90
Unescape Escape View File

@ -13,27 +13,41 @@ program psb_comm_cg_test
type(psb_dprec_type) :: prec type(psb_dprec_type) :: prec
integer(psb_ipk_) :: info, iam, np integer(psb_ipk_) :: info, iam, np
integer(psb_ipk_) :: idim, itmax, itrace, istop, iter, is integer(psb_ipk_) :: idim, itmax, itrace, istop, iter
integer(psb_ipk_) :: iter_arr(3), info_arr(3) integer(psb_ipk_) :: scheme_idx, prec_idx, rep, nrep, nwarm
integer(psb_ipk_) :: scheme_types(3) integer(psb_ipk_), parameter :: n_schemes=3, n_precs=2
real(psb_dpk_) :: eps, err, t1, t2 integer(psb_ipk_), allocatable :: iter_count(:,:,:), solve_info(:,:,:)
real(psb_dpk_) :: tsolve(3), err_arr(3) integer(psb_ipk_) :: scheme_type(n_schemes)
character(len=25) :: scheme_names(3) real(psb_dpk_) :: eps, err, t_start, t_elapsed
real(psb_dpk_), allocatable :: setup_time(:,:,:), solve_time(:,:,:)
real(psb_dpk_), allocatable :: total_time(:,:,:), final_error(:,:,:)
real(psb_dpk_) :: avg_t, std_t, med_t, p10_t, p90_t, min_t, max_t
character(len=25) :: scheme_name(n_schemes)
character(len=12) :: prec_type(n_precs)
character(len=20) :: prec_name(n_precs)
character(len=5) :: afmt character(len=5) :: afmt
character(len=256) :: arg character(len=256) :: arg
logical :: prec_ready
info = psb_success_ info = psb_success_
prec_ready = .false.
afmt = 'CSR' afmt = 'CSR'
idim = 40 idim = 20
itmax = 500 itmax = 5000
itrace = 0 nrep = 1
nwarm = 1
itrace = 0
istop = 2 istop = 2
eps = 1.d-6 eps = 1.d-6
scheme_types = (/ psb_comm_isend_irecv_, psb_comm_ineighbor_alltoallv_, & scheme_type = (/ psb_comm_isend_irecv_, psb_comm_ineighbor_alltoallv_, &
& psb_comm_persistent_ineighbor_alltoallv_ /) & psb_comm_persistent_ineighbor_alltoallv_ /)
scheme_names(1) = 'isend_irecv' scheme_name(1) = 'isend_irecv'
scheme_names(2) = 'ineighbor_alltoallv' scheme_name(2) = 'ineighbor_alltoallv'
scheme_names(3) = 'persistent_ineighbor_a2av' scheme_name(3) = 'persistent_ineighbor_a2av'
prec_type(1) = 'NONE'
prec_type(2) = 'DIAG'
prec_name(1) = 'none'
prec_name(2) = 'diag'
call get_command_argument(1,arg) call get_command_argument(1,arg)
if (len_trim(arg) > 0) then if (len_trim(arg) > 0) then
@ -43,6 +57,27 @@ program psb_comm_cg_test
info = psb_success_ info = psb_success_
end if end if
end if end if
call get_command_argument(2,arg)
if (len_trim(arg) > 0) then
read(arg,*,iostat=info) nrep
if ((info /= 0).or.(nrep <= 0)) then
nrep = 7
info = psb_success_
end if
end if
call get_command_argument(3,arg)
if (len_trim(arg) > 0) then
read(arg,*,iostat=info) nwarm
if ((info /= 0).or.(nwarm < 0)) then
nwarm = 1
info = psb_success_
end if
end if
allocate(setup_time(n_precs,n_schemes,nrep), solve_time(n_precs,n_schemes,nrep), &
& total_time(n_precs,n_schemes,nrep), final_error(n_precs,n_schemes,nrep), &
& iter_count(n_precs,n_schemes,nrep), solve_info(n_precs,n_schemes,nrep), stat=info)
if (info /= psb_success_) stop 1
call psb_init(ctxt) call psb_init(ctxt)
call psb_info(ctxt, iam, np) call psb_info(ctxt, iam, np)
@ -53,58 +88,120 @@ program psb_comm_cg_test
write(psb_out_unit,'("Grid dimensions : ",i4," x ",i4," x ",i4)') idim,idim,idim write(psb_out_unit,'("Grid dimensions : ",i4," x ",i4," x ",i4)') idim,idim,idim
write(psb_out_unit,'("Number of processors : ",i0)') np write(psb_out_unit,'("Number of processors : ",i0)') np
write(psb_out_unit,'("Iterative method : CG")') write(psb_out_unit,'("Iterative method : CG")')
write(psb_out_unit,'("Preconditioner : NONE")') write(psb_out_unit,'("Preconditioners : NONE, DIAG")')
write(psb_out_unit,'("Repetitions : ",i0)') nrep
write(psb_out_unit,'("Warmup solves : ",i0," (each with itmax=1)")') nwarm
write(psb_out_unit,'(" ")') write(psb_out_unit,'(" ")')
end if end if
call psb_barrier(ctxt) call psb_barrier(ctxt)
t1 = psb_wtime() t_start = psb_wtime()
call psb_d_gen_pde3d(ctxt,idim,a,b,x,desc_a,afmt,info) call psb_d_gen_pde3d(ctxt,idim,a,b,x,desc_a,afmt,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
call prec%init(ctxt,'NONE',info) do prec_idx = 1, n_precs
if (info /= psb_success_) goto 9999 do scheme_idx = 1, n_schemes
do rep = 1, nrep
call prec%build(a,desc_a,info) if (prec_ready) then
if (info /= psb_success_) goto 9999 call psb_precfree(prec,info)
if (info /= psb_success_) goto 9999
do is = 1, 3 prec_ready = .false.
call psb_geaxpby(dzero,b,dzero,x,desc_a,info) end if
if (info /= psb_success_) goto 9999
call psb_geaxpby(dzero,b,dzero,x,desc_a,info)
call psb_comm_init(scheme_types(is),x%v%comm_handle,info) if (info /= psb_success_) goto 9999
if (info /= psb_success_) goto 9999
call psb_barrier(ctxt)
call psb_barrier(ctxt) t_start = psb_wtime()
t1 = psb_wtime() call psb_precinit(ctxt,prec,trim(prec_type(prec_idx)),info)
call psb_krylov('CG',a,prec,b,x,eps,desc_a,info,& if (info /= psb_success_) goto 9999
& itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istop) call psb_precbld(a,desc_a,prec,info)
t2 = psb_wtime() - t1 if (info /= psb_success_) goto 9999
call psb_amx(ctxt,t2) if (.not.allocated(prec%prec)) then
info = psb_err_internal_error_
tsolve(is) = t2 write(psb_err_unit,*) 'Preconditioner object not allocated after build'
iter_arr(is) = iter goto 9999
err_arr(is) = err end if
info_arr(is) = info prec_ready = .true.
if (info /= psb_success_) goto 9999 call psb_comm_set(scheme_type(scheme_idx),x%v%comm_handle,info)
if (info /= psb_success_) goto 9999
if (.not.allocated(prec%prec)) then
info = psb_err_internal_error_
write(psb_err_unit,*) 'Preconditioner object lost after psb_comm_set'
goto 9999
end if
setup_time(prec_idx,scheme_idx,rep) = psb_wtime() - t_start
call psb_amx(ctxt,setup_time(prec_idx,scheme_idx,rep))
do iter = 1, nwarm
call psb_geaxpby(dzero,b,dzero,x,desc_a,info)
if (info /= psb_success_) goto 9999
call psb_krylov('CG',a,prec,b,x,eps,desc_a,info,&
& itmax=itmax,itrace=itrace,istop=istop)
if (info /= psb_success_) goto 9999
end do
call psb_geaxpby(dzero,b,dzero,x,desc_a,info)
if (info /= psb_success_) goto 9999
call psb_barrier(ctxt)
t_start = psb_wtime()
if (.not.allocated(prec%prec)) then
info = psb_err_internal_error_
write(psb_err_unit,*) 'Preconditioner object lost before psb_krylov'
goto 9999
end if
call psb_krylov('CG',a,prec,b,x,eps,desc_a,info,&
& itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istop)
t_elapsed = psb_wtime() - t_start
call psb_amx(ctxt,t_elapsed)
solve_time(prec_idx,scheme_idx,rep) = t_elapsed
total_time(prec_idx,scheme_idx,rep) = setup_time(prec_idx,scheme_idx,rep) + &
& solve_time(prec_idx,scheme_idx,rep)
iter_count(prec_idx,scheme_idx,rep) = iter
final_error(prec_idx,scheme_idx,rep) = err
solve_info(prec_idx,scheme_idx,rep) = info
if (info /= psb_success_) goto 9999
end do
end do
end do end do
if (iam == psb_root_) then if (iam == psb_root_) then
write(psb_out_unit,'(" ")') write(psb_out_unit,'(" ")')
write(psb_out_unit,'("CG solve time by communication scheme")') write(psb_out_unit,'("CG timing stats by preconditioner and communication scheme")')
write(psb_out_unit,'("--------------------------------------")') write(psb_out_unit,'("-----------------------------------------------------------")')
do is = 1, 3 do prec_idx = 1, n_precs
write(psb_out_unit,'(a25,2x,"time=",es12.5,2x,"iter=",i8,2x,"err=",es12.5,2x,"info=",i6)') & write(psb_out_unit,'("Preconditioner: ",a)') trim(prec_name(prec_idx))
& trim(scheme_names(is)), tsolve(is), iter_arr(is), err_arr(is), info_arr(is) do scheme_idx = 1, n_schemes
call compute_stats(setup_time(prec_idx,scheme_idx,:),avg_t,std_t,med_t,p10_t,p90_t,min_t,max_t)
write(psb_out_unit,&
& '(a25,2x,"setup median=",es12.5,2x,"p10=",es12.5,2x,"p90=",es12.5)') &
& trim(scheme_name(scheme_idx)), med_t, p10_t, p90_t
call compute_stats(solve_time(prec_idx,scheme_idx,:),avg_t,std_t,med_t,p10_t,p90_t,min_t,max_t)
write(psb_out_unit,&
& '(27x,"solve median=",es12.5,2x,"mean=",es12.5,2x,"std=",es12.5)') med_t, avg_t, std_t
call compute_stats(total_time(prec_idx,scheme_idx,:),avg_t,std_t,med_t,p10_t,p90_t,min_t,max_t)
write(psb_out_unit,&
& '(27x,"total median=",es12.5,2x,"min=",es12.5,2x,"max=",es12.5)') med_t, min_t, max_t
call compute_stats(final_error(prec_idx,scheme_idx,:),avg_t,std_t,med_t,p10_t,p90_t,min_t,max_t)
write(psb_out_unit,&
& '(27x,"err median=",es12.5,2x,"last it/info=",i8,"/",i6)') &
& med_t, iter_count(prec_idx,scheme_idx,nrep), solve_info(prec_idx,scheme_idx,nrep)
end do
write(psb_out_unit,'(" ")')
end do end do
end if end if
call psb_gefree(b,desc_a,info) call psb_gefree(b,desc_a,info)
call psb_gefree(x,desc_a,info) call psb_gefree(x,desc_a,info)
call psb_spfree(a,desc_a,info) call psb_spfree(a,desc_a,info)
call prec%free(info) if (prec_ready) call psb_precfree(prec,info)
call psb_cdfree(desc_a,info) call psb_cdfree(desc_a,info)
deallocate(setup_time,solve_time,total_time,final_error,iter_count,solve_info)
call psb_exit(ctxt) call psb_exit(ctxt)
stop stop
@ -114,6 +211,64 @@ program psb_comm_cg_test
contains contains
subroutine sort_real_inplace(v)
real(psb_dpk_), intent(inout) :: v(:)
integer(psb_ipk_) :: i, j
real(psb_dpk_) :: key
do i = 2, size(v)
key = v(i)
j = i - 1
do while ((j >= 1).and.(v(j) > key))
v(j+1) = v(j)
j = j - 1
end do
v(j+1) = key
end do
end subroutine sort_real_inplace
subroutine compute_stats(vals,mean_v,std_v,median_v,p10_v,p90_v,min_v,max_v)
real(psb_dpk_), intent(in) :: vals(:)
real(psb_dpk_), intent(out) :: mean_v,std_v,median_v,p10_v,p90_v,min_v,max_v
real(psb_dpk_), allocatable :: tmp(:)
integer(psb_ipk_) :: n, idx10, idx90
n = size(vals)
if (n <= 0) then
mean_v = dzero; std_v = dzero; median_v = dzero
p10_v = dzero; p90_v = dzero; min_v = dzero; max_v = dzero
return
end if
mean_v = sum(vals)/real(n,psb_dpk_)
if (n > 1) then
std_v = sqrt(sum((vals-mean_v)**2)/real(n-1,psb_dpk_))
else
std_v = dzero
end if
allocate(tmp(n))
tmp = vals
call sort_real_inplace(tmp)
if (mod(n,2) == 0) then
median_v = (tmp(n/2)+tmp(n/2+1))/2.0_psb_dpk_
else
median_v = tmp((n+1)/2)
end if
idx10 = int(ceiling(0.10_psb_dpk_*real(n,psb_dpk_)),kind=psb_ipk_)
idx90 = int(ceiling(0.90_psb_dpk_*real(n,psb_dpk_)),kind=psb_ipk_)
idx10 = max(1_psb_ipk_,min(n,idx10))
idx90 = max(1_psb_ipk_,min(n,idx90))
p10_v = tmp(idx10)
p90_v = tmp(idx90)
min_v = tmp(1)
max_v = tmp(n)
deallocate(tmp)
end subroutine compute_stats
function b1(x,y,z) result(val) function b1(x,y,z) result(val)
real(psb_dpk_), intent(in) :: x,y,z real(psb_dpk_), intent(in) :: x,y,z
real(psb_dpk_) :: val real(psb_dpk_) :: val

8
test/comm/spmv/psb_spmv_overlap_test.f90
Unescape Escape View File

@ -8,7 +8,7 @@ module psb_spmv_overlap_test
use psb_base_mod use psb_base_mod
use psb_util_mod use psb_util_mod
use psb_comm_factory_mod, only: psb_comm_init use psb_comm_factory_mod, only: psb_comm_set
use psb_comm_schemes_mod, only: psb_comm_isend_irecv_, psb_comm_ineighbor_alltoallv_, & use psb_comm_schemes_mod, only: psb_comm_isend_irecv_, psb_comm_ineighbor_alltoallv_, &
& psb_comm_persistent_ineighbor_alltoallv_ & psb_comm_persistent_ineighbor_alltoallv_
@ -584,11 +584,11 @@ contains
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
! Set communication schemes on the x vectors used by psb_spmm. ! Set communication schemes on the x vectors used by psb_spmm.
call psb_comm_init(psb_comm_isend_irecv_, x_baseline%v%comm_handle, info) call psb_comm_set(psb_comm_isend_irecv_, x_baseline%v%comm_handle, info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
call psb_comm_init(psb_comm_ineighbor_alltoallv_, x_neighbor%v%comm_handle, info) call psb_comm_set(psb_comm_ineighbor_alltoallv_, x_neighbor%v%comm_handle, info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
call psb_comm_init(psb_comm_persistent_ineighbor_alltoallv_, x_persistent%v%comm_handle, info) call psb_comm_set(psb_comm_persistent_ineighbor_alltoallv_, x_persistent%v%comm_handle, info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
! Warm-up all schemes once. ! Warm-up all schemes once.

16
test/comm/swapdata/psb_comm_test.F90
Unescape Escape View File

@ -18,7 +18,7 @@
program psb_comm_test program psb_comm_test
use psb_base_mod use psb_base_mod
use psi_mod use psi_mod
use psb_comm_factory_mod, only: psb_comm_init, psb_comm_free use psb_comm_factory_mod, only: psb_comm_set, psb_comm_free
use psb_comm_schemes_mod, only: psb_comm_ineighbor_alltoallv_, psb_comm_persistent_ineighbor_alltoallv_, & use psb_comm_schemes_mod, only: psb_comm_ineighbor_alltoallv_, psb_comm_persistent_ineighbor_alltoallv_, &
& psb_comm_isend_irecv_ & psb_comm_isend_irecv_
use psb_comm_schemes_mod, only: psb_comm_status_start_, psb_comm_status_wait_, psb_comm_status_unknown_ use psb_comm_schemes_mod, only: psb_comm_status_start_, psb_comm_status_wait_, psb_comm_status_unknown_
@ -219,9 +219,9 @@ program psb_comm_test
! ================================================================== ! ==================================================================
! 7. Neighbor topology halo exchange (start + wait) ! 7. Neighbor topology halo exchange (start + wait)
! ================================================================== ! ==================================================================
call psb_comm_init(psb_comm_ineighbor_alltoallv_, v_neighbor%v%comm_handle, info) call psb_comm_set(psb_comm_ineighbor_alltoallv_, v_neighbor%v%comm_handle, info)
if (info /= 0) then if (info /= 0) then
write(psb_err_unit,*) my_rank, 'psb_comm_init neighbor error:', info write(psb_err_unit,*) my_rank, 'psb_comm_set neighbor error:', info
call psb_abort(ctxt) call psb_abort(ctxt)
end if end if
call psi_swapdata(psb_comm_status_start_, dzero, v_neighbor%v, desc_a, info, data=psb_comm_halo_) call psi_swapdata(psb_comm_status_start_, dzero, v_neighbor%v, desc_a, info, data=psb_comm_halo_)
@ -239,9 +239,9 @@ program psb_comm_test
! ================================================================== ! ==================================================================
! 7b. Persistent-neighbor halo exchange (start + wait) ! 7b. Persistent-neighbor halo exchange (start + wait)
! ================================================================== ! ==================================================================
call psb_comm_init(psb_comm_persistent_ineighbor_alltoallv_, v_neighbor_persistent%v%comm_handle, info) call psb_comm_set(psb_comm_persistent_ineighbor_alltoallv_, v_neighbor_persistent%v%comm_handle, info)
if (info /= 0) then if (info /= 0) then
write(psb_err_unit,*) my_rank, 'psb_comm_init persistent-neighbor error:', info write(psb_err_unit,*) my_rank, 'psb_comm_set persistent-neighbor error:', info
call psb_abort(ctxt) call psb_abort(ctxt)
end if end if
call psi_swapdata(psb_comm_status_start_, dzero, v_neighbor_persistent%v, desc_a, info, data=psb_comm_halo_) call psi_swapdata(psb_comm_status_start_, dzero, v_neighbor_persistent%v, desc_a, info, data=psb_comm_halo_)
@ -266,9 +266,9 @@ program psb_comm_test
tsum_neighbor = 0.0_psb_dpk_ tsum_neighbor = 0.0_psb_dpk_
tsum_neighbor_persistent = 0.0_psb_dpk_ tsum_neighbor_persistent = 0.0_psb_dpk_
call psb_comm_init(psb_comm_isend_irecv_, v_baseline%v%comm_handle, info) call psb_comm_set(psb_comm_isend_irecv_, v_baseline%v%comm_handle, info)
call psb_comm_init(psb_comm_ineighbor_alltoallv_, v_neighbor%v%comm_handle, info) call psb_comm_set(psb_comm_ineighbor_alltoallv_, v_neighbor%v%comm_handle, info)
call psb_comm_init(psb_comm_persistent_ineighbor_alltoallv_, v_neighbor_persistent%v%comm_handle, info) call psb_comm_set(psb_comm_persistent_ineighbor_alltoallv_, v_neighbor_persistent%v%comm_handle, info)
! ---- Comm check: verify selected communication schemes ---- ! ---- Comm check: verify selected communication schemes ----
n_total = n_total + 1 n_total = n_total + 1

2
test/pdegen/psb_d_pde3d.F90
Unescape Escape View File

@ -837,7 +837,7 @@ program psb_d_pde3d
& err=err,itrace=itrace,& & err=err,itrace=itrace,&
& istop=istopc) & istop=istopc)
case('BICGSTAB','BICGSTABL','BICG','CG','CGS','FCG','GCR','RGMRES') case('BICGSTAB','BICGSTABL','BICG','CG','CGS','FCG','GCR','RGMRES')
call psb_comm_init(psb_comm_persistent_ineighbor_alltoallv_,xxv%v%comm_handle,info) call psb_comm_set(psb_comm_persistent_ineighbor_alltoallv_,xxv%v%comm_handle,info)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='comm init' ch_err='comm init'

2
test/pdegen/runs/psb_pde3d.inp
Unescape Escape View File

@ -1,6 +1,6 @@
17 Number of entries below this 17 Number of entries below this
BICGSTAB Iterative method BICGSTAB CGS BICG BICGSTABL RGMRES FCG CGR RICHARDSON BICGSTAB Iterative method BICGSTAB CGS BICG BICGSTABL RGMRES FCG CGR RICHARDSON
BJAC Preconditioner NONE DIAG BJAC DIAG Preconditioner NONE DIAG BJAC
CSR Storage format for matrix A: CSR COO CSR Storage format for matrix A: CSR COO
100 Domain size (acutal system is this**3 (pde3d) ) 100 Domain size (acutal system is this**3 (pde3d) )
3 Partition: 1 BLOCK 3 3D 3 Partition: 1 BLOCK 3 3D

Write Preview
Loading…
Cancel
Save