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

[ADD] Added single point of comm_scheme selection on descriptor

Browse Source
communication_v2
Stack-1 15 hours ago
parent 29248d366f
commit 2c65c50593
17 changed files with 304 additions and 173 deletions
Show Stats Download Patch File Download Diff File

56
base/comm/internals/psi_cswapdata.F90
Unescape Escape View File

@ -118,11 +118,14 @@ contains
! error handling variables
integer(psb_ipk_) :: err_act
character(len=30) :: name
logical :: debug
info = psb_success_
name = 'psi_cswapdata_vect'
call psb_erractionsave(err_act)
debug = .false.
ctxt = desc_a%get_context()
call psb_info(ctxt,my_rank,np)
@ -159,7 +162,7 @@ contains
end if
if (.not. allocated(y%comm_handle)) then
call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info)
call psb_comm_set(desc_a%comm_type, y%comm_handle, info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline')
goto 9999
@ -173,7 +176,9 @@ contains
goto 9999
end if
if(debug .eqv. .true.) then
write(0,'(a,i0,a,i0)') 'DBG_DISPATCH comm_type=',y%comm_handle%comm_type,' desc_a%comm_type=',desc_a%comm_type
endif
select case(y%comm_handle%comm_type)
case(psb_comm_isend_irecv_)
call psi_cswap_baseline_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info)
@ -620,15 +625,15 @@ contains
if (debug) write(*,*) my_rank,' nbr_vect: posting MPI_Ineighbor_alltoallv'
if (buffer_size > 0) then
call mpi_ineighbor_alltoallv( &
& y%combuf(1), & ! send buffer
& n*neighbor_comm_handle%send_counts, &
& n*neighbor_comm_handle%send_displs, &
& psb_mpi_r_dpk_, &
& y%combuf(1), & ! recv buffer (baseline layout)
& neighbor_comm_handle%recv_counts, &
& neighbor_comm_handle%recv_displs, &
& psb_mpi_r_dpk_, &
& neighbor_comm_handle%graph_comm, &
& y%combuf(1), & ! send buffer (baseline/positional layout)
& neighbor_comm_handle%send_counts, &
& neighbor_comm_handle%send_displs_v, & ! positional displacements (match gth layout)
& psb_mpi_r_spk_, &
& y%combuf(1), & ! recv buffer (baseline/positional layout)
& neighbor_comm_handle%recv_counts, &
& neighbor_comm_handle%recv_displs_v, & ! positional displacements (match sct layout)
& psb_mpi_r_spk_, &
& neighbor_comm_handle%graph_comm, &
& neighbor_comm_handle%comm_request, iret)
if (iret /= mpi_success) then
info = psb_err_mpi_error_
@ -756,6 +761,7 @@ contains
integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n
info = psb_success_
debug = .false.
name = 'psi_cswap_neighbor_persistent_topology_vect'
call psb_erractionsave(err_act)
call psb_info(ctxt,my_rank,np)
@ -825,12 +831,12 @@ contains
neighbor_comm_handle%persistent_in_flight = .false.
neighbor_comm_handle%persistent_buffer_size = 0
end if
call y%new_buffer(buffer_size, info)
call y%new_buffer(ione*size(comm_indexes%v), info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_, name)
goto 9999
end if
else if (size(y%combuf) < buffer_size) then
else if (size(y%combuf) < ione*size(comm_indexes%v)) then
if (neighbor_comm_handle%persistent_request_ready) then
if (neighbor_comm_handle%persistent_request /= mpi_request_null) then
call mpi_request_free(neighbor_comm_handle%persistent_request, iret)
@ -840,7 +846,7 @@ contains
neighbor_comm_handle%persistent_in_flight = .false.
neighbor_comm_handle%persistent_buffer_size = 0
end if
call y%new_buffer(buffer_size, info)
call y%new_buffer(ione*size(comm_indexes%v), info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_, name)
goto 9999
@ -882,16 +888,16 @@ contains
if (buffer_size > 0) then
if (debug) write(*,*) my_rank,' nbr_vect: posting MPI_Neighbor_alltoallv_init'
call mpi_neighbor_alltoallv_init( &
& y%combuf(1), & ! send buffer
& neighbor_comm_handle%send_counts, &
& neighbor_comm_handle%send_displs, &
& psb_mpi_r_dpk_, &
& y%combuf(1), & ! recv buffer (baseline layout)
& neighbor_comm_handle%recv_counts, &
& neighbor_comm_handle%recv_displs, &
& psb_mpi_r_dpk_, &
& neighbor_comm_handle%graph_comm, &
& mpi_info_null, &
& y%combuf(1), & ! send buffer
& neighbor_comm_handle%send_counts, &
& neighbor_comm_handle%send_displs_v, & ! positional (baseline layout)
& psb_mpi_r_dpk_, &
& y%combuf(1), & ! recv buffer (baseline layout)
& neighbor_comm_handle%recv_counts, &
& neighbor_comm_handle%recv_displs_v, & ! positional (baseline layout)
& psb_mpi_r_dpk_, &
& neighbor_comm_handle%graph_comm, &
& mpi_info_null, &
& neighbor_comm_handle%persistent_request, iret)
if (iret /= mpi_success) then
info = psb_err_mpi_error_
@ -1559,7 +1565,7 @@ contains
end if
if (.not. allocated(y%comm_handle)) then
call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info)
call psb_comm_set(desc_a%comm_type, y%comm_handle, info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline')
goto 9999

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

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

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

@ -118,11 +118,14 @@ contains
! error handling variables
integer(psb_ipk_) :: err_act
character(len=30) :: name
logical :: debug
info = psb_success_
name = 'psi_dswapdata_vect'
call psb_erractionsave(err_act)
debug = .false.
ctxt = desc_a%get_context()
call psb_info(ctxt,my_rank,np)
@ -159,7 +162,7 @@ contains
end if
if (.not. allocated(y%comm_handle)) then
call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info)
call psb_comm_set(desc_a%comm_type, y%comm_handle, info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline')
goto 9999
@ -173,7 +176,9 @@ contains
goto 9999
end if
if(debug .eqv. .true.) then
write(0,'(a,i0,a,i0)') 'DBG_DISPATCH comm_type=',y%comm_handle%comm_type,' desc_a%comm_type=',desc_a%comm_type
endif
select case(y%comm_handle%comm_type)
case(psb_comm_isend_irecv_)
call psi_dswap_baseline_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info)
@ -620,15 +625,15 @@ contains
if (debug) write(*,*) my_rank,' nbr_vect: posting MPI_Ineighbor_alltoallv'
if (buffer_size > 0) then
call mpi_ineighbor_alltoallv( &
& y%combuf(1), & ! send buffer
& n*neighbor_comm_handle%send_counts, &
& n*neighbor_comm_handle%send_displs, &
& psb_mpi_r_dpk_, &
& y%combuf(1), & ! recv buffer (baseline layout)
& neighbor_comm_handle%recv_counts, &
& neighbor_comm_handle%recv_displs, &
& psb_mpi_r_dpk_, &
& neighbor_comm_handle%graph_comm, &
& y%combuf(1), & ! send buffer (baseline/positional layout)
& neighbor_comm_handle%send_counts, &
& neighbor_comm_handle%send_displs_v, & ! positional displacements (match gth layout)
& psb_mpi_r_dpk_, &
& y%combuf(1), & ! recv buffer (baseline/positional layout)
& neighbor_comm_handle%recv_counts, &
& neighbor_comm_handle%recv_displs_v, & ! positional displacements (match sct layout)
& psb_mpi_r_dpk_, &
& neighbor_comm_handle%graph_comm, &
& neighbor_comm_handle%comm_request, iret)
if (iret /= mpi_success) then
info = psb_err_mpi_error_
@ -756,6 +761,7 @@ contains
integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n
info = psb_success_
debug = .false.
name = 'psi_dswap_neighbor_persistent_topology_vect'
call psb_erractionsave(err_act)
call psb_info(ctxt,my_rank,np)
@ -825,12 +831,12 @@ contains
neighbor_comm_handle%persistent_in_flight = .false.
neighbor_comm_handle%persistent_buffer_size = 0
end if
call y%new_buffer(buffer_size, info)
call y%new_buffer(ione*size(comm_indexes%v), info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_, name)
goto 9999
end if
else if (size(y%combuf) < buffer_size) then
else if (size(y%combuf) < ione*size(comm_indexes%v)) then
if (neighbor_comm_handle%persistent_request_ready) then
if (neighbor_comm_handle%persistent_request /= mpi_request_null) then
call mpi_request_free(neighbor_comm_handle%persistent_request, iret)
@ -840,7 +846,7 @@ contains
neighbor_comm_handle%persistent_in_flight = .false.
neighbor_comm_handle%persistent_buffer_size = 0
end if
call y%new_buffer(buffer_size, info)
call y%new_buffer(ione*size(comm_indexes%v), info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_, name)
goto 9999
@ -882,16 +888,16 @@ contains
if (buffer_size > 0) then
if (debug) write(*,*) my_rank,' nbr_vect: posting MPI_Neighbor_alltoallv_init'
call mpi_neighbor_alltoallv_init( &
& y%combuf(1), & ! send buffer
& neighbor_comm_handle%send_counts, &
& neighbor_comm_handle%send_displs, &
& psb_mpi_r_dpk_, &
& y%combuf(1), & ! recv buffer (baseline layout)
& neighbor_comm_handle%recv_counts, &
& neighbor_comm_handle%recv_displs, &
& psb_mpi_r_dpk_, &
& neighbor_comm_handle%graph_comm, &
& mpi_info_null, &
& y%combuf(1), & ! send buffer
& neighbor_comm_handle%send_counts, &
& neighbor_comm_handle%send_displs_v, & ! positional (baseline layout)
& psb_mpi_r_dpk_, &
& y%combuf(1), & ! recv buffer (baseline layout)
& neighbor_comm_handle%recv_counts, &
& neighbor_comm_handle%recv_displs_v, & ! positional (baseline layout)
& psb_mpi_r_dpk_, &
& neighbor_comm_handle%graph_comm, &
& mpi_info_null, &
& neighbor_comm_handle%persistent_request, iret)
if (iret /= mpi_success) then
info = psb_err_mpi_error_
@ -1559,7 +1565,7 @@ contains
end if
if (.not. allocated(y%comm_handle)) then
call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info)
call psb_comm_set(desc_a%comm_type, y%comm_handle, info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline')
goto 9999

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

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

56
base/comm/internals/psi_iswapdata.F90
Unescape Escape View File

@ -118,11 +118,14 @@ contains
! error handling variables
integer(psb_ipk_) :: err_act
character(len=30) :: name
logical :: debug
info = psb_success_
name = 'psi_iswapdata_vect'
call psb_erractionsave(err_act)
debug = .false.
ctxt = desc_a%get_context()
call psb_info(ctxt,my_rank,np)
@ -159,7 +162,7 @@ contains
end if
if (.not. allocated(y%comm_handle)) then
call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info)
call psb_comm_set(desc_a%comm_type, y%comm_handle, info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline')
goto 9999
@ -173,7 +176,9 @@ contains
goto 9999
end if
if(debug .eqv. .true.) then
write(0,'(a,i0,a,i0)') 'DBG_DISPATCH comm_type=',y%comm_handle%comm_type,' desc_a%comm_type=',desc_a%comm_type
endif
select case(y%comm_handle%comm_type)
case(psb_comm_isend_irecv_)
call psi_iswap_baseline_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info)
@ -620,15 +625,15 @@ contains
if (debug) write(*,*) my_rank,' nbr_vect: posting MPI_Ineighbor_alltoallv'
if (buffer_size > 0) then
call mpi_ineighbor_alltoallv( &
& y%combuf(1), & ! send buffer
& n*neighbor_comm_handle%send_counts, &
& n*neighbor_comm_handle%send_displs, &
& psb_mpi_r_dpk_, &
& y%combuf(1), & ! recv buffer (baseline layout)
& neighbor_comm_handle%recv_counts, &
& neighbor_comm_handle%recv_displs, &
& psb_mpi_r_dpk_, &
& neighbor_comm_handle%graph_comm, &
& y%combuf(1), & ! send buffer (baseline/positional layout)
& neighbor_comm_handle%send_counts, &
& neighbor_comm_handle%send_displs_v, & ! positional displacements (match gth layout)
& psb_mpi_ipk_, &
& y%combuf(1), & ! recv buffer (baseline/positional layout)
& neighbor_comm_handle%recv_counts, &
& neighbor_comm_handle%recv_displs_v, & ! positional displacements (match sct layout)
& psb_mpi_ipk_, &
& neighbor_comm_handle%graph_comm, &
& neighbor_comm_handle%comm_request, iret)
if (iret /= mpi_success) then
info = psb_err_mpi_error_
@ -756,6 +761,7 @@ contains
integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n
info = psb_success_
debug = .false.
name = 'psi_iswap_neighbor_persistent_topology_vect'
call psb_erractionsave(err_act)
call psb_info(ctxt,my_rank,np)
@ -825,12 +831,12 @@ contains
neighbor_comm_handle%persistent_in_flight = .false.
neighbor_comm_handle%persistent_buffer_size = 0
end if
call y%new_buffer(buffer_size, info)
call y%new_buffer(ione*size(comm_indexes%v), info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_, name)
goto 9999
end if
else if (size(y%combuf) < buffer_size) then
else if (size(y%combuf) < ione*size(comm_indexes%v)) then
if (neighbor_comm_handle%persistent_request_ready) then
if (neighbor_comm_handle%persistent_request /= mpi_request_null) then
call mpi_request_free(neighbor_comm_handle%persistent_request, iret)
@ -840,7 +846,7 @@ contains
neighbor_comm_handle%persistent_in_flight = .false.
neighbor_comm_handle%persistent_buffer_size = 0
end if
call y%new_buffer(buffer_size, info)
call y%new_buffer(ione*size(comm_indexes%v), info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_, name)
goto 9999
@ -882,16 +888,16 @@ contains
if (buffer_size > 0) then
if (debug) write(*,*) my_rank,' nbr_vect: posting MPI_Neighbor_alltoallv_init'
call mpi_neighbor_alltoallv_init( &
& y%combuf(1), & ! send buffer
& neighbor_comm_handle%send_counts, &
& neighbor_comm_handle%send_displs, &
& psb_mpi_r_dpk_, &
& y%combuf(1), & ! recv buffer (baseline layout)
& neighbor_comm_handle%recv_counts, &
& neighbor_comm_handle%recv_displs, &
& psb_mpi_r_dpk_, &
& neighbor_comm_handle%graph_comm, &
& mpi_info_null, &
& y%combuf(1), & ! send buffer
& neighbor_comm_handle%send_counts, &
& neighbor_comm_handle%send_displs_v, & ! positional (baseline layout)
& psb_mpi_r_dpk_, &
& y%combuf(1), & ! recv buffer (baseline layout)
& neighbor_comm_handle%recv_counts, &
& neighbor_comm_handle%recv_displs_v, & ! positional (baseline layout)
& psb_mpi_r_dpk_, &
& neighbor_comm_handle%graph_comm, &
& mpi_info_null, &
& neighbor_comm_handle%persistent_request, iret)
if (iret /= mpi_success) then
info = psb_err_mpi_error_
@ -1559,7 +1565,7 @@ contains
end if
if (.not. allocated(y%comm_handle)) then
call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info)
call psb_comm_set(desc_a%comm_type, y%comm_handle, info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline')
goto 9999

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

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

56
base/comm/internals/psi_lswapdata.F90
Unescape Escape View File

@ -118,11 +118,14 @@ contains
! error handling variables
integer(psb_ipk_) :: err_act
character(len=30) :: name
logical :: debug
info = psb_success_
name = 'psi_lswapdata_vect'
call psb_erractionsave(err_act)
debug = .false.
ctxt = desc_a%get_context()
call psb_info(ctxt,my_rank,np)
@ -159,7 +162,7 @@ contains
end if
if (.not. allocated(y%comm_handle)) then
call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info)
call psb_comm_set(desc_a%comm_type, y%comm_handle, info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline')
goto 9999
@ -173,7 +176,9 @@ contains
goto 9999
end if
if(debug .eqv. .true.) then
write(0,'(a,i0,a,i0)') 'DBG_DISPATCH comm_type=',y%comm_handle%comm_type,' desc_a%comm_type=',desc_a%comm_type
endif
select case(y%comm_handle%comm_type)
case(psb_comm_isend_irecv_)
call psi_lswap_baseline_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info)
@ -620,15 +625,15 @@ contains
if (debug) write(*,*) my_rank,' nbr_vect: posting MPI_Ineighbor_alltoallv'
if (buffer_size > 0) then
call mpi_ineighbor_alltoallv( &
& y%combuf(1), & ! send buffer
& n*neighbor_comm_handle%send_counts, &
& n*neighbor_comm_handle%send_displs, &
& psb_mpi_r_dpk_, &
& y%combuf(1), & ! recv buffer (baseline layout)
& neighbor_comm_handle%recv_counts, &
& neighbor_comm_handle%recv_displs, &
& psb_mpi_r_dpk_, &
& neighbor_comm_handle%graph_comm, &
& y%combuf(1), & ! send buffer (baseline/positional layout)
& neighbor_comm_handle%send_counts, &
& neighbor_comm_handle%send_displs_v, & ! positional displacements (match gth layout)
& psb_mpi_lpk_, &
& y%combuf(1), & ! recv buffer (baseline/positional layout)
& neighbor_comm_handle%recv_counts, &
& neighbor_comm_handle%recv_displs_v, & ! positional displacements (match sct layout)
& psb_mpi_lpk_, &
& neighbor_comm_handle%graph_comm, &
& neighbor_comm_handle%comm_request, iret)
if (iret /= mpi_success) then
info = psb_err_mpi_error_
@ -756,6 +761,7 @@ contains
integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n
info = psb_success_
debug = .false.
name = 'psi_lswap_neighbor_persistent_topology_vect'
call psb_erractionsave(err_act)
call psb_info(ctxt,my_rank,np)
@ -825,12 +831,12 @@ contains
neighbor_comm_handle%persistent_in_flight = .false.
neighbor_comm_handle%persistent_buffer_size = 0
end if
call y%new_buffer(buffer_size, info)
call y%new_buffer(ione*size(comm_indexes%v), info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_, name)
goto 9999
end if
else if (size(y%combuf) < buffer_size) then
else if (size(y%combuf) < ione*size(comm_indexes%v)) then
if (neighbor_comm_handle%persistent_request_ready) then
if (neighbor_comm_handle%persistent_request /= mpi_request_null) then
call mpi_request_free(neighbor_comm_handle%persistent_request, iret)
@ -840,7 +846,7 @@ contains
neighbor_comm_handle%persistent_in_flight = .false.
neighbor_comm_handle%persistent_buffer_size = 0
end if
call y%new_buffer(buffer_size, info)
call y%new_buffer(ione*size(comm_indexes%v), info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_, name)
goto 9999
@ -882,16 +888,16 @@ contains
if (buffer_size > 0) then
if (debug) write(*,*) my_rank,' nbr_vect: posting MPI_Neighbor_alltoallv_init'
call mpi_neighbor_alltoallv_init( &
& y%combuf(1), & ! send buffer
& neighbor_comm_handle%send_counts, &
& neighbor_comm_handle%send_displs, &
& psb_mpi_r_dpk_, &
& y%combuf(1), & ! recv buffer (baseline layout)
& neighbor_comm_handle%recv_counts, &
& neighbor_comm_handle%recv_displs, &
& psb_mpi_r_dpk_, &
& neighbor_comm_handle%graph_comm, &
& mpi_info_null, &
& y%combuf(1), & ! send buffer
& neighbor_comm_handle%send_counts, &
& neighbor_comm_handle%send_displs_v, & ! positional (baseline layout)
& psb_mpi_r_dpk_, &
& y%combuf(1), & ! recv buffer (baseline layout)
& neighbor_comm_handle%recv_counts, &
& neighbor_comm_handle%recv_displs_v, & ! positional (baseline layout)
& psb_mpi_r_dpk_, &
& neighbor_comm_handle%graph_comm, &
& mpi_info_null, &
& neighbor_comm_handle%persistent_request, iret)
if (iret /= mpi_success) then
info = psb_err_mpi_error_
@ -1559,7 +1565,7 @@ contains
end if
if (.not. allocated(y%comm_handle)) then
call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info)
call psb_comm_set(desc_a%comm_type, y%comm_handle, info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline')
goto 9999

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

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

56
base/comm/internals/psi_sswapdata.F90
Unescape Escape View File

@ -118,11 +118,14 @@ contains
! error handling variables
integer(psb_ipk_) :: err_act
character(len=30) :: name
logical :: debug
info = psb_success_
name = 'psi_sswapdata_vect'
call psb_erractionsave(err_act)
debug = .false.
ctxt = desc_a%get_context()
call psb_info(ctxt,my_rank,np)
@ -159,7 +162,7 @@ contains
end if
if (.not. allocated(y%comm_handle)) then
call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info)
call psb_comm_set(desc_a%comm_type, y%comm_handle, info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline')
goto 9999
@ -173,7 +176,9 @@ contains
goto 9999
end if
if(debug .eqv. .true.) then
write(0,'(a,i0,a,i0)') 'DBG_DISPATCH comm_type=',y%comm_handle%comm_type,' desc_a%comm_type=',desc_a%comm_type
endif
select case(y%comm_handle%comm_type)
case(psb_comm_isend_irecv_)
call psi_sswap_baseline_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info)
@ -620,15 +625,15 @@ contains
if (debug) write(*,*) my_rank,' nbr_vect: posting MPI_Ineighbor_alltoallv'
if (buffer_size > 0) then
call mpi_ineighbor_alltoallv( &
& y%combuf(1), & ! send buffer
& n*neighbor_comm_handle%send_counts, &
& n*neighbor_comm_handle%send_displs, &
& psb_mpi_r_dpk_, &
& y%combuf(1), & ! recv buffer (baseline layout)
& neighbor_comm_handle%recv_counts, &
& neighbor_comm_handle%recv_displs, &
& psb_mpi_r_dpk_, &
& neighbor_comm_handle%graph_comm, &
& y%combuf(1), & ! send buffer (baseline/positional layout)
& neighbor_comm_handle%send_counts, &
& neighbor_comm_handle%send_displs_v, & ! positional displacements (match gth layout)
& psb_mpi_r_spk_, &
& y%combuf(1), & ! recv buffer (baseline/positional layout)
& neighbor_comm_handle%recv_counts, &
& neighbor_comm_handle%recv_displs_v, & ! positional displacements (match sct layout)
& psb_mpi_r_spk_, &
& neighbor_comm_handle%graph_comm, &
& neighbor_comm_handle%comm_request, iret)
if (iret /= mpi_success) then
info = psb_err_mpi_error_
@ -756,6 +761,7 @@ contains
integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n
info = psb_success_
debug = .false.
name = 'psi_sswap_neighbor_persistent_topology_vect'
call psb_erractionsave(err_act)
call psb_info(ctxt,my_rank,np)
@ -825,12 +831,12 @@ contains
neighbor_comm_handle%persistent_in_flight = .false.
neighbor_comm_handle%persistent_buffer_size = 0
end if
call y%new_buffer(buffer_size, info)
call y%new_buffer(ione*size(comm_indexes%v), info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_, name)
goto 9999
end if
else if (size(y%combuf) < buffer_size) then
else if (size(y%combuf) < ione*size(comm_indexes%v)) then
if (neighbor_comm_handle%persistent_request_ready) then
if (neighbor_comm_handle%persistent_request /= mpi_request_null) then
call mpi_request_free(neighbor_comm_handle%persistent_request, iret)
@ -840,7 +846,7 @@ contains
neighbor_comm_handle%persistent_in_flight = .false.
neighbor_comm_handle%persistent_buffer_size = 0
end if
call y%new_buffer(buffer_size, info)
call y%new_buffer(ione*size(comm_indexes%v), info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_, name)
goto 9999
@ -882,16 +888,16 @@ contains
if (buffer_size > 0) then
if (debug) write(*,*) my_rank,' nbr_vect: posting MPI_Neighbor_alltoallv_init'
call mpi_neighbor_alltoallv_init( &
& y%combuf(1), & ! send buffer
& neighbor_comm_handle%send_counts, &
& neighbor_comm_handle%send_displs, &
& psb_mpi_r_dpk_, &
& y%combuf(1), & ! recv buffer (baseline layout)
& neighbor_comm_handle%recv_counts, &
& neighbor_comm_handle%recv_displs, &
& psb_mpi_r_dpk_, &
& neighbor_comm_handle%graph_comm, &
& mpi_info_null, &
& y%combuf(1), & ! send buffer
& neighbor_comm_handle%send_counts, &
& neighbor_comm_handle%send_displs_v, & ! positional (baseline layout)
& psb_mpi_r_dpk_, &
& y%combuf(1), & ! recv buffer (baseline layout)
& neighbor_comm_handle%recv_counts, &
& neighbor_comm_handle%recv_displs_v, & ! positional (baseline layout)
& psb_mpi_r_dpk_, &
& neighbor_comm_handle%graph_comm, &
& mpi_info_null, &
& neighbor_comm_handle%persistent_request, iret)
if (iret /= mpi_success) then
info = psb_err_mpi_error_
@ -1559,7 +1565,7 @@ contains
end if
if (.not. allocated(y%comm_handle)) then
call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info)
call psb_comm_set(desc_a%comm_type, y%comm_handle, info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline')
goto 9999

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

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

56
base/comm/internals/psi_zswapdata.F90
Unescape Escape View File

@ -118,11 +118,14 @@ contains
! error handling variables
integer(psb_ipk_) :: err_act
character(len=30) :: name
logical :: debug
info = psb_success_
name = 'psi_zswapdata_vect'
call psb_erractionsave(err_act)
debug = .false.
ctxt = desc_a%get_context()
call psb_info(ctxt,my_rank,np)
@ -159,7 +162,7 @@ contains
end if
if (.not. allocated(y%comm_handle)) then
call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info)
call psb_comm_set(desc_a%comm_type, y%comm_handle, info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline')
goto 9999
@ -173,7 +176,9 @@ contains
goto 9999
end if
if(debug .eqv. .true.) then
write(0,'(a,i0,a,i0)') 'DBG_DISPATCH comm_type=',y%comm_handle%comm_type,' desc_a%comm_type=',desc_a%comm_type
endif
select case(y%comm_handle%comm_type)
case(psb_comm_isend_irecv_)
call psi_zswap_baseline_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info)
@ -620,15 +625,15 @@ contains
if (debug) write(*,*) my_rank,' nbr_vect: posting MPI_Ineighbor_alltoallv'
if (buffer_size > 0) then
call mpi_ineighbor_alltoallv( &
& y%combuf(1), & ! send buffer
& n*neighbor_comm_handle%send_counts, &
& n*neighbor_comm_handle%send_displs, &
& psb_mpi_r_dpk_, &
& y%combuf(1), & ! recv buffer (baseline layout)
& neighbor_comm_handle%recv_counts, &
& neighbor_comm_handle%recv_displs, &
& psb_mpi_r_dpk_, &
& neighbor_comm_handle%graph_comm, &
& y%combuf(1), & ! send buffer (baseline/positional layout)
& neighbor_comm_handle%send_counts, &
& neighbor_comm_handle%send_displs_v, & ! positional displacements (match gth layout)
& psb_mpi_r_dpk_, &
& y%combuf(1), & ! recv buffer (baseline/positional layout)
& neighbor_comm_handle%recv_counts, &
& neighbor_comm_handle%recv_displs_v, & ! positional displacements (match sct layout)
& psb_mpi_r_dpk_, &
& neighbor_comm_handle%graph_comm, &
& neighbor_comm_handle%comm_request, iret)
if (iret /= mpi_success) then
info = psb_err_mpi_error_
@ -756,6 +761,7 @@ contains
integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n
info = psb_success_
debug = .false.
name = 'psi_zswap_neighbor_persistent_topology_vect'
call psb_erractionsave(err_act)
call psb_info(ctxt,my_rank,np)
@ -825,12 +831,12 @@ contains
neighbor_comm_handle%persistent_in_flight = .false.
neighbor_comm_handle%persistent_buffer_size = 0
end if
call y%new_buffer(buffer_size, info)
call y%new_buffer(ione*size(comm_indexes%v), info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_, name)
goto 9999
end if
else if (size(y%combuf) < buffer_size) then
else if (size(y%combuf) < ione*size(comm_indexes%v)) then
if (neighbor_comm_handle%persistent_request_ready) then
if (neighbor_comm_handle%persistent_request /= mpi_request_null) then
call mpi_request_free(neighbor_comm_handle%persistent_request, iret)
@ -840,7 +846,7 @@ contains
neighbor_comm_handle%persistent_in_flight = .false.
neighbor_comm_handle%persistent_buffer_size = 0
end if
call y%new_buffer(buffer_size, info)
call y%new_buffer(ione*size(comm_indexes%v), info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_, name)
goto 9999
@ -882,16 +888,16 @@ contains
if (buffer_size > 0) then
if (debug) write(*,*) my_rank,' nbr_vect: posting MPI_Neighbor_alltoallv_init'
call mpi_neighbor_alltoallv_init( &
& y%combuf(1), & ! send buffer
& neighbor_comm_handle%send_counts, &
& neighbor_comm_handle%send_displs, &
& psb_mpi_r_dpk_, &
& y%combuf(1), & ! recv buffer (baseline layout)
& neighbor_comm_handle%recv_counts, &
& neighbor_comm_handle%recv_displs, &
& psb_mpi_r_dpk_, &
& neighbor_comm_handle%graph_comm, &
& mpi_info_null, &
& y%combuf(1), & ! send buffer
& neighbor_comm_handle%send_counts, &
& neighbor_comm_handle%send_displs_v, & ! positional (baseline layout)
& psb_mpi_r_dpk_, &
& y%combuf(1), & ! recv buffer (baseline layout)
& neighbor_comm_handle%recv_counts, &
& neighbor_comm_handle%recv_displs_v, & ! positional (baseline layout)
& psb_mpi_r_dpk_, &
& neighbor_comm_handle%graph_comm, &
& mpi_info_null, &
& neighbor_comm_handle%persistent_request, iret)
if (iret /= mpi_success) then
info = psb_err_mpi_error_
@ -1559,7 +1565,7 @@ contains
end if
if (.not. allocated(y%comm_handle)) then
call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info)
call psb_comm_set(desc_a%comm_type, y%comm_handle, info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline')
goto 9999

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

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

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

@ -19,6 +19,7 @@ module psb_comm_neighbor_impl_mod
integer(psb_ipk_) :: num_neighbors = 0
integer(psb_mpk_), allocatable :: send_counts(:), recv_counts(:)
integer(psb_mpk_), allocatable :: send_displs(:), recv_displs(:)
integer(psb_mpk_), allocatable :: send_displs_v(:), recv_displs_v(:)
integer(psb_ipk_), allocatable :: send_indexes(:)
integer(psb_ipk_), allocatable :: recv_indexes(:)
integer(psb_ipk_) :: total_send = 0
@ -169,6 +170,20 @@ contains
goto 9999
end if
allocate(topology%send_displs_v(num_neighbors), stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name, a_err='Send vect displacements allocation failed')
goto 9999
end if
allocate(topology%recv_displs_v(num_neighbors), stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name, a_err='Receive vect displacements allocation failed')
goto 9999
end if
! -----------------------------------------------------------
! Allocate the gather/scatter index arrays
@ -219,6 +234,11 @@ contains
topology%recv_counts(i) = int(num_elem_recv, psb_mpk_)
topology%send_displs(i) = int(send_offset, psb_mpk_)
topology%recv_displs(i) = int(recv_offset, psb_mpk_)
! Positional displacements: match the combuf layout used by gthzbuf/sctb_buf
! snd_pt = 1 + position + num_elem_recv + psb_n_elem_send_ → displs = snd_pt - 1
! rcv_pt = 1 + position + psb_n_elem_recv_ → displs = rcv_pt - 1
topology%send_displs_v(i) = int(position + num_elem_recv + psb_n_elem_send_, psb_mpk_)
topology%recv_displs_v(i) = int(position + psb_n_elem_recv_, psb_mpk_)
! Fill recv_indexes from halo_index(position+2 .. position+1+nerv)
do k = 1, num_elem_recv
@ -330,6 +350,8 @@ contains
if (allocated(this%recv_counts)) deallocate(this%recv_counts)
if (allocated(this%send_displs)) deallocate(this%send_displs)
if (allocated(this%recv_displs)) deallocate(this%recv_displs)
if (allocated(this%send_displs_v)) deallocate(this%send_displs_v)
if (allocated(this%recv_displs_v)) deallocate(this%recv_displs_v)
if (allocated(this%send_indexes)) deallocate(this%send_indexes)
if (allocated(this%recv_indexes)) deallocate(this%recv_indexes)
@ -357,6 +379,8 @@ contains
if (allocated(this%recv_counts)) val = val + psb_sizeof_ip * size(this%recv_counts)
if (allocated(this%send_displs)) val = val + psb_sizeof_ip * size(this%send_displs)
if (allocated(this%recv_displs)) val = val + psb_sizeof_ip * size(this%recv_displs)
if (allocated(this%send_displs_v)) val = val + psb_sizeof_ip * size(this%send_displs_v)
if (allocated(this%recv_displs_v)) val = val + psb_sizeof_ip * size(this%recv_displs_v)
if (allocated(this%send_indexes)) val = val + psb_sizeof_ip * size(this%send_indexes)
if (allocated(this%recv_indexes)) val = val + psb_sizeof_ip * size(this%recv_indexes)

15
base/modules/desc/psb_desc_mod.F90
Unescape Escape View File

@ -40,6 +40,7 @@ module psb_desc_mod
use psb_desc_const_mod
use psb_indx_map_mod
use psb_i_vect_mod
use psb_comm_schemes_mod, only: psb_comm_isend_irecv_
implicit none
@ -216,6 +217,7 @@ module psb_desc_mod
integer(psb_ipk_), allocatable :: lprm(:)
type(psb_desc_type), pointer :: base_desc => null()
integer(psb_ipk_), allocatable :: idx_space(:)
integer(psb_ipk_) :: comm_type = psb_comm_isend_irecv_
contains
procedure, pass(desc) :: is_ok => psb_is_ok_desc
procedure, pass(desc) :: is_valid => psb_is_valid_desc
@ -268,7 +270,7 @@ module psb_desc_mod
procedure, pass(desc) :: g2lv2_ins => cd_g2lv2_ins
generic, public :: g2l_ins => g2ls2_ins, g2lv2_ins
generic, public :: g2lip_ins => g2ls1_ins, g2lv1_ins
procedure, pass(desc) :: set_comm_scheme => psb_desc_set_comm_scheme
end type psb_desc_type
@ -312,7 +314,16 @@ module psb_desc_mod
integer(psb_lpk_), private, save :: cd_hash_threshold = psb_default_hash_threshold
integer(psb_ipk_), private, save :: sp_a2av_alg = psb_sp_a2av_smpl_triad_
contains
contains
subroutine psb_desc_set_comm_scheme(desc, comm_type, info)
implicit none
class(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_), intent(in) :: comm_type
integer(psb_ipk_), intent(out) :: info
info = psb_success_
desc%comm_type = comm_type
end subroutine psb_desc_set_comm_scheme
function psb_m_get_sp_a2av_alg() result(val)
implicit none

12
base/psblas/psb_dspmm.f90
Unescape Escape View File

@ -172,11 +172,8 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,&
!if (me==0) write(0,*) 'going for overlap ',a%ad%get_fmt(),' ',a%and%get_fmt()
if (do_timings) call psb_barrier(ctxt)
if (do_timings) call psb_tic(mv_phase1)
if (doswap_) then
call psi_swapdata(psb_comm_status_start_, dzero, x%v, desc_a, info, data=psb_comm_halo_)
else
call psi_swapdata(psb_comm_status_sync_, dzero, x%v, desc_a, info, data=psb_comm_halo_)
end if
if (doswap_) call psi_swapdata(psb_swap_send_,&
& dzero,x%v,desc_a,info,data=psb_comm_halo_)
if (do_timings) call psb_toc(mv_phase1)
if (do_timings) call psb_tic(mv_phase2)
call a%ad%spmm(alpha,x%v,beta,y%v,info)
@ -196,7 +193,10 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,&
if (do_timings) call psb_barrier(ctxt)
if (do_timings) call psb_tic(mv_phase11)
call psi_swapdata(psb_comm_status_sync_, dzero, x%v, desc_a, info, data=psb_comm_halo_)
if (doswap_) then
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& dzero,x%v,desc_a,info,data=psb_comm_halo_)
end if
if (do_timings) call psb_toc(mv_phase11)
if (do_timings) call psb_tic(mv_phase12)
call psb_csmm(alpha,a,x,beta,y,info)

