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

sendtypes and recvtypes in descriptor structure

Browse Source
psblas3-type-indexed
Alessandro Fanfarillo 13 years ago
parent cef6c4c3d3
commit 414d9c3496
4 changed files with 110 additions and 53 deletions
Show Stats Download Patch File Download Diff File

101
base/internals/psi_dswapdata.F90
Unescape Escape View File

@ -1074,7 +1074,7 @@ subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data)
goto 9999
end if
call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,desc_a%sendtypes,desc_a%recvtypes,work,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -1090,7 +1090,7 @@ subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data)
end subroutine psi_dswapdata_vect
subroutine psi_dswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_dswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,sendtypes,recvtypes,work,info)
use psi_mod, psb_protect_name => psi_dswapidx_vect
use psb_error_mod
@ -1111,6 +1111,7 @@ subroutine psi_dswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,
real(psb_dpk_) :: beta
real(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
integer, allocatable,optional, intent(in) :: sendtypes(:),recvtypes(:)
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
@ -1131,8 +1132,8 @@ subroutine psi_dswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,
#endif
character(len=20) :: name
!integer, dimension(totxch) :: sendtypes,recvtypes
integer, allocatable, save :: sendtypes(:),recvtypes(:)
integer, allocatable :: blens(:), new_idx(:)
!integer, allocatable :: sendtypes(:),recvtypes(:)
!integer, allocatable :: blens(:), new_idx(:)
info=psb_success_
name='psi_swap_datav'
@ -1221,54 +1222,54 @@ subroutine psi_dswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,
!We've to set the derivate datatypes
!Send/Gather
pnti = 1
snd_pt = 1
if(.not.allocated(sendtypes)) then
allocate(sendtypes(totxch), stat=info)
do i=1, totxch
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+nerv+psb_n_elem_send_
allocate(blens(nesd),stat=info)
do j=1,nesd
blens(j) = 1
end do
call MPI_TYPE_INDEXED(nesd,blens,(idx(idx_pt:idx_pt+nesd-1)-1),&
& mpi_double_precision,sendtypes(i),info)
call MPI_TYPE_COMMIT(sendtypes(i),info)
deallocate(blens,stat=info)
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
end if
! pnti = 1
! snd_pt = 1
! if(.not.allocated(sendtypes)) then
! allocate(sendtypes(totxch), stat=info)
! do i=1, totxch
! nerv = idx(pnti+psb_n_elem_recv_)
! nesd = idx(pnti+nerv+psb_n_elem_send_)
! idx_pt = 1+pnti+nerv+psb_n_elem_send_
! allocate(blens(nesd),stat=info)
! do j=1,nesd
! blens(j) = 1
! end do
! call MPI_TYPE_INDEXED(nesd,blens,(idx(idx_pt:idx_pt+nesd-1)-1),&
! & mpi_double_precision,sendtypes(i),info)
! call MPI_TYPE_COMMIT(sendtypes(i),info)
! deallocate(blens,stat=info)
! snd_pt = snd_pt + nesd
! pnti = pnti + nerv + nesd + 3
! end do
! end if
!Recv/Scatter
pnti = 1
snd_pt = 1
rcv_pt = 1
if(.not.allocated(recvtypes)) then
allocate(recvtypes(totxch), stat=info)
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_
allocate(blens(nerv),stat=info)
do j=1, nerv
blens(j) = 1
end do
call MPI_TYPE_INDEXED(nerv,blens,(idx(idx_pt:idx_pt+nerv-1)-1),&
& mpi_double_precision,recvtypes(i),info)
call MPI_TYPE_COMMIT(recvtypes(i),info)
deallocate(blens,stat=info)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
end if
! pnti = 1
! snd_pt = 1
! rcv_pt = 1
!if(.not.allocated(recvtypes)) then
! allocate(recvtypes(totxch), stat=info)
! do i=1, totxch
! proc_to_comm = idx(pnti+psb_proc_id_)
! nerv = idx(pnti+psb_n_elem_recv_)
! nesd = idx(pnti+nerv+psb_n_elem_send_)
! idx_pt = 1+pnti+psb_n_elem_recv_
! allocate(blens(nerv),stat=info)
! do j=1, nerv
! blens(j) = 1
! end do
!
! call MPI_TYPE_INDEXED(nerv,blens,(idx(idx_pt:idx_pt+nerv-1)-1),&
! & mpi_double_precision,recvtypes(i),info)
! call MPI_TYPE_COMMIT(recvtypes(i),info)
! deallocate(blens,stat=info)
! rcv_pt = rcv_pt + nerv
! snd_pt = snd_pt + nesd
! pnti = pnti + nerv + nesd + 3
! end do
! end if
if (beta/=0 .and. do_send) then

2
base/modules/psb_desc_type.f90
Unescape Escape View File

@ -209,6 +209,8 @@ module psb_descriptor_type
integer(psb_ipk_), allocatable :: lprm(:)
type(psb_desc_type), pointer :: base_desc => null()
integer(psb_ipk_), allocatable :: idx_space(:)
integer, allocatable :: sendtypes(:),recvtypes(:) !Extendable as a matrix of every kind of data
contains
procedure, pass(desc) :: is_ok => psb_is_ok_desc
procedure, pass(desc) :: is_valid => psb_is_valid_desc

3
base/modules/psi_d_mod.f90
Unescape Escape View File

@ -80,7 +80,7 @@ module psi_d_mod
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_dswapidxv
subroutine psi_dswapidx_vect(ictxt,icomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,sendtypes,recvtypes,work,info)
import :: psb_desc_type, psb_ipk_, psb_dpk_, psb_d_base_vect_type
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
@ -88,6 +88,7 @@ module psi_d_mod
real(psb_dpk_) :: beta
real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
integer, allocatable,optional, intent(in) :: sendtypes(:),recvtypes(:)
end subroutine psi_dswapidx_vect
end interface

57
base/tools/psb_icdasb.F90
Unescape Escape View File

@ -61,10 +61,13 @@ subroutine psb_icdasb(desc,info,ext_hv)
integer(psb_ipk_) :: int_err(5)
integer(psb_ipk_),allocatable :: ovrlap_index(:),halo_index(:), ext_index(:)
integer(psb_ipk_) :: i, n_col, dectype, err_act, n_row
integer(psb_mpik_) :: np,me, icomm, ictxt
integer(psb_ipk_) :: i, n_col, dectype, err_act, n_row,j
integer(psb_mpik_) :: np,me, icomm, ictxt,proc_to_comm
logical :: ext_hv_
integer(psb_ipk_) :: debug_level, debug_unit
integer :: totxch, idxr, idxs, data_, pnti, snd_pt, rcv_pt,nerv,nesd,idx_pt
integer, allocatable :: blens(:), new_idx(:)
integer(psb_ipk_), pointer :: idx(:)
character(len=20) :: name
info = psb_success_
@ -157,6 +160,56 @@ subroutine psb_icdasb(desc,info,ext_hv)
call psb_errpush(info,name)
goto 9999
endif
!datatypes allocation
data_ = psb_comm_halo_
call desc%get_list(data_,idx,totxch,idxr,idxs,info)
!Send/Gather
pnti = 1
snd_pt = 1
rcv_pt = 1
allocate(desc%sendtypes(totxch), stat=info)
do i=1, totxch
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+nerv+psb_n_elem_send_
allocate(blens(nesd),stat=info)
do j=1,nesd
blens(j) = 1
end do
call MPI_TYPE_INDEXED(nesd,blens,(idx(idx_pt:idx_pt+nesd-1)-1),&
& mpi_double_precision,desc%sendtypes(i),info)
call MPI_TYPE_COMMIT(desc%sendtypes(i),info)
deallocate(blens,stat=info)
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
pnti = 1
snd_pt = 1
rcv_pt = 1
!Recv/Scatter
allocate(desc%recvtypes(totxch), stat=info)
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_
allocate(blens(nerv),stat=info)
do j=1, nerv
blens(j) = 1
end do
call MPI_TYPE_INDEXED(nerv,blens,(idx(idx_pt:idx_pt+nerv-1)-1),&
& mpi_double_precision,desc%recvtypes(i),info)
call MPI_TYPE_COMMIT(desc%recvtypes(i),info)
deallocate(blens,stat=info)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': Done'

Write Preview
Loading…
Cancel
Save