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

*** empty log message ***

Browse Source
psblas3-type-indexed
Salvatore Filippone 12 years ago
parent 538d4b31dc
commit 5ab265ff28
1 changed files with 103 additions and 110 deletions
Show Stats Download Patch File Download Diff File

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

@ -1560,33 +1560,33 @@ subroutine psi_dswapidx_vect_mptx(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,to
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
interface interface
function receive(v,recvtype,procSender,tag,communicator,handle) & function receive(v,recvtype,procSender,tag,communicator,handle) &
& result(res) bind(c,name='receiveRoutine') & result(res) bind(c,name='receiveRoutine')
use iso_c_binding use iso_c_binding
!real(c_double) :: v(*) !real(c_double) :: v(*)
type(c_ptr), value :: v type(c_ptr), value :: v
integer(c_int),value :: recvtype integer(c_int),value :: recvtype
integer(c_int),value :: communicator integer(c_int),value :: communicator
integer(c_int),value :: procSender integer(c_int),value :: procSender
integer(c_int),value :: tag integer(c_int),value :: tag
integer(c_int) :: handle integer(c_int) :: handle
integer(c_int) :: res integer(c_int) :: res
end function receive end function receive
end interface end interface
interface interface
function send(v,sendtype,procToSend,tag,communicator) & function send(v,sendtype,procToSend,tag,communicator) &
& result(res) bind(c,name='sendRoutine') & result(res) bind(c,name='sendRoutine')
use iso_c_binding use iso_c_binding
!real(c_double) :: v(*) !real(c_double) :: v(*)
type(c_ptr), value :: v type(c_ptr), value :: v
integer(c_int),value :: sendtype integer(c_int),value :: sendtype
integer(c_int),value :: communicator integer(c_int),value :: communicator
integer(c_int),value :: procToSend integer(c_int),value :: procToSend
integer(c_int),value :: tag integer(c_int),value :: tag
integer(c_int) :: res integer(c_int) :: res
end function send end function send
end interface end interface
real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf
#ifdef HAVE_VOLATILE #ifdef HAVE_VOLATILE
@ -1774,7 +1774,7 @@ subroutine psi_dswapidx_vect_mptx(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,to
end if end if
if (beta/=0 .and. do_send) then if (do_send) then
! Pack send buffers ! Pack send buffers
pnti = 1 pnti = 1
@ -1880,19 +1880,14 @@ subroutine psi_dswapidx_vect_mptx(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,to
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
if(beta==0) then if (usersend) then
!call send_routine(y%v,sendtypes(i),prcid(i),p2ptag,icomm, iret) call mpi_rsend(sndbuf(snd_pt),nesd,&
iret = send(y%get_clocv(),sendtypes(i),prcid(i),p2ptag,icomm) & psb_mpi_r_dpk_,prcid(i),&
& p2ptag,icomm,iret)
else else
if (usersend) then call mpi_send(sndbuf(snd_pt),nesd,&
call mpi_rsend(sndbuf(snd_pt),nesd,& & psb_mpi_r_dpk_,prcid(i),&
& psb_mpi_r_dpk_,prcid(i),& & p2ptag,icomm,iret)
& p2ptag,icomm,iret)
else
call mpi_send(sndbuf(snd_pt),nesd,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag,icomm,iret)
end if
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
@ -1976,17 +1971,15 @@ subroutine psi_dswapidx_vect_mptx(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,to
snd_pt = 1 snd_pt = 1
rcv_pt = 1 rcv_pt = 1
do i=1, totxch do i=1, totxch
if(beta/=0) then 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_ call y%sct(nerv,idx(idx_pt:idx_pt+nerv-1),&
call y%sct(nerv,idx(idx_pt:idx_pt+nerv-1),& & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta)
& rcvbuf(rcv_pt:rcv_pt+nerv-1),beta) 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 if
end do end do
end if end if
@ -2018,72 +2011,72 @@ subroutine psi_dswapidx_vect_mptx(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,to
end if end if
return return
!contains !contains
! subroutine receive_routine(v,recvtype,procSender,tag,communicator, rvhd,info) ! subroutine receive_routine(v,recvtype,procSender,tag,communicator, rvhd,info)
! use iso_c_binding ! use iso_c_binding
! real(c_double), intent(in), target :: v(*) ! real(c_double), intent(in), target :: v(*)
! integer, intent(in) :: recvtype ! integer, intent(in) :: recvtype
! integer :: communicator ! integer :: communicator
! integer :: procSender,tag,rvhd ! integer :: procSender,tag,rvhd
! integer, intent(out) :: info ! integer, intent(out) :: info
! type(c_ptr) :: cptr ! type(c_ptr) :: cptr
! integer :: isz ! integer :: isz
! interface ! interface
! function receive(v,recvtype,procSender,tag,communicator,handle) & ! function receive(v,recvtype,procSender,tag,communicator,handle) &
! & result(res) bind(c,name='receiveRoutine') ! & result(res) bind(c,name='receiveRoutine')
! use iso_c_binding ! use iso_c_binding
! !real(c_double) :: v(*) ! !real(c_double) :: v(*)
! type(c_ptr), value :: v ! type(c_ptr), value :: v
! integer(c_int),value :: recvtype ! integer(c_int),value :: recvtype
! integer(c_int),value :: communicator ! integer(c_int),value :: communicator
! integer(c_int),value :: procSender ! integer(c_int),value :: procSender
! integer(c_int),value :: tag ! integer(c_int),value :: tag
! integer(c_int) :: handle ! integer(c_int) :: handle
! integer(c_int) :: res ! integer(c_int) :: res
! end function receive ! end function receive
! end interface ! end interface
! cptr = c_loc(v) ! cptr = c_loc(v)
! info = receive(cptr,recvtype,procSender,tag,communicator,rvhd) ! info = receive(cptr,recvtype,procSender,tag,communicator,rvhd)
!!!$ call mpi_type_size(recvtype,isz,info) !!!$ call mpi_type_size(recvtype,isz,info)
!!!$ WRITE(0,*) 'Recving from ',procSender,tag,recvtype,isz,v(1) !!!$ WRITE(0,*) 'Recving from ',procSender,tag,recvtype,isz,v(1)
!!!$ call mpi_irecv(v,1,recvtype,procSender,tag,communicator,rvhd,info) !!!$ call mpi_irecv(v,1,recvtype,procSender,tag,communicator,rvhd,info)
! end subroutine receive_routine ! end subroutine receive_routine
! subroutine send_routine(v,sendtype,procToSend,tag,communicator,info) ! subroutine send_routine(v,sendtype,procToSend,tag,communicator,info)
! use iso_c_binding ! use iso_c_binding
! real(c_double), intent(in), target :: v(*) ! real(c_double), intent(in), target :: v(*)
! integer, intent(in) :: sendtype ! integer, intent(in) :: sendtype
! integer :: communicator ! integer :: communicator
! integer :: procToSend,tag ! integer :: procToSend,tag
! integer, intent(out) :: info ! integer, intent(out) :: info
! type(c_ptr) :: cptr ! type(c_ptr) :: cptr
! integer :: isz ! integer :: isz
! interface ! interface
! function send(v,sendtype,procToSend,tag,communicator) & ! function send(v,sendtype,procToSend,tag,communicator) &
! & result(res) bind(c,name='sendRoutine') ! & result(res) bind(c,name='sendRoutine')
! use iso_c_binding ! use iso_c_binding
! !real(c_double) :: v(*) ! !real(c_double) :: v(*)
! type(c_ptr), value :: v ! type(c_ptr), value :: v
! integer(c_int),value :: sendtype ! integer(c_int),value :: sendtype
! integer(c_int),value :: communicator ! integer(c_int),value :: communicator
! integer(c_int),value :: procToSend ! integer(c_int),value :: procToSend
! integer(c_int),value :: tag ! integer(c_int),value :: tag
! integer(c_int) :: res ! integer(c_int) :: res
! end function send ! end function send
! end interface ! end interface
! cptr = c_loc(v) ! cptr = c_loc(v)
! info = send(cptr,sendtype,procToSend,tag,communicator) ! info = send(cptr,sendtype,procToSend,tag,communicator)
!!!$ call mpi_type_size(sendtype,isz,info) !!!$ call mpi_type_size(sendtype,isz,info)
!!!$ WRITE(0,*) 'Sending to ',procToSend,tag,sendtype,isz,v(1) !!!$ WRITE(0,*) 'Sending to ',procToSend,tag,sendtype,isz,v(1)
!!!$ call mpi_send(v,1,sendtype,procToSend,tag,communicator,info) !!!$ call mpi_send(v,1,sendtype,procToSend,tag,communicator,info)
! end subroutine send_routine ! end subroutine send_routine
end subroutine psi_dswapidx_vect_mptx end subroutine psi_dswapidx_vect_mptx

Write Preview
Loading…
Cancel
Save