39
base/tools/psb_dspasb.f90
Unescape Escape View File

@ -184,7 +184,44 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, mold, dupl, bld_and)
end if
if (bld_and_) then
call a%split_nd(n_row,n_col,info)
!!$ allocate(a%ad,mold=a%a)
!!$ allocate(a%and,mold=a%a)o
!!$ call a%split_nd(n_row,n_col,info)
!!$ block
!!$ character(len=1024) :: fname
!!$ type(psb_d_coo_sparse_mat) :: acoo
!!$ type(psb_d_csr_sparse_mat), allocatable :: aclip
!!$ type(psb_d_ecsr_sparse_mat), allocatable :: andclip
!!$ logical, parameter :: use_ecsr=.true.
!!$ allocate(aclip)
!!$ call a%a%csclip(acoo,info,jmax=n_row,rscale=.false.,cscale=.false.)
!!$ allocate(a%ad,mold=a%a)
!!$ call a%ad%mv_from_coo(acoo,info)
!!$ call a%a%csclip(acoo,info,jmin=n_row+1,jmax=n_col,rscale=.false.,cscale=.false.)
!!$ if (use_ecsr) then
!!$ allocate(andclip)
!!$ call andclip%mv_from_coo(acoo,info)
!!$ call move_alloc(andclip,a%and)
!!$ else
!!$ allocate(a%and,mold=a%a)
!!$ call a%and%mv_from_coo(acoo,info)
!!$ end if
!!$ if (.false.) then
!!$ write(fname,'(a,i2.2,a)') 'adclip_',me,'.mtx'
!!$ open(25,file=fname)
!!$ call a%ad%print(25)
!!$ close(25)
!!$ write(fname,'(a,i2.2,a)') 'andclip_',me,'.mtx'
!!$ open(25,file=fname)
!!$ call a%and%print(25)
!!$ close(25)
!!$ !call andclip%set_cols(n_col)
!!$ write(*,*) me,' ',trim(name),' ad ',&
!!$ &a%ad%get_nrows(),a%ad%get_ncols(),n_row,n_col
!!$ write(*,*) me,' ',trim(name),' and ',&
!!$ &a%and%get_nrows(),a%and%get_ncols(),n_row,n_col
!!$ end if
!!$ end block
else
if (allocated(a%ad)) deallocate(a%ad)
if (allocated(a%and)) deallocate(a%and)

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

