diff --git a/base/internals/psi_dswapdata.F90 b/base/internals/psi_dswapdata.F90 index 76181849..8186846c 100644 --- a/base/internals/psi_dswapdata.F90 +++ b/base/internals/psi_dswapdata.F90 @@ -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 diff --git a/base/modules/psb_desc_type.f90 b/base/modules/psb_desc_type.f90 index 42450796..34aba4e0 100644 --- a/base/modules/psb_desc_type.f90 +++ b/base/modules/psb_desc_type.f90 @@ -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 diff --git a/base/modules/psi_d_mod.f90 b/base/modules/psi_d_mod.f90 index 04c29e1c..20d07fed 100644 --- a/base/modules/psi_d_mod.f90 +++ b/base/modules/psi_d_mod.f90 @@ -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 diff --git a/base/tools/psb_icdasb.F90 b/base/tools/psb_icdasb.F90 index b6aac134..75597103 100644 --- a/base/tools/psb_icdasb.F90 +++ b/base/tools/psb_icdasb.F90 @@ -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'