From 2846907ca97aa408ea53291f8de53695fdd81d46 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 5 Mar 2013 18:03:24 +0000 Subject: [PATCH] psblas3-type-indexed: base/internals/psi_dswapdata.F90 base/modules/psb_d_base_vect_mod.f90 base/modules/psb_s_base_vect_mod.f90 Safegurds to choose whether to use TYPE_INDEXED. --- base/internals/psi_dswapdata.F90 | 55 +--------------------------- base/modules/psb_d_base_vect_mod.f90 | 22 +++++++++-- base/modules/psb_s_base_vect_mod.f90 | 36 ++++++++++++++++++ 3 files changed, 56 insertions(+), 57 deletions(-) diff --git a/base/internals/psi_dswapdata.F90 b/base/internals/psi_dswapdata.F90 index 064acda9..ec7283b8 100644 --- a/base/internals/psi_dswapdata.F90 +++ b/base/internals/psi_dswapdata.F90 @@ -1613,7 +1613,8 @@ subroutine psi_dswapidx_vect_mptx(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,to do_send = swap_mpi .or. swap_sync .or. swap_send do_recv = swap_mpi .or. swap_sync .or. swap_recv - if (beta==dzero .and. do_send .and. do_recv .and.sendtypes(1)/=mpi_datatype_null) then + if (y%type_idx() .and. beta==dzero .and. do_send .and. do_recv .and. & + & sendtypes(1)/=mpi_datatype_null) then allocate(rvhd(totxch),prcid(totxch),stat=info) if(info /= psb_success_) then @@ -1631,58 +1632,6 @@ subroutine psi_dswapidx_vect_mptx(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,to bfsz = max(bfsz,nesd,nerv) pnti = pnti + nerv + nesd + 3 end do -!!$ allocate(blens(bfsz),new_idx(bfsz),stat=info) -!!$ if(info /= psb_success_) then -!!$ call psb_errpush(psb_err_alloc_dealloc_,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ -!!$ !We've to set the derivate datatypes -!!$ !Send/Gather -!!$ pnti = 1 -!!$ snd_pt = 1 -!!$ if (sendtypes(1)==mpi_datatype_null) then -!!$ 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_ -!!$ do j=1,nesd -!!$ blens(j) = 1 -!!$ new_idx(i) = idx(idx_pt+i-1)-1 -!!$ end do -!!$ call MPI_TYPE_INDEXED(nesd,blens,new_idx,& -!!$ & psb_mpi_r_dpk_,sendtypes(i),iret) -!!$ call MPI_TYPE_COMMIT(sendtypes(i),iret) -!!$ 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 (recvtypes(1)==mpi_datatype_null) then -!!$ 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_ -!!$ do j=1, nerv -!!$ blens(j) = 1 -!!$ new_idx(i) = idx(idx_pt+i-1)-1 -!!$ end do -!!$ call mpi_type_indexed(nerv,blens,new_idx,& -!!$ & psb_mpi_r_dpk_,recvtypes(i),iret) -!!$ call mpi_type_commit(recvtypes(i),iret) -!!$ -!!$ rcv_pt = rcv_pt + nerv -!!$ snd_pt = snd_pt + nesd -!!$ pnti = pnti + nerv + nesd + 3 -!!$ end do -!!$ end if -!!$ !write(*,*) 'Sono dentro swap_send .and. swap_recv' diff --git a/base/modules/psb_d_base_vect_mod.f90 b/base/modules/psb_d_base_vect_mod.f90 index e8ab37c8..5fb0ec6d 100644 --- a/base/modules/psb_d_base_vect_mod.f90 +++ b/base/modules/psb_d_base_vect_mod.f90 @@ -142,6 +142,7 @@ module psb_d_base_vect_mod generic, public :: gth => gthab, gthzv procedure, pass(y) :: sctb => d_base_sctb generic, public :: sct => sctb + procedure, pass(x) :: type_idx => d_base_type_idx procedure, pass(x) :: get_clocv => d_base_get_clocv end type psb_d_base_vect_type @@ -818,6 +819,19 @@ contains end subroutine d_base_sctb + ! + ! Whether we should go for data exchange + ! using MPI_TYPE_INDEXED, if at all + ! possible. + ! + function d_base_type_idx(x) result(res) + class(psb_d_base_vect_type) :: x + logical :: res + + res = .true. + + end function d_base_type_idx + function d_base_get_clocv(x) result(res) use iso_c_binding @@ -825,17 +839,17 @@ contains type(c_ptr) :: res if (allocated(x%v)) then - call aux_get_clocv(x%v,res) -!!$ res = c_loc(x%v) + call d_aux_get_clocv(x%v,res) else res = c_null_ptr end if end function d_base_get_clocv - subroutine aux_get_clocv(v,res) + + subroutine d_aux_get_clocv(v,res) use iso_c_binding real(psb_dpk_), target :: v(*) type(c_ptr) :: res res = c_loc(v) - end subroutine aux_get_clocv + end subroutine d_aux_get_clocv end module psb_d_base_vect_mod diff --git a/base/modules/psb_s_base_vect_mod.f90 b/base/modules/psb_s_base_vect_mod.f90 index a16e6252..2720909e 100644 --- a/base/modules/psb_s_base_vect_mod.f90 +++ b/base/modules/psb_s_base_vect_mod.f90 @@ -142,6 +142,8 @@ module psb_s_base_vect_mod generic, public :: gth => gthab, gthzv procedure, pass(y) :: sctb => s_base_sctb generic, public :: sct => sctb + procedure, pass(x) :: type_idx => s_base_type_idx + procedure, pass(x) :: get_clocv => s_base_get_clocv end type psb_s_base_vect_type public :: psb_s_base_vect @@ -817,4 +819,38 @@ contains end subroutine s_base_sctb + + ! + ! Whether we should go for data exchange + ! using MPI_TYPE_INDEXED, if at all + ! possible. + ! + function s_base_type_idx(x) result(res) + class(psb_s_base_vect_type) :: x + logical :: res + + res = .true. + + end function s_base_type_idx + + function s_base_get_clocv(x) result(res) + use iso_c_binding + + class(psb_s_base_vect_type), target :: x + type(c_ptr) :: res + + if (allocated(x%v)) then + call s_aux_get_clocv(x%v,res) + else + res = c_null_ptr + end if + end function s_base_get_clocv + + subroutine s_aux_get_clocv(v,res) + use iso_c_binding + real(psb_spk_), target :: v(*) + type(c_ptr) :: res + res = c_loc(v) + end subroutine s_aux_get_clocv + end module psb_s_base_vect_mod