@ -7,7 +7,8 @@ program psb_comm_cg_test
use psb_prec_mod
use psb_linsolve_mod
use psb_comm_factory_mod
use psb_comm_neighbor_impl_mod, only: psb_comm_neighbor_handle
use psb_comm_schemes_mod, only: psb_comm_isend_irecv_, psb_comm_ineighbor_alltoallv_, &
& psb_comm_persistent_ineighbor_alltoallv_, psb_comm_rma_pull_, psb_comm_rma_push_
use, intrinsic :: ieee_arithmetic
implicit none
@ -205,7 +206,14 @@ program psb_comm_cg_test
do scheme_idx = 1, n_schemes
do rep = 1, nrep
t_start = psb_wtime()
call psb_comm_set(scheme_type(scheme_idx),x%v%comm_handle,info)
! Set default scheme on the descriptor: all vectors that lazy-init during
! this solve (including internal CG vectors r, p, q, z) will use this scheme.
call desc_a%set_comm_scheme(scheme_type(scheme_idx), info)
if (info /= psb_success_) goto 9999
! Free x comm_handle so it also re-initializes from desc_a%comm_type
! (it may already be allocated from a previous rep).
if (allocated(x%v%comm_handle)) call psb_comm_free(x%v%comm_handle, info)
if (info /= psb_success_) goto 9999
comm_set_time(prec_idx,scheme_idx,rep) = psb_wtime() - t_start
call psb_geaxpby(dzero,b,dzero,x,desc_a,info)
@ -257,6 +265,21 @@ program psb_comm_cg_test
if (info /= psb_success_) goto 9999
! Verify x used the descriptor scheme (lazy init should have fired during CG).
if (allocated(x%v%comm_handle)) then
if (x%v%comm_handle%comm_type /= scheme_type(scheme_idx)) then
if (my_rank == psb_root_) &
write(psb_err_unit,'("SCHEME MISMATCH rank=",i0," expected=",i0," got=",i0)') &
my_rank, scheme_type(scheme_idx), x%v%comm_handle%comm_type
info = psb_err_internal_error_
goto 9999
else
if (my_rank == psb_root_ .and. rep == 1) &
write(psb_out_unit,'(" [OK] x comm_handle matches scheme: ",a)') &
trim(scheme_name(scheme_idx))
end if
end if
call psb_geaxpby(dzero,b,dzero,x,desc_a,info)
if (info /= psb_success_) goto 9999

Write Preview
Loading…
Cancel
Save