fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-20 12:52:14 +00:00
Code Issues Packages Projects Releases Wiki Activity

[FIX] Fixed compilation for psi_dswapdata routine

Browse Source
This commit is contained in:
Stack-1
2026-03-17 11:02:16 +01:00
parent 4ee8b847e0
commit e7e8a69373
13 changed files with 2913 additions and 739 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/modules/Makefile
+3 -3
View File
@@ -28,6 +28,7 @@ COMMINT= penv/psi_penv_mod.o \
SERIAL_MODS=serial/psb_s_serial_mod.o serial/psb_d_serial_mod.o \
serial/psb_c_serial_mod.o serial/psb_z_serial_mod.o \
serial/psb_serial_mod.o \
comm/psb_neighbor_topology_mod.o \
serial/psb_i_base_vect_mod.o serial/psb_i_vect_mod.o\
serial/psb_l_base_vect_mod.o serial/psb_l_vect_mod.o\
serial/psb_d_base_vect_mod.o serial/psb_d_vect_mod.o\
@@ -181,6 +182,7 @@ auxil/psb_string_mod.o auxil/psb_m_realloc_mod.o auxil/psb_e_realloc_mod.o auxil
auxil/psb_d_realloc_mod.o auxil/psb_c_realloc_mod.o auxil/psb_z_realloc_mod.o \
desc/psb_desc_const_mod.o psi_penv_mod.o: psb_const_mod.o
comm/psb_neighbor_topology_mod.o: psb_const_mod.o desc/psb_desc_const_mod.o
desc/psb_indx_map_mod.o desc/psb_hash_mod.o: psb_realloc_mod.o psb_const_mod.o desc/psb_desc_const_mod.o
auxil/psb_i_sort_mod.o auxil/psb_s_sort_mod.o auxil/psb_d_sort_mod.o auxil/psb_c_sort_mod.o auxil/psb_z_sort_mod.o \
@@ -261,7 +263,7 @@ serial/psb_d_base_mat_mod.o: serial/psb_d_base_vect_mod.o
serial/psb_c_base_mat_mod.o: serial/psb_c_base_vect_mod.o
serial/psb_z_base_mat_mod.o: serial/psb_z_base_vect_mod.o
serial/psb_l_base_vect_mod.o: serial/psb_i_base_vect_mod.o
serial/psb_c_base_vect_mod.o serial/psb_s_base_vect_mod.o serial/psb_d_base_vect_mod.o serial/psb_z_base_vect_mod.o: serial/psb_i_base_vect_mod.o serial/psb_l_base_vect_mod.o
serial/psb_c_base_vect_mod.o serial/psb_s_base_vect_mod.o serial/psb_d_base_vect_mod.o serial/psb_z_base_vect_mod.o: serial/psb_i_base_vect_mod.o serial/psb_l_base_vect_mod.o comm/psb_neighbor_topology_mod.o
serial/psb_i_base_vect_mod.o serial/psb_l_base_vect_mod.o serial/psb_c_base_vect_mod.o serial/psb_s_base_vect_mod.o serial/psb_d_base_vect_mod.o serial/psb_z_base_vect_mod.o: auxil/psi_serial_mod.o psb_realloc_mod.o
serial/psb_s_mat_mod.o: serial/psb_s_base_mat_mod.o serial/psb_s_csr_mat_mod.o serial/psb_s_csc_mat_mod.o serial/psb_s_vect_mod.o \
serial/psb_i_vect_mod.o serial/psb_l_vect_mod.o
@@ -368,8 +370,6 @@ comm/psi_e_comm_a_mod.o comm/psi_m_comm_a_mod.o \
comm/psi_s_comm_a_mod.o comm/psi_d_comm_a_mod.o \
comm/psi_c_comm_a_mod.o comm/psi_z_comm_a_mod.o: desc/psb_desc_mod.o
tools/psb_tools_mod.o: tools/psb_cd_tools_mod.o tools/psb_s_tools_mod.o tools/psb_d_tools_mod.o\
tools/psb_i_tools_mod.o tools/psb_l_tools_mod.o \
tools/psb_c_tools_mod.o tools/psb_z_tools_mod.o \
base/modules/comm/psb_neighbor_topology_mod.F90
+422
View File
@@ -0,0 +1,422 @@
!
! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018
! Salvatore Filippone
! Alfredo Buttari
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
! Module: psb_neighbor_topology_mod
! Provides a type to hold pre-built MPI neighborhood topology
! information for persistent/repeated halo exchanges via
! MPI_Neighbor_alltoallv (MPI >= 3.0).
!
! The topology is stored inside the vector type (psb_d_base_vect_type)
! and lazily created on the first psi_swapdata call with the
! neighbor-alltoallv communication mode. Once built it is reused
! for every subsequent halo exchange, avoiding the per-call overhead
! of re-scanning the index list and allocating temporary arrays.
!
! The graph communicator and per-neighbor counts/displacements
! are built once and reused.
!
! The gather/scatter index arrays (send_indexes, recv_indexes) record
! which local vector positions must be packed / unpacked.
!
module psb_neighbor_topology_mod
use psb_const_mod
use psb_desc_const_mod
use psb_error_mod
!
! Only import mpi_comm_null here (needed for type default initializer).
! Full MPI access is done inside each contained subroutine so that
! MPI symbols do NOT leak into modules that use psb_neighbor_topology_mod.
!
#ifdef PSB_MPI_MOD
use mpi, only: mpi_comm_null
#endif
implicit none
#ifdef PSB_MPI_H
include 'mpif.h'
#endif
type :: psb_neighbor_topology_type
!
! MPI dist-graph communicator (only communicating neighbors).
!
integer(psb_mpk_) :: graph_comm = mpi_comm_null
!
! Number of neighbors (processes I exchange with, excluding self).
!
integer(psb_ipk_) :: num_neighbors = 0
!
! Per-neighbor send/recv counts and displacements (units of
! single elements; for n-column multivectors multiply by n).
! send_counts(i) = number of elements sent to i-th neighbor
! recv_counts(i) = number of elements received from i-th neighbor
! send_displs(i) = displacement into contiguous send buffer
! recv_displs(i) = displacement into contiguous recv buffer
!
integer(psb_mpk_), allocatable :: send_counts(:), recv_counts(:)
integer(psb_mpk_), allocatable :: send_displs(:), recv_displs(:)
!
! Gather indexes: the k-th element of the send buffer is
! y%v( send_indexes(k) )
! Scatter indexes: the k-th element of the recv buffer goes to
! y%v( recv_indexes(k) )
!
integer(psb_ipk_), allocatable :: send_indexes(:)
integer(psb_ipk_), allocatable :: recv_indexes(:)
!
! Total number of elements to send / receive (per single column),
! excluding self-exchange.
!
integer(psb_ipk_) :: total_send = 0
integer(psb_ipk_) :: total_recv = 0
!
! Initialization flag.
!
logical :: is_initialized = .false.
contains
procedure, pass(topology) :: init => neighbor_topology_init
procedure, pass(topology) :: free => neighbor_topology_free
procedure, pass(topology) :: sizeof => neighbor_topology_sizeof
end type psb_neighbor_topology_type
contains
! ---------------------------------------------------------------
! neighbor_topology_init
!
! Parse the halo index list (obtained via desc_a%get_list_p)
! and build:
! - MPI dist-graph communicator with only the true neighbors
! - per-neighbor send/recv counts and displacements
! - contiguous gather/scatter index arrays
!
! The topology is stored inside the vector and lazily built
! on the first psi_swapdata call that uses the neighbor-alltoallv
! communication mode.
!
! Arguments:
! topology - the persistent state (output, intent inout)
! halo_index - halo_index array (from get_list_p, intent in)
! num_neighbors - number of exchanges (from get_list_p)
! total_send_elems - total send count (from get_list_p)
! total_recv_elems - total recv count (from get_list_p)
! ctxt - PSBLAS context
! icomm - MPI communicator
! info - error code (output)
! ---------------------------------------------------------------
subroutine neighbor_topology_init(topology, halo_index, num_neighbors, &
& total_send_elems, total_recv_elems, ctxt, icomm, info)
#ifdef PSB_MPI_MOD
use mpi
#endif
implicit none
#ifdef PSB_MPI_H
include 'mpif.h'
#endif
class(psb_neighbor_topology_type), intent(inout) :: topology
integer(psb_ipk_), intent(in) :: halo_index(:)
integer(psb_ipk_), intent(in) :: num_neighbors, total_send_elems, total_recv_elems
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_mpk_) :: iret
integer(psb_ipk_) :: i, k, idx_ptr, num_elem_recv, num_elem_send, partner_proc
integer(psb_ipk_) :: neighbor_count, send_offset, recv_offset
integer(psb_mpk_), allocatable :: source_ranks(:), dest_ranks(:)
integer(psb_mpk_), allocatable :: source_weights(:), dest_weights(:)
integer(psb_mpk_) :: in_degree, out_degree
character(len=40) :: name
integer(psb_ipk_) :: proc_id
integer(psb_ipk_) :: position
integer(psb_ipk_) :: err_act
info = psb_success_
name = 'neighbor_topology_init'
call psb_erractionsave(err_act)
! Clean up any previous state
call topology%free(info)
! ----------------------------------------------------------
! First pass: count neighbors (excluding self) and totals
! ----------------------------------------------------------
topology%num_neighbors = 0
topology%total_send = 0
topology%total_recv = 0
if(size(halo_index) < 1) then
call psb_errpush(psb_err_topology_invalid_args_,name)
goto 9999
end if
allocate(source_ranks(num_neighbors), stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name, a_err='Source ranks allocation failed')
goto 9999
end if
allocate(dest_ranks(num_neighbors), stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name, a_err='Destination ranks allocation failed')
goto 9999
end if
allocate(source_weights(num_neighbors), stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name, a_err='Source weights allocation failed')
goto 9999
end if
allocate(dest_weights(num_neighbors), stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name, a_err='Destination weights allocation failed')
goto 9999
end if
allocate(topology%send_counts(num_neighbors), stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name, a_err='Send counts allocation failed')
goto 9999
end if
allocate(topology%recv_counts(num_neighbors), stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name, a_err='Receive counts allocation failed')
goto 9999
end if
allocate(topology%send_displs(num_neighbors), stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name, a_err='Send displacements allocation failed')
goto 9999
end if
allocate(topology%recv_displs(num_neighbors), stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name, a_err='Receive displacements allocation failed')
goto 9999
end if
! -----------------------------------------------------------
! Allocate the gather/scatter index arrays
! -----------------------------------------------------------
allocate(topology%send_indexes(total_send_elems), stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name, a_err='Send indexes allocation failed')
goto 9999
end if
allocate(topology%recv_indexes(total_recv_elems), stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name, a_err='Recv indexes allocation failed')
goto 9999
end if
! -----------------------------------------------------------
! Fill neighbor ranks, weights, counts, displacements,
! and gather/scatter index arrays.
!
! The halo_index layout per neighbor (starting at position):
! position + 0 : process id
! position + 1 : nerv (num recv elements)
! position + 2 .. +1+nerv : recv element indexes
! position + 2+nerv : nesd (num send elements)
! position + 3+nerv .. +2+nerv+nesd : send element indexes
! Total stride per neighbor: nerv + nesd + 3
! -----------------------------------------------------------
send_offset = 0
recv_offset = 0
position = 1
do i = 1, num_neighbors
proc_id = halo_index(position)
num_elem_recv = halo_index(position + 1)
num_elem_send = halo_index(position + num_elem_recv + 2)
! Fill source/destination ranks and weights (weights are all 1 for now)
source_ranks(i) = int(proc_id, psb_mpk_)
dest_ranks(i) = int(proc_id, psb_mpk_)
source_weights(i) = 1
dest_weights(i) = 1
! Counts and displacements (displs set BEFORE accumulating offset)
topology%send_counts(i) = int(num_elem_send, psb_mpk_)
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_)
! Fill recv_indexes from halo_index(position+2 .. position+1+nerv)
do k = 1, num_elem_recv
topology%recv_indexes(recv_offset + k) = halo_index(position + psb_elem_recv_ + k - 1)
end do
! Fill send_indexes from halo_index(position+3+nerv .. position+2+nerv+nesd)
do k = 1, num_elem_send
topology%send_indexes(send_offset + k) = halo_index(position + num_elem_recv + psb_elem_send_ + k - 1)
end do
send_offset = send_offset + num_elem_send
recv_offset = recv_offset + num_elem_recv
topology%num_neighbors = topology%num_neighbors + 1
topology%total_send = topology%total_send + num_elem_send
topology%total_recv = topology%total_recv + num_elem_recv
position = position + num_elem_recv + num_elem_send + 3
end do
! ----------------------------------------------------------
! Sanity check: the totals computed from the neighbor list
! should match the totals returned by get_list_p.
! ----------------------------------------------------------
if (topology%total_send /= total_send_elems) then
info = psb_err_topology_args_mismatch_
call psb_errpush(info, name, a_err='Send elements mismatch')
goto 9999
end if
if (topology%total_recv /= total_recv_elems) then
info = psb_err_topology_args_mismatch_
call psb_errpush(info, name, a_err='Receive elements mismatch')
goto 9999
end if
if(topology%num_neighbors /= num_neighbors) then
info = psb_err_topology_args_mismatch_
call psb_errpush(info, name, a_err='Number of neighbors mismatch')
goto 9999
end if
! ----------------------------------------------------------
! Build the dist-graph communicator
! ----------------------------------------------------------
in_degree = topology%num_neighbors !! Just for clarity
out_degree = topology%num_neighbors !! Just for clarity
call mpi_dist_graph_create_adjacent(icomm, &
& in_degree, source_ranks, source_weights, &
& out_degree, dest_ranks, dest_weights, &
& mpi_info_null, .false., & ! Check this line for optimizations
& topology%graph_comm, info)
if (info /= mpi_success) then
info = psb_err_topology_error_
call psb_errpush(info, name)
goto 9999
end if
topology%is_initialized = .true.
! TODO: Is it safe to deallocate these temporary arrays here, or do we need them for the gather/scatter indexes?
! deallocate(source_ranks, dest_ranks, source_weights, dest_weights)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine neighbor_topology_init
! ---------------------------------------------------------------
! neighbor_topology_free
! Release all resources held by the persistent state.
! ---------------------------------------------------------------
subroutine neighbor_topology_free(topology, info)
#ifdef PSB_MPI_MOD
use mpi
#endif
implicit none
#ifdef PSB_MPI_H
include 'mpif.h'
#endif
class(psb_neighbor_topology_type), intent(inout) :: topology
integer(psb_ipk_), intent(out) :: info
integer(psb_mpk_) :: iret
info = psb_success_
if (topology%graph_comm /= mpi_comm_null) then
call mpi_comm_free(topology%graph_comm, iret)
topology%graph_comm = mpi_comm_null
end if
if (allocated(topology%send_counts)) deallocate(topology%send_counts)
if (allocated(topology%recv_counts)) deallocate(topology%recv_counts)
if (allocated(topology%send_displs)) deallocate(topology%send_displs)
if (allocated(topology%recv_displs)) deallocate(topology%recv_displs)
if (allocated(topology%send_indexes)) deallocate(topology%send_indexes)
if (allocated(topology%recv_indexes)) deallocate(topology%recv_indexes)
topology%num_neighbors = 0
topology%total_send = 0
topology%total_recv = 0
topology%is_initialized = .false.
end subroutine neighbor_topology_free
! ---------------------------------------------------------------
! neighbor_topology_sizeof
! Return approximate memory footprint in bytes.
! ---------------------------------------------------------------
function neighbor_topology_sizeof(topology) result(val)
implicit none
class(psb_neighbor_topology_type), intent(in) :: topology
integer(psb_epk_) :: val
val = 0
val = val + psb_sizeof_ip * 6 ! scalar integers + logicals
if (allocated(topology%send_counts)) val = val + psb_sizeof_ip * size(topology%send_counts)
if (allocated(topology%recv_counts)) val = val + psb_sizeof_ip * size(topology%recv_counts)
if (allocated(topology%send_displs)) val = val + psb_sizeof_ip * size(topology%send_displs)
if (allocated(topology%recv_displs)) val = val + psb_sizeof_ip * size(topology%recv_displs)
if (allocated(topology%send_indexes)) val = val + psb_sizeof_ip * size(topology%send_indexes)
if (allocated(topology%recv_indexes)) val = val + psb_sizeof_ip * size(topology%recv_indexes)
end function neighbor_topology_sizeof
end module psb_neighbor_topology_mod
base/modules/comm/psi_d_comm_v_mod.f90
+12 -38
View File
@@ -37,53 +37,27 @@ module psi_d_comm_v_mod
interface psi_swapdata
! ---------------------------------------------------------------
! Upper call in order to populate idx using desc_a%get_list_p
! Wrapper that calls different communications schemes depending on
! flag variable using communication buff obtained from desc_a%get_list_p
! ---------------------------------------------------------------
module subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y
real(psb_dpk_) :: beta
real(psb_dpk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
class(psb_d_base_vect_type) :: y
real(psb_dpk_) :: beta
real(psb_dpk_), optional, target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_dswapdata_vect
module subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_multivect_type) :: y
real(psb_dpk_) :: beta
real(psb_dpk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
class(psb_d_base_multivect_type) :: y
real(psb_dpk_) :: beta
real(psb_dpk_), optional, target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_dswapdata_multivect
! ---------------------------------------------------------------
! Wrapper that calls different communications schemes depending on
! flag variable
! ---------------------------------------------------------------
module subroutine psi_dswap_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y
real(psb_dpk_) :: beta
real(psb_dpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_dswap_vidx_vect
module subroutine psi_dswap_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_multivect_type) :: y
real(psb_dpk_) :: beta
real(psb_dpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_dswap_vidx_multivect
end interface psi_swapdata
base/modules/comm/psi_s_comm_v_mod.f90
+8 -8
View File
@@ -40,7 +40,7 @@ module psi_s_comm_v_mod
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
real(psb_spk_) :: beta
real(psb_spk_), intent(in) :: beta
real(psb_spk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
@@ -49,7 +49,7 @@ module psi_s_comm_v_mod
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
real(psb_spk_) :: beta
real(psb_spk_), intent(in) :: beta
real(psb_spk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
@@ -60,7 +60,7 @@ module psi_s_comm_v_mod
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
real(psb_spk_) :: beta
real(psb_spk_), intent(in) :: beta
real(psb_spk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
@@ -71,7 +71,7 @@ module psi_s_comm_v_mod
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
real(psb_spk_) :: beta
real(psb_spk_), intent(in) :: beta
real(psb_spk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
@@ -84,7 +84,7 @@ module psi_s_comm_v_mod
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
real(psb_spk_) :: beta
real(psb_spk_), intent(in) :: beta
real(psb_spk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
@@ -93,7 +93,7 @@ module psi_s_comm_v_mod
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
real(psb_spk_) :: beta
real(psb_spk_), intent(in) :: beta
real(psb_spk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
@@ -104,7 +104,7 @@ module psi_s_comm_v_mod
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
real(psb_spk_) :: beta
real(psb_spk_), intent(in) :: beta
real(psb_spk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
@@ -115,7 +115,7 @@ module psi_s_comm_v_mod
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
real(psb_spk_) :: beta
real(psb_spk_), intent(in) :: beta
real(psb_spk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
base/modules/desc/psb_desc_const_mod.f90
+6 -4
View File
@@ -49,10 +49,12 @@ module psb_desc_const_mod
integer(psb_ipk_), parameter :: psb_setzero_ = 4
! The following are bit fields.
integer(psb_ipk_), parameter :: psb_swap_send_ = 1
integer(psb_ipk_), parameter :: psb_swap_recv_ = 2
integer(psb_ipk_), parameter :: psb_swap_sync_ = 4
integer(psb_ipk_), parameter :: psb_swap_mpi_ = 8
integer(psb_ipk_), parameter :: psb_swap_send_ = 1
integer(psb_ipk_), parameter :: psb_swap_recv_ = 2
integer(psb_ipk_), parameter :: psb_swap_sync_ = 4
integer(psb_ipk_), parameter :: psb_swap_mpi_ = 8
integer(psb_ipk_), parameter :: psb_swap_start_ = 16
integer(psb_ipk_), parameter :: psb_swap_wait_ = 32
integer(psb_ipk_), parameter :: psb_collective_start_ = 1
integer(psb_ipk_), parameter :: psb_collective_end_ = 2
integer(psb_ipk_), parameter :: psb_collective_sync_ = 4
base/modules/psb_const_mod.F90
+4 -1
View File
@@ -326,7 +326,10 @@ module psb_const_mod
integer(psb_ipk_), parameter, public :: psb_err_invalid_irst_ =5002
integer(psb_ipk_), parameter, public :: psb_err_invalid_preci_=5003
integer(psb_ipk_), parameter, public :: psb_err_invalid_preca_=5004
integer(psb_ipk_), parameter, public :: psb_err_incoherent_comm_state_ = 6000 ! Used when communication type bitmask has more then one bit flipped
integer(psb_ipk_), parameter, public :: psb_err_topology_error_ = 7000
integer(psb_ipk_), parameter, public :: psb_err_topology_invalid_args_ = 7001
integer(psb_ipk_), parameter, public :: psb_err_topology_args_mismatch_ = 7002
type :: psb_ctxt_type
integer(psb_mpk_), allocatable :: ctxt
base/modules/serial/psb_d_base_vect_mod.F90
+91 -6
View File
@@ -49,6 +49,8 @@ module psb_d_base_vect_mod
use psb_realloc_mod
use psb_i_base_vect_mod
use psb_l_base_vect_mod
use psb_neighbor_topology_mod
!> \namespace psb_base_mod \class psb_d_base_vect_type
!! The psb_d_base_vect_type
@@ -62,9 +64,11 @@ module psb_d_base_vect_mod
!!
type psb_d_base_vect_type
!> Values.
real(psb_dpk_), allocatable :: v(:)
real(psb_dpk_), allocatable :: combuf(:)
integer(psb_mpk_), allocatable :: comid(:,:)
real(psb_dpk_), allocatable :: v(:)
real(psb_dpk_), allocatable :: combuf(:)
integer(psb_mpk_), allocatable :: comid(:,:) ! This is used only for Isend/Irecv scheme, to store the communication handles for each neighbor
integer(psb_mpk_) :: communication_handle ! This is used only for Isend/Irecv scheme, to store the communication handle for the whole halo exchange
!> vector bldstate:
!! null: pristine;
!! build: it's being filled with entries;
@@ -77,6 +81,9 @@ module psb_d_base_vect_mod
integer(psb_ipk_), private :: dupl = psb_dupl_null_
integer(psb_ipk_), private :: ncfs = 0
integer(psb_ipk_), allocatable :: iv(:)
type(psb_neighbor_topology_type) :: neighbor_topology
contains
!
! Constructors/allocators
@@ -249,6 +256,11 @@ module psb_d_base_vect_mod
procedure, pass(x) :: minquotient_a2 => d_base_minquotient_a2
generic, public :: minquotient => minquotient_v, minquotient_a2
! Methods used to handle topology in neighbor_alltoallv communication scheme
procedure, pass(x) :: init_topology => d_base_init_topology
procedure, pass(x) :: free_topology => d_base_free_topology
end type psb_d_base_vect_type
public :: psb_d_base_vect
@@ -2609,6 +2621,36 @@ contains
if (x%is_dev()) call x%sync()
call z%addconst(x%v,b,info)
end subroutine d_base_addconst_v2
! --------------------------------------------------------------------
! Implementation of methods used for neighbor alltoallv communication
! --------------------------------------------------------------------
subroutine d_base_init_topology(x, halo_index, num_exchanges, &
& total_send_elems, total_recv_elems, ctxt, icomm, info)
implicit none
class(psb_d_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: halo_index(:)
integer(psb_ipk_), intent(in) :: num_exchanges, total_send_elems, total_recv_elems
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(out) :: info
call x%neighbor_topology%init(halo_index, num_exchanges, &
& total_send_elems, total_recv_elems, ctxt, icomm, info)
end subroutine d_base_init_topology
subroutine d_base_free_topology(x, info)
implicit none
class(psb_d_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
call x%neighbor_topology%free(info)
end subroutine d_base_free_topology
! --------------------------------------------------------------------
end module psb_d_base_vect_mod
@@ -2618,6 +2660,7 @@ module psb_d_base_multivect_mod
use psb_error_mod
use psb_realloc_mod
use psb_d_base_vect_mod
use psb_neighbor_topology_mod
!> \namespace psb_base_mod \class psb_d_base_vect_type
!! The psb_d_base_vect_type
@@ -2634,9 +2677,11 @@ module psb_d_base_multivect_mod
type psb_d_base_multivect_type
!> Values.
real(psb_dpk_), allocatable :: v(:,:)
real(psb_dpk_), allocatable :: combuf(:)
integer(psb_mpk_), allocatable :: comid(:,:)
real(psb_dpk_), allocatable :: v(:,:)
real(psb_dpk_), allocatable :: combuf(:)
integer(psb_mpk_), allocatable :: comid(:,:) ! This is used only for Isend/Irecv scheme, to store the communication handles for each neighbor
integer(psb_mpk_) :: communication_handle ! This is used only for Isend/Irecv scheme, to store the communication handle for the whole halo exchange
!> vector bldstate:
!! null: pristine;
!! build: it's being filled with entries;
@@ -2649,6 +2694,9 @@ module psb_d_base_multivect_mod
integer(psb_ipk_), private :: dupl = psb_dupl_null_
integer(psb_ipk_), private :: ncfs = 0
integer(psb_ipk_), allocatable :: iv(:)
type(psb_neighbor_topology_type) :: neighbor_topology
contains
!
! Constructors/allocators
@@ -2774,6 +2822,12 @@ module psb_d_base_multivect_mod
procedure, pass(y) :: sctb_x => d_base_mlv_sctb_x
procedure, pass(y) :: sctb_buf => d_base_mlv_sctb_buf
generic, public :: sct => sctb, sctbr2, sctb_x, sctb_buf
! Neighbor alltoallv communication topology handling
procedure, pass(x) :: init_topology => d_base_mlv_init_topology
procedure, pass(x) :: free_topology => d_base_mlv_free_topology
end type psb_d_base_multivect_type
interface psb_d_base_multivect
@@ -4297,4 +4351,35 @@ contains
end subroutine d_base_mlv_device_wait
! --------------------------------------------------------------------
! Implementation of methods used for neighbor alltoallv communication
! --------------------------------------------------------------------
subroutine d_base_mlv_init_topology(x, halo_index, num_exchanges, &
& total_send_elems, total_recv_elems, ctxt, icomm, info)
implicit none
class(psb_d_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: halo_index(:)
integer(psb_ipk_), intent(in) :: num_exchanges, total_send_elems, total_recv_elems
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(out) :: info
call x%neighbor_topology%init(halo_index, num_exchanges, &
& total_send_elems, total_recv_elems, ctxt, icomm, info)
end subroutine d_base_mlv_init_topology
subroutine d_base_mlv_free_topology(x, info)
implicit none
class(psb_d_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
call x%neighbor_topology%free(info)
end subroutine d_base_mlv_free_topology
! --------------------------------------------------------------------
end module psb_d_base_multivect_mod
base/modules/serial/psb_s_base_vect_mod.F90
+8
View File
@@ -49,6 +49,7 @@ module psb_s_base_vect_mod
use psb_realloc_mod
use psb_i_base_vect_mod
use psb_l_base_vect_mod
use psb_neighbor_topology_mod
!> \namespace psb_base_mod \class psb_s_base_vect_type
!! The psb_s_base_vect_type
@@ -65,6 +66,7 @@ module psb_s_base_vect_mod
real(psb_spk_), allocatable :: v(:)
real(psb_spk_), allocatable :: combuf(:)
integer(psb_mpk_), allocatable :: comid(:,:)
integer(psb_mpk_) :: communication_handle ! This is used only for Isend/Irecv scheme, to store the communication handle for the whole halo exchange
!> vector bldstate:
!! null: pristine;
!! build: it's being filled with entries;
@@ -77,6 +79,8 @@ module psb_s_base_vect_mod
integer(psb_ipk_), private :: dupl = psb_dupl_null_
integer(psb_ipk_), private :: ncfs = 0
integer(psb_ipk_), allocatable :: iv(:)
type(psb_neighbor_topology_type) :: neighbor_topology
contains
!
! Constructors/allocators
@@ -2618,6 +2622,7 @@ module psb_s_base_multivect_mod
use psb_error_mod
use psb_realloc_mod
use psb_s_base_vect_mod
use psb_neighbor_topology_mod
!> \namespace psb_base_mod \class psb_s_base_vect_type
!! The psb_s_base_vect_type
@@ -2637,6 +2642,7 @@ module psb_s_base_multivect_mod
real(psb_spk_), allocatable :: v(:,:)
real(psb_spk_), allocatable :: combuf(:)
integer(psb_mpk_), allocatable :: comid(:,:)
integer(psb_mpk_) :: communication_handle ! This is used only for Isend/Irecv scheme, to store the communication handle for the whole halo exchange
!> vector bldstate:
!! null: pristine;
!! build: it's being filled with entries;
@@ -2649,6 +2655,8 @@ module psb_s_base_multivect_mod
integer(psb_ipk_), private :: dupl = psb_dupl_null_
integer(psb_ipk_), private :: ncfs = 0
integer(psb_ipk_), allocatable :: iv(:)
type(psb_neighbor_topology_type) :: neighbor_topology
contains
!
! Constructors/allocators