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 goto 9999
end if 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 if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act) 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 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 psi_mod, psb_protect_name => psi_dswapidx_vect
use psb_error_mod 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_) :: beta
real(psb_dpk_), target :: work(:) real(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
integer, allocatable,optional, intent(in) :: sendtypes(:),recvtypes(:)
! locals ! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,& 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 #endif
character(len=20) :: name character(len=20) :: name
!integer, dimension(totxch) :: sendtypes,recvtypes !integer, dimension(totxch) :: sendtypes,recvtypes
integer, allocatable, save :: sendtypes(:),recvtypes(:) !integer, allocatable :: sendtypes(:),recvtypes(:)
integer, allocatable :: blens(:), new_idx(:) !integer, allocatable :: blens(:), new_idx(:)
info=psb_success_ info=psb_success_
name='psi_swap_datav' 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 !We've to set the derivate datatypes
!Send/Gather !Send/Gather
pnti = 1 ! pnti = 1
snd_pt = 1 ! snd_pt = 1
if(.not.allocated(sendtypes)) then ! if(.not.allocated(sendtypes)) then
allocate(sendtypes(totxch), stat=info) ! allocate(sendtypes(totxch), stat=info)
do i=1, totxch ! do i=1, totxch
nerv = idx(pnti+psb_n_elem_recv_) ! nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) ! nesd = idx(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+nerv+psb_n_elem_send_ ! idx_pt = 1+pnti+nerv+psb_n_elem_send_
allocate(blens(nesd),stat=info) ! allocate(blens(nesd),stat=info)
do j=1,nesd ! do j=1,nesd
blens(j) = 1 ! blens(j) = 1
end do ! end do
call MPI_TYPE_INDEXED(nesd,blens,(idx(idx_pt:idx_pt+nesd-1)-1),& ! call MPI_TYPE_INDEXED(nesd,blens,(idx(idx_pt:idx_pt+nesd-1)-1),&
& mpi_double_precision,sendtypes(i),info) ! & mpi_double_precision,sendtypes(i),info)
call MPI_TYPE_COMMIT(sendtypes(i),info) ! call MPI_TYPE_COMMIT(sendtypes(i),info)
deallocate(blens,stat=info) ! deallocate(blens,stat=info)
snd_pt = snd_pt + nesd ! snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3 ! pnti = pnti + nerv + nesd + 3
end do ! end do
end if ! end if
!Recv/Scatter !Recv/Scatter
pnti = 1 ! pnti = 1
snd_pt = 1 ! snd_pt = 1
rcv_pt = 1 ! rcv_pt = 1
if(.not.allocated(recvtypes)) then !if(.not.allocated(recvtypes)) then
allocate(recvtypes(totxch), stat=info) ! allocate(recvtypes(totxch), stat=info)
do i=1, totxch ! do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_) ! proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) ! nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) ! nesd = idx(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_ ! idx_pt = 1+pnti+psb_n_elem_recv_
allocate(blens(nerv),stat=info) ! allocate(blens(nerv),stat=info)
do j=1, nerv ! do j=1, nerv
blens(j) = 1 ! blens(j) = 1
end do ! end do
!
call MPI_TYPE_INDEXED(nerv,blens,(idx(idx_pt:idx_pt+nerv-1)-1),& ! call MPI_TYPE_INDEXED(nerv,blens,(idx(idx_pt:idx_pt+nerv-1)-1),&
& mpi_double_precision,recvtypes(i),info) ! & mpi_double_precision,recvtypes(i),info)
call MPI_TYPE_COMMIT(recvtypes(i),info) ! call MPI_TYPE_COMMIT(recvtypes(i),info)
deallocate(blens,stat=info) ! deallocate(blens,stat=info)
rcv_pt = rcv_pt + nerv ! rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd ! snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3 ! pnti = pnti + nerv + nesd + 3
end do ! end do
end if ! end if
if (beta/=0 .and. do_send) then 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(:) integer(psb_ipk_), allocatable :: lprm(:)
type(psb_desc_type), pointer :: base_desc => null() type(psb_desc_type), pointer :: base_desc => null()
integer(psb_ipk_), allocatable :: idx_space(:) integer(psb_ipk_), allocatable :: idx_space(:)
integer, allocatable :: sendtypes(:),recvtypes(:) !Extendable as a matrix of every kind of data
contains contains
procedure, pass(desc) :: is_ok => psb_is_ok_desc procedure, pass(desc) :: is_ok => psb_is_ok_desc
procedure, pass(desc) :: is_valid => psb_is_valid_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 integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_dswapidxv end subroutine psi_dswapidxv
subroutine psi_dswapidx_vect(ictxt,icomm,flag,beta,y,idx,& 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 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(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -88,6 +88,7 @@ module psi_d_mod
real(psb_dpk_) :: beta real(psb_dpk_) :: beta
real(psb_dpk_),target :: work(:) real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
integer, allocatable,optional, intent(in) :: sendtypes(:),recvtypes(:)
end subroutine psi_dswapidx_vect end subroutine psi_dswapidx_vect
end interface 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_) :: int_err(5)
integer(psb_ipk_),allocatable :: ovrlap_index(:),halo_index(:), ext_index(:) integer(psb_ipk_),allocatable :: ovrlap_index(:),halo_index(:), ext_index(:)
integer(psb_ipk_) :: i, n_col, dectype, err_act, n_row integer(psb_ipk_) :: i, n_col, dectype, err_act, n_row,j
integer(psb_mpik_) :: np,me, icomm, ictxt integer(psb_mpik_) :: np,me, icomm, ictxt,proc_to_comm
logical :: ext_hv_ logical :: ext_hv_
integer(psb_ipk_) :: debug_level, debug_unit 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 character(len=20) :: name
info = psb_success_ info = psb_success_
@ -158,6 +161,56 @@ subroutine psb_icdasb(desc,info,ext_hv)
goto 9999 goto 9999
endif 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_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': Done' & write(debug_unit,*) me,' ',trim(name),': Done'

Write Preview
Loading…
Cancel
Save