mirror of
https://github.com/sfilippone/psblas3.git
synced 2026-10-06 22:55:08 +00:00
psblas3:
Changelog base/comm/psb_cspgather.F90 base/comm/psb_dspgather.F90 base/comm/psb_sspgather.F90 base/comm/psb_zspgather.F90 base/internals/psi_bld_tmphalo.f90 base/internals/psi_cswapdata.F90 base/internals/psi_desc_impl.f90 base/internals/psi_dswapdata.F90 base/internals/psi_sswapdata.F90 base/internals/psi_zswapdata.F90 base/modules/Makefile base/modules/psb_c_base_vect_mod.f90 base/modules/psb_c_linmap_mod.f90 base/modules/psb_c_tools_mod.f90 base/modules/psb_c_vect_mod.F90 base/modules/psb_cd_tools_mod.f90 base/modules/psb_d_base_vect_mod.f90 base/modules/psb_d_linmap_mod.f90 base/modules/psb_d_tools_mod.f90 base/modules/psb_d_vect_mod.F90 base/modules/psb_desc_mod.F90 base/modules/psb_i_base_vect_mod.f90 base/modules/psb_i_vect_mod.F90 base/modules/psb_s_base_vect_mod.f90 base/modules/psb_s_linmap_mod.f90 base/modules/psb_s_tools_mod.f90 base/modules/psb_s_vect_mod.F90 base/modules/psb_z_base_vect_mod.f90 base/modules/psb_z_linmap_mod.f90 base/modules/psb_z_tools_mod.f90 base/modules/psb_z_vect_mod.F90 base/modules/psi_c_mod.f90 base/modules/psi_d_mod.f90 base/modules/psi_i_mod.f90 base/modules/psi_s_mod.f90 base/modules/psi_z_mod.f90 base/tools/psb_c_map.f90 base/tools/psb_ccdbldext.F90 base/tools/psb_cd_lstext.f90 base/tools/psb_cdcpy.F90 base/tools/psb_csphalo.F90 base/tools/psb_d_map.f90 base/tools/psb_dcdbldext.F90 base/tools/psb_dsphalo.F90 base/tools/psb_icdasb.F90 base/tools/psb_iins.f90 base/tools/psb_s_map.f90 base/tools/psb_scdbldext.F90 base/tools/psb_ssphalo.F90 base/tools/psb_z_map.f90 base/tools/psb_zcdbldext.F90 base/tools/psb_zsphalo.F90 config/pac.m4 configure.ac configure test/pargen/Makefile util/Makefile util/metis_int.c util/psb_d_genpde_impl.f90 util/psb_d_genpde_mod.f90 util/psb_metispart_mod.F90 util/psb_s_genpde_impl.f90 util/psb_s_genpde_mod.f90 Merged changes from 399 branch.
This commit is contained in:
Salvatore Filippone
@@ -1,5 +1,7 @@
|
||||
Changelog. A lot less detailed than usual, at least for past
|
||||
history.
|
||||
2013/11/07: Merged integer vector changes.
|
||||
|
||||
2013/10/01: New desc_type methods calling into indxmap methods.
|
||||
|
||||
2013/09/30: Restructure index conversion methods, simplify.
|
||||
|
||||
@@ -113,9 +113,9 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
|
||||
idisp(ip) = sum(nzbr(1:ip-1))
|
||||
enddo
|
||||
ndx = nzbr(me+1)
|
||||
call mpi_allgatherv(loc_coo%val,ndx,mpi_complex,&
|
||||
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_c_spk_,&
|
||||
& glob_coo%val,nzbr,idisp,&
|
||||
& mpi_complex,icomm,minfo)
|
||||
& psb_mpi_c_spk_,icomm,minfo)
|
||||
if (minfo == psb_success_) call &
|
||||
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_integer,&
|
||||
& glob_coo%ia,nzbr,idisp,&
|
||||
|
||||
@@ -113,9 +113,9 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
|
||||
idisp(ip) = sum(nzbr(1:ip-1))
|
||||
enddo
|
||||
ndx = nzbr(me+1)
|
||||
call mpi_allgatherv(loc_coo%val,ndx,mpi_double_precision,&
|
||||
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_r_dpk_,&
|
||||
& glob_coo%val,nzbr,idisp,&
|
||||
& mpi_double_precision,icomm,minfo)
|
||||
& psb_mpi_r_dpk_,icomm,minfo)
|
||||
if (minfo == psb_success_) call &
|
||||
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_integer,&
|
||||
& glob_coo%ia,nzbr,idisp,&
|
||||
|
||||
@@ -113,9 +113,9 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
|
||||
idisp(ip) = sum(nzbr(1:ip-1))
|
||||
enddo
|
||||
ndx = nzbr(me+1)
|
||||
call mpi_allgatherv(loc_coo%val,ndx,mpi_real,&
|
||||
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_r_spk_,&
|
||||
& glob_coo%val,nzbr,idisp,&
|
||||
& mpi_real,icomm,minfo)
|
||||
& psb_mpi_r_spk_,icomm,minfo)
|
||||
if (minfo == psb_success_) call &
|
||||
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_integer,&
|
||||
& glob_coo%ia,nzbr,idisp,&
|
||||
|
||||
@@ -113,9 +113,9 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
|
||||
idisp(ip) = sum(nzbr(1:ip-1))
|
||||
enddo
|
||||
ndx = nzbr(me+1)
|
||||
call mpi_allgatherv(loc_coo%val,ndx,mpi_double_complex,&
|
||||
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_c_dpk_,&
|
||||
& glob_coo%val,nzbr,idisp,&
|
||||
& mpi_double_complex,icomm,minfo)
|
||||
& psb_mpi_c_dpk_,icomm,minfo)
|
||||
if (minfo == psb_success_) call &
|
||||
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_integer,&
|
||||
& glob_coo%ia,nzbr,idisp,&
|
||||
|
||||
@@ -81,7 +81,7 @@ subroutine psi_bld_tmphalo(desc,info)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
if (.not.(psb_is_bld_desc(desc).and.allocated(desc%indxmap))) then
|
||||
if (.not.(desc%is_bld())) then
|
||||
info = psb_err_invalid_cd_state_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
|
||||
@@ -1040,6 +1040,7 @@ subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data)
|
||||
! locals
|
||||
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
|
||||
integer(psb_ipk_), pointer :: d_idx(:)
|
||||
class(psb_i_base_vect_type), pointer :: d_vidx
|
||||
character(len=20) :: name
|
||||
|
||||
info=psb_success_
|
||||
@@ -1068,13 +1069,14 @@ subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data)
|
||||
data_ = psb_comm_halo_
|
||||
end if
|
||||
|
||||
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
|
||||
!!$ call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
|
||||
call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
|
||||
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_vidx,totxch,idxs,idxr,work,info)
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
@@ -1451,3 +1453,366 @@ subroutine psi_cswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,
|
||||
return
|
||||
end subroutine psi_cswapidx_vect
|
||||
|
||||
|
||||
subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
|
||||
|
||||
use psi_mod, psb_protect_name => psi_cswap_vidx_vect
|
||||
use psb_error_mod
|
||||
use psb_desc_mod
|
||||
use psb_penv_mod
|
||||
use psb_c_base_vect_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
|
||||
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_c_base_vect_type) :: y
|
||||
complex(psb_spk_) :: beta
|
||||
complex(psb_spk_), target :: work(:)
|
||||
class(psb_i_base_vect_type), intent(in) :: idx
|
||||
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
|
||||
|
||||
! locals
|
||||
integer(psb_mpik_) :: ictxt, icomm, np, me,&
|
||||
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
|
||||
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
|
||||
& sdsz, rvsz, prcid, rvhd, sdhd
|
||||
integer(psb_ipk_) :: nesd, nerv,&
|
||||
& err_act, i, idx_pt, totsnd_, totrcv_,&
|
||||
& snd_pt, rcv_pt, pnti, n
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
|
||||
& albf,do_send,do_recv
|
||||
logical, parameter :: usersend=.false.
|
||||
|
||||
complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf
|
||||
#ifdef HAVE_VOLATILE
|
||||
volatile :: sndbuf, rcvbuf
|
||||
#endif
|
||||
character(len=20) :: name
|
||||
|
||||
info=psb_success_
|
||||
name='psi_swap_datav'
|
||||
call psb_erractionsave(err_act)
|
||||
ictxt = iictxt
|
||||
icomm = iicomm
|
||||
call psb_info(ictxt,me,np)
|
||||
if (np == -1) then
|
||||
info=psb_err_context_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
n=1
|
||||
|
||||
swap_mpi = iand(flag,psb_swap_mpi_) /= 0
|
||||
swap_sync = iand(flag,psb_swap_sync_) /= 0
|
||||
swap_send = iand(flag,psb_swap_send_) /= 0
|
||||
swap_recv = iand(flag,psb_swap_recv_) /= 0
|
||||
do_send = swap_mpi .or. swap_sync .or. swap_send
|
||||
do_recv = swap_mpi .or. swap_sync .or. swap_recv
|
||||
|
||||
totrcv_ = totrcv * n
|
||||
totsnd_ = totsnd * n
|
||||
|
||||
if (swap_mpi) then
|
||||
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
|
||||
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
|
||||
& stat=info)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
rvhd(:) = mpi_request_null
|
||||
sdsz(:) = 0
|
||||
rvsz(:) = 0
|
||||
|
||||
! prepare info for communications
|
||||
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
|
||||
|
||||
brvidx(proc_to_comm) = rcv_pt
|
||||
rvsz(proc_to_comm) = nerv
|
||||
|
||||
bsdidx(proc_to_comm) = snd_pt
|
||||
sdsz(proc_to_comm) = nesd
|
||||
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
|
||||
end do
|
||||
|
||||
else
|
||||
allocate(rvhd(totxch),prcid(totxch),stat=info)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,name)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
|
||||
|
||||
totrcv_ = max(totrcv_,1)
|
||||
totsnd_ = max(totsnd_,1)
|
||||
if((totrcv_+totsnd_) < size(work)) then
|
||||
sndbuf => work(1:totsnd_)
|
||||
rcvbuf => work(totsnd_+1:totsnd_+totrcv_)
|
||||
albf=.false.
|
||||
else
|
||||
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,name)
|
||||
goto 9999
|
||||
end if
|
||||
albf=.true.
|
||||
end if
|
||||
|
||||
|
||||
if (do_send) then
|
||||
|
||||
! Pack send buffers
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
do i=1, totxch
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
idx_pt = 1+pnti+nerv+psb_n_elem_send_
|
||||
call y%gth(idx_pt,nesd,idx,&
|
||||
& sndbuf(snd_pt:snd_pt+nesd-1))
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
end if
|
||||
|
||||
! Case SWAP_MPI
|
||||
if (swap_mpi) then
|
||||
|
||||
! swap elements using mpi_alltoallv
|
||||
call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
|
||||
& psb_mpi_c_spk_,rcvbuf,rvsz,&
|
||||
& brvidx,psb_mpi_c_spk_,icomm,iret)
|
||||
if(iret /= mpi_success) then
|
||||
ierr(1) = iret
|
||||
info=psb_err_mpi_error_
|
||||
call psb_errpush(info,name,i_err=ierr)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
else if (swap_sync) then
|
||||
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
|
||||
if (proc_to_comm < me) then
|
||||
if (nesd>0) call psb_snd(ictxt,&
|
||||
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
|
||||
if (nerv>0) call psb_rcv(ictxt,&
|
||||
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
|
||||
else if (proc_to_comm > me) then
|
||||
if (nerv>0) call psb_rcv(ictxt,&
|
||||
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
|
||||
if (nesd>0) call psb_snd(ictxt,&
|
||||
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
|
||||
else if (proc_to_comm == me) then
|
||||
if (nesd /= nerv) then
|
||||
write(psb_err_unit,*) &
|
||||
& 'Fatal error in swapdata: mismatch on self send',&
|
||||
& nerv,nesd
|
||||
end if
|
||||
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
|
||||
end if
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
|
||||
else if (swap_send .and. swap_recv) then
|
||||
|
||||
! First I post all the non blocking receives
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
|
||||
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
|
||||
if ((nerv>0).and.(proc_to_comm /= me)) then
|
||||
p2ptag = psb_complex_swap_tag
|
||||
call mpi_irecv(rcvbuf(rcv_pt),nerv,&
|
||||
& psb_mpi_c_spk_,prcid(i),&
|
||||
& p2ptag, icomm,rvhd(i),iret)
|
||||
end if
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
|
||||
! Then I post all the blocking sends
|
||||
if (usersend) call mpi_barrier(icomm,iret)
|
||||
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
|
||||
p2ptag = psb_complex_swap_tag
|
||||
|
||||
if ((nesd>0).and.(proc_to_comm /= me)) then
|
||||
if (usersend) then
|
||||
call mpi_rsend(sndbuf(snd_pt),nesd,&
|
||||
& psb_mpi_c_spk_,prcid(i),&
|
||||
& p2ptag,icomm,iret)
|
||||
else
|
||||
call mpi_send(sndbuf(snd_pt),nesd,&
|
||||
& psb_mpi_c_spk_,prcid(i),&
|
||||
& p2ptag,icomm,iret)
|
||||
end if
|
||||
|
||||
if(iret /= mpi_success) then
|
||||
ierr(1) = iret
|
||||
info=psb_err_mpi_error_
|
||||
call psb_errpush(info,name,i_err=ierr)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
|
||||
pnti = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
|
||||
p2ptag = psb_complex_swap_tag
|
||||
|
||||
if ((proc_to_comm /= me).and.(nerv>0)) then
|
||||
call mpi_wait(rvhd(i),p2pstat,iret)
|
||||
if(iret /= mpi_success) then
|
||||
ierr(1) = iret
|
||||
info=psb_err_mpi_error_
|
||||
call psb_errpush(info,name,i_err=ierr)
|
||||
goto 9999
|
||||
end if
|
||||
else if (proc_to_comm == me) then
|
||||
if (nesd /= nerv) then
|
||||
write(psb_err_unit,*) &
|
||||
& 'Fatal error in swapdata: mismatch on self send',&
|
||||
& nerv,nesd
|
||||
end if
|
||||
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
|
||||
end if
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
|
||||
else if (swap_send) then
|
||||
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
if (nesd>0) call psb_snd(ictxt,&
|
||||
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
else if (swap_recv) then
|
||||
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
if (nerv>0) call psb_rcv(ictxt,&
|
||||
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
end if
|
||||
|
||||
if (do_recv) then
|
||||
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
idx_pt = 1+pnti+psb_n_elem_recv_
|
||||
call y%sct(idx_pt,nerv,idx,&
|
||||
& rcvbuf(rcv_pt:rcv_pt+nerv-1),beta)
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
end if
|
||||
|
||||
if (swap_mpi) then
|
||||
deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,&
|
||||
& stat=info)
|
||||
else
|
||||
deallocate(rvhd,prcid,stat=info)
|
||||
end if
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,name)
|
||||
goto 9999
|
||||
end if
|
||||
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error(ictxt)
|
||||
return
|
||||
end if
|
||||
return
|
||||
end subroutine psi_cswap_vidx_vect
|
||||
|
||||
|
||||
@@ -60,7 +60,7 @@ subroutine psi_renum_index(iperm,idx,info)
|
||||
|
||||
end subroutine psi_renum_index
|
||||
|
||||
subroutine psi_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info)
|
||||
subroutine psi_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold)
|
||||
|
||||
use psi_mod, psi_protect_name => psi_cnv_dsc
|
||||
use psb_realloc_mod
|
||||
@@ -70,6 +70,7 @@ subroutine psi_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info)
|
||||
integer(psb_ipk_), intent(in) :: halo_in(:), ovrlap_in(:),ext_in(:)
|
||||
type(psb_desc_type), intent(inout) :: cdesc
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_i_base_vect_type), optional, intent(in) :: mold
|
||||
|
||||
! ....local scalars....
|
||||
integer(psb_ipk_) :: np,me
|
||||
@@ -107,9 +108,6 @@ subroutine psi_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info)
|
||||
goto 9999
|
||||
end if
|
||||
call psb_move_alloc(idx_out,cdesc%halo_index,info)
|
||||
!!$ cdesc%matrix_data(psb_thal_xch_) = nxch
|
||||
!!$ cdesc%matrix_data(psb_thal_snd_) = nsnd
|
||||
!!$ cdesc%matrix_data(psb_thal_rcv_) = nrcv
|
||||
|
||||
if (debug_level>0) write(debug_unit,*) me,'Done crea_index on halo'
|
||||
if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on ext'
|
||||
@@ -123,9 +121,6 @@ subroutine psi_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info)
|
||||
goto 9999
|
||||
end if
|
||||
call psb_move_alloc(idx_out,cdesc%ext_index,info)
|
||||
!!$ cdesc%matrix_data(psb_text_xch_) = nxch
|
||||
!!$ cdesc%matrix_data(psb_text_snd_) = nsnd
|
||||
!!$ cdesc%matrix_data(psb_text_rcv_) = nrcv
|
||||
|
||||
if (debug_level>0) write(debug_unit,*) me,'Done crea_index on ext'
|
||||
if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on ovrlap'
|
||||
@@ -142,9 +137,6 @@ subroutine psi_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!!$ cdesc%matrix_data(psb_tovr_xch_) = nxch
|
||||
!!$ cdesc%matrix_data(psb_tovr_snd_) = nsnd
|
||||
!!$ cdesc%matrix_data(psb_tovr_rcv_) = nrcv
|
||||
|
||||
! next ovrlap_elem
|
||||
if (debug_level>0) write(debug_unit,*) me,'Calling crea_ovr_elem'
|
||||
@@ -170,14 +162,16 @@ subroutine psi_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!!$ cdesc%matrix_data(psb_tmov_xch_) = nxch
|
||||
!!$ cdesc%matrix_data(psb_tmov_snd_) = nsnd
|
||||
!!$ cdesc%matrix_data(psb_tmov_rcv_) = nrcv
|
||||
|
||||
! finally bnd_elem
|
||||
call psi_crea_bnd_elem(idx_out,cdesc,info)
|
||||
if (info == psb_success_) call psb_move_alloc(idx_out,cdesc%bnd_elem,info)
|
||||
|
||||
call cdesc%v_halo_index%bld(cdesc%halo_index,mold=mold)
|
||||
call cdesc%v_ext_index%bld(cdesc%ext_index,mold=mold)
|
||||
call cdesc%v_ovrlap_index%bld(cdesc%ovrlap_index,mold=mold)
|
||||
call cdesc%v_ovr_mst_idx%bld(cdesc%ovr_mst_idx,mold=mold)
|
||||
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_crea_bnd_elem')
|
||||
goto 9999
|
||||
|
||||
@@ -1040,6 +1040,7 @@ subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data)
|
||||
! locals
|
||||
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
|
||||
integer(psb_ipk_), pointer :: d_idx(:)
|
||||
class(psb_i_base_vect_type), pointer :: d_vidx
|
||||
character(len=20) :: name
|
||||
|
||||
info=psb_success_
|
||||
@@ -1068,13 +1069,14 @@ subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data)
|
||||
data_ = psb_comm_halo_
|
||||
end if
|
||||
|
||||
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
|
||||
!!$ call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
|
||||
call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
|
||||
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_vidx,totxch,idxs,idxr,work,info)
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
@@ -1451,3 +1453,366 @@ subroutine psi_dswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,
|
||||
return
|
||||
end subroutine psi_dswapidx_vect
|
||||
|
||||
|
||||
subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
|
||||
|
||||
use psi_mod, psb_protect_name => psi_dswap_vidx_vect
|
||||
use psb_error_mod
|
||||
use psb_desc_mod
|
||||
use psb_penv_mod
|
||||
use psb_d_base_vect_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
|
||||
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_d_base_vect_type) :: y
|
||||
real(psb_dpk_) :: beta
|
||||
real(psb_dpk_), target :: work(:)
|
||||
class(psb_i_base_vect_type), intent(in) :: idx
|
||||
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
|
||||
|
||||
! locals
|
||||
integer(psb_mpik_) :: ictxt, icomm, np, me,&
|
||||
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
|
||||
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
|
||||
& sdsz, rvsz, prcid, rvhd, sdhd
|
||||
integer(psb_ipk_) :: nesd, nerv,&
|
||||
& err_act, i, idx_pt, totsnd_, totrcv_,&
|
||||
& snd_pt, rcv_pt, pnti, n
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
|
||||
& albf,do_send,do_recv
|
||||
logical, parameter :: usersend=.false.
|
||||
|
||||
real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf
|
||||
#ifdef HAVE_VOLATILE
|
||||
volatile :: sndbuf, rcvbuf
|
||||
#endif
|
||||
character(len=20) :: name
|
||||
|
||||
info=psb_success_
|
||||
name='psi_swap_datav'
|
||||
call psb_erractionsave(err_act)
|
||||
ictxt = iictxt
|
||||
icomm = iicomm
|
||||
call psb_info(ictxt,me,np)
|
||||
if (np == -1) then
|
||||
info=psb_err_context_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
n=1
|
||||
|
||||
swap_mpi = iand(flag,psb_swap_mpi_) /= 0
|
||||
swap_sync = iand(flag,psb_swap_sync_) /= 0
|
||||
swap_send = iand(flag,psb_swap_send_) /= 0
|
||||
swap_recv = iand(flag,psb_swap_recv_) /= 0
|
||||
do_send = swap_mpi .or. swap_sync .or. swap_send
|
||||
do_recv = swap_mpi .or. swap_sync .or. swap_recv
|
||||
|
||||
totrcv_ = totrcv * n
|
||||
totsnd_ = totsnd * n
|
||||
|
||||
if (swap_mpi) then
|
||||
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
|
||||
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
|
||||
& stat=info)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
rvhd(:) = mpi_request_null
|
||||
sdsz(:) = 0
|
||||
rvsz(:) = 0
|
||||
|
||||
! prepare info for communications
|
||||
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
|
||||
|
||||
brvidx(proc_to_comm) = rcv_pt
|
||||
rvsz(proc_to_comm) = nerv
|
||||
|
||||
bsdidx(proc_to_comm) = snd_pt
|
||||
sdsz(proc_to_comm) = nesd
|
||||
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
|
||||
end do
|
||||
|
||||
else
|
||||
allocate(rvhd(totxch),prcid(totxch),stat=info)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,name)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
|
||||
|
||||
totrcv_ = max(totrcv_,1)
|
||||
totsnd_ = max(totsnd_,1)
|
||||
if((totrcv_+totsnd_) < size(work)) then
|
||||
sndbuf => work(1:totsnd_)
|
||||
rcvbuf => work(totsnd_+1:totsnd_+totrcv_)
|
||||
albf=.false.
|
||||
else
|
||||
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,name)
|
||||
goto 9999
|
||||
end if
|
||||
albf=.true.
|
||||
end if
|
||||
|
||||
|
||||
if (do_send) then
|
||||
|
||||
! Pack send buffers
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
do i=1, totxch
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
idx_pt = 1+pnti+nerv+psb_n_elem_send_
|
||||
call y%gth(idx_pt,nesd,idx,&
|
||||
& sndbuf(snd_pt:snd_pt+nesd-1))
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
end if
|
||||
|
||||
! Case SWAP_MPI
|
||||
if (swap_mpi) then
|
||||
|
||||
! swap elements using mpi_alltoallv
|
||||
call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
|
||||
& psb_mpi_r_dpk_,rcvbuf,rvsz,&
|
||||
& brvidx,psb_mpi_r_dpk_,icomm,iret)
|
||||
if(iret /= mpi_success) then
|
||||
ierr(1) = iret
|
||||
info=psb_err_mpi_error_
|
||||
call psb_errpush(info,name,i_err=ierr)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
else if (swap_sync) then
|
||||
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
|
||||
if (proc_to_comm < me) then
|
||||
if (nesd>0) call psb_snd(ictxt,&
|
||||
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
|
||||
if (nerv>0) call psb_rcv(ictxt,&
|
||||
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
|
||||
else if (proc_to_comm > me) then
|
||||
if (nerv>0) call psb_rcv(ictxt,&
|
||||
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
|
||||
if (nesd>0) call psb_snd(ictxt,&
|
||||
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
|
||||
else if (proc_to_comm == me) then
|
||||
if (nesd /= nerv) then
|
||||
write(psb_err_unit,*) &
|
||||
& 'Fatal error in swapdata: mismatch on self send',&
|
||||
& nerv,nesd
|
||||
end if
|
||||
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
|
||||
end if
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
|
||||
else if (swap_send .and. swap_recv) then
|
||||
|
||||
! First I post all the non blocking receives
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
|
||||
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
|
||||
if ((nerv>0).and.(proc_to_comm /= me)) then
|
||||
p2ptag = psb_double_swap_tag
|
||||
call mpi_irecv(rcvbuf(rcv_pt),nerv,&
|
||||
& psb_mpi_r_dpk_,prcid(i),&
|
||||
& p2ptag, icomm,rvhd(i),iret)
|
||||
end if
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
|
||||
! Then I post all the blocking sends
|
||||
if (usersend) call mpi_barrier(icomm,iret)
|
||||
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
|
||||
p2ptag = psb_double_swap_tag
|
||||
|
||||
if ((nesd>0).and.(proc_to_comm /= me)) then
|
||||
if (usersend) then
|
||||
call mpi_rsend(sndbuf(snd_pt),nesd,&
|
||||
& psb_mpi_r_dpk_,prcid(i),&
|
||||
& p2ptag,icomm,iret)
|
||||
else
|
||||
call mpi_send(sndbuf(snd_pt),nesd,&
|
||||
& psb_mpi_r_dpk_,prcid(i),&
|
||||
& p2ptag,icomm,iret)
|
||||
end if
|
||||
|
||||
if(iret /= mpi_success) then
|
||||
ierr(1) = iret
|
||||
info=psb_err_mpi_error_
|
||||
call psb_errpush(info,name,i_err=ierr)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
|
||||
pnti = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
|
||||
p2ptag = psb_double_swap_tag
|
||||
|
||||
if ((proc_to_comm /= me).and.(nerv>0)) then
|
||||
call mpi_wait(rvhd(i),p2pstat,iret)
|
||||
if(iret /= mpi_success) then
|
||||
ierr(1) = iret
|
||||
info=psb_err_mpi_error_
|
||||
call psb_errpush(info,name,i_err=ierr)
|
||||
goto 9999
|
||||
end if
|
||||
else if (proc_to_comm == me) then
|
||||
if (nesd /= nerv) then
|
||||
write(psb_err_unit,*) &
|
||||
& 'Fatal error in swapdata: mismatch on self send',&
|
||||
& nerv,nesd
|
||||
end if
|
||||
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
|
||||
end if
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
|
||||
else if (swap_send) then
|
||||
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
if (nesd>0) call psb_snd(ictxt,&
|
||||
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
else if (swap_recv) then
|
||||
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
if (nerv>0) call psb_rcv(ictxt,&
|
||||
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
end if
|
||||
|
||||
if (do_recv) then
|
||||
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
idx_pt = 1+pnti+psb_n_elem_recv_
|
||||
call y%sct(idx_pt,nerv,idx,&
|
||||
& rcvbuf(rcv_pt:rcv_pt+nerv-1),beta)
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
end if
|
||||
|
||||
if (swap_mpi) then
|
||||
deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,&
|
||||
& stat=info)
|
||||
else
|
||||
deallocate(rvhd,prcid,stat=info)
|
||||
end if
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,name)
|
||||
goto 9999
|
||||
end if
|
||||
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error(ictxt)
|
||||
return
|
||||
end if
|
||||
return
|
||||
end subroutine psi_dswap_vidx_vect
|
||||
|
||||
|
||||
@@ -1040,6 +1040,7 @@ subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data)
|
||||
! locals
|
||||
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
|
||||
integer(psb_ipk_), pointer :: d_idx(:)
|
||||
class(psb_i_base_vect_type), pointer :: d_vidx
|
||||
character(len=20) :: name
|
||||
|
||||
info=psb_success_
|
||||
@@ -1068,13 +1069,14 @@ subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data)
|
||||
data_ = psb_comm_halo_
|
||||
end if
|
||||
|
||||
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
|
||||
!!$ call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
|
||||
call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
|
||||
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_vidx,totxch,idxs,idxr,work,info)
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
@@ -1451,3 +1453,366 @@ subroutine psi_sswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,
|
||||
return
|
||||
end subroutine psi_sswapidx_vect
|
||||
|
||||
|
||||
subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
|
||||
|
||||
use psi_mod, psb_protect_name => psi_sswap_vidx_vect
|
||||
use psb_error_mod
|
||||
use psb_desc_mod
|
||||
use psb_penv_mod
|
||||
use psb_s_base_vect_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
|
||||
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_s_base_vect_type) :: y
|
||||
real(psb_spk_) :: beta
|
||||
real(psb_spk_), target :: work(:)
|
||||
class(psb_i_base_vect_type), intent(in) :: idx
|
||||
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
|
||||
|
||||
! locals
|
||||
integer(psb_mpik_) :: ictxt, icomm, np, me,&
|
||||
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
|
||||
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
|
||||
& sdsz, rvsz, prcid, rvhd, sdhd
|
||||
integer(psb_ipk_) :: nesd, nerv,&
|
||||
& err_act, i, idx_pt, totsnd_, totrcv_,&
|
||||
& snd_pt, rcv_pt, pnti, n
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
|
||||
& albf,do_send,do_recv
|
||||
logical, parameter :: usersend=.false.
|
||||
|
||||
real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf
|
||||
#ifdef HAVE_VOLATILE
|
||||
volatile :: sndbuf, rcvbuf
|
||||
#endif
|
||||
character(len=20) :: name
|
||||
|
||||
info=psb_success_
|
||||
name='psi_swap_datav'
|
||||
call psb_erractionsave(err_act)
|
||||
ictxt = iictxt
|
||||
icomm = iicomm
|
||||
call psb_info(ictxt,me,np)
|
||||
if (np == -1) then
|
||||
info=psb_err_context_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
n=1
|
||||
|
||||
swap_mpi = iand(flag,psb_swap_mpi_) /= 0
|
||||
swap_sync = iand(flag,psb_swap_sync_) /= 0
|
||||
swap_send = iand(flag,psb_swap_send_) /= 0
|
||||
swap_recv = iand(flag,psb_swap_recv_) /= 0
|
||||
do_send = swap_mpi .or. swap_sync .or. swap_send
|
||||
do_recv = swap_mpi .or. swap_sync .or. swap_recv
|
||||
|
||||
totrcv_ = totrcv * n
|
||||
totsnd_ = totsnd * n
|
||||
|
||||
if (swap_mpi) then
|
||||
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
|
||||
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
|
||||
& stat=info)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
rvhd(:) = mpi_request_null
|
||||
sdsz(:) = 0
|
||||
rvsz(:) = 0
|
||||
|
||||
! prepare info for communications
|
||||
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
|
||||
|
||||
brvidx(proc_to_comm) = rcv_pt
|
||||
rvsz(proc_to_comm) = nerv
|
||||
|
||||
bsdidx(proc_to_comm) = snd_pt
|
||||
sdsz(proc_to_comm) = nesd
|
||||
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
|
||||
end do
|
||||
|
||||
else
|
||||
allocate(rvhd(totxch),prcid(totxch),stat=info)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,name)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
|
||||
|
||||
totrcv_ = max(totrcv_,1)
|
||||
totsnd_ = max(totsnd_,1)
|
||||
if((totrcv_+totsnd_) < size(work)) then
|
||||
sndbuf => work(1:totsnd_)
|
||||
rcvbuf => work(totsnd_+1:totsnd_+totrcv_)
|
||||
albf=.false.
|
||||
else
|
||||
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,name)
|
||||
goto 9999
|
||||
end if
|
||||
albf=.true.
|
||||
end if
|
||||
|
||||
|
||||
if (do_send) then
|
||||
|
||||
! Pack send buffers
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
do i=1, totxch
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
idx_pt = 1+pnti+nerv+psb_n_elem_send_
|
||||
call y%gth(idx_pt,nesd,idx,&
|
||||
& sndbuf(snd_pt:snd_pt+nesd-1))
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
end if
|
||||
|
||||
! Case SWAP_MPI
|
||||
if (swap_mpi) then
|
||||
|
||||
! swap elements using mpi_alltoallv
|
||||
call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
|
||||
& psb_mpi_r_spk_,rcvbuf,rvsz,&
|
||||
& brvidx,psb_mpi_r_spk_,icomm,iret)
|
||||
if(iret /= mpi_success) then
|
||||
ierr(1) = iret
|
||||
info=psb_err_mpi_error_
|
||||
call psb_errpush(info,name,i_err=ierr)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
else if (swap_sync) then
|
||||
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
|
||||
if (proc_to_comm < me) then
|
||||
if (nesd>0) call psb_snd(ictxt,&
|
||||
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
|
||||
if (nerv>0) call psb_rcv(ictxt,&
|
||||
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
|
||||
else if (proc_to_comm > me) then
|
||||
if (nerv>0) call psb_rcv(ictxt,&
|
||||
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
|
||||
if (nesd>0) call psb_snd(ictxt,&
|
||||
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
|
||||
else if (proc_to_comm == me) then
|
||||
if (nesd /= nerv) then
|
||||
write(psb_err_unit,*) &
|
||||
& 'Fatal error in swapdata: mismatch on self send',&
|
||||
& nerv,nesd
|
||||
end if
|
||||
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
|
||||
end if
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
|
||||
else if (swap_send .and. swap_recv) then
|
||||
|
||||
! First I post all the non blocking receives
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
|
||||
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
|
||||
if ((nerv>0).and.(proc_to_comm /= me)) then
|
||||
p2ptag = psb_real_swap_tag
|
||||
call mpi_irecv(rcvbuf(rcv_pt),nerv,&
|
||||
& psb_mpi_r_spk_,prcid(i),&
|
||||
& p2ptag, icomm,rvhd(i),iret)
|
||||
end if
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
|
||||
! Then I post all the blocking sends
|
||||
if (usersend) call mpi_barrier(icomm,iret)
|
||||
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
|
||||
p2ptag = psb_real_swap_tag
|
||||
|
||||
if ((nesd>0).and.(proc_to_comm /= me)) then
|
||||
if (usersend) then
|
||||
call mpi_rsend(sndbuf(snd_pt),nesd,&
|
||||
& psb_mpi_r_spk_,prcid(i),&
|
||||
& p2ptag,icomm,iret)
|
||||
else
|
||||
call mpi_send(sndbuf(snd_pt),nesd,&
|
||||
& psb_mpi_r_spk_,prcid(i),&
|
||||
& p2ptag,icomm,iret)
|
||||
end if
|
||||
|
||||
if(iret /= mpi_success) then
|
||||
ierr(1) = iret
|
||||
info=psb_err_mpi_error_
|
||||
call psb_errpush(info,name,i_err=ierr)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
|
||||
pnti = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
|
||||
p2ptag = psb_real_swap_tag
|
||||
|
||||
if ((proc_to_comm /= me).and.(nerv>0)) then
|
||||
call mpi_wait(rvhd(i),p2pstat,iret)
|
||||
if(iret /= mpi_success) then
|
||||
ierr(1) = iret
|
||||
info=psb_err_mpi_error_
|
||||
call psb_errpush(info,name,i_err=ierr)
|
||||
goto 9999
|
||||
end if
|
||||
else if (proc_to_comm == me) then
|
||||
if (nesd /= nerv) then
|
||||
write(psb_err_unit,*) &
|
||||
& 'Fatal error in swapdata: mismatch on self send',&
|
||||
& nerv,nesd
|
||||
end if
|
||||
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
|
||||
end if
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
|
||||
else if (swap_send) then
|
||||
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
if (nesd>0) call psb_snd(ictxt,&
|
||||
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
else if (swap_recv) then
|
||||
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
if (nerv>0) call psb_rcv(ictxt,&
|
||||
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
end if
|
||||
|
||||
if (do_recv) then
|
||||
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
idx_pt = 1+pnti+psb_n_elem_recv_
|
||||
call y%sct(idx_pt,nerv,idx,&
|
||||
& rcvbuf(rcv_pt:rcv_pt+nerv-1),beta)
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
end if
|
||||
|
||||
if (swap_mpi) then
|
||||
deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,&
|
||||
& stat=info)
|
||||
else
|
||||
deallocate(rvhd,prcid,stat=info)
|
||||
end if
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,name)
|
||||
goto 9999
|
||||
end if
|
||||
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error(ictxt)
|
||||
return
|
||||
end if
|
||||
return
|
||||
end subroutine psi_sswap_vidx_vect
|
||||
|
||||
|
||||
@@ -1040,6 +1040,7 @@ subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data)
|
||||
! locals
|
||||
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
|
||||
integer(psb_ipk_), pointer :: d_idx(:)
|
||||
class(psb_i_base_vect_type), pointer :: d_vidx
|
||||
character(len=20) :: name
|
||||
|
||||
info=psb_success_
|
||||
@@ -1068,13 +1069,14 @@ subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data)
|
||||
data_ = psb_comm_halo_
|
||||
end if
|
||||
|
||||
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
|
||||
!!$ call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
|
||||
call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
|
||||
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_vidx,totxch,idxs,idxr,work,info)
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
@@ -1451,3 +1453,366 @@ subroutine psi_zswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,
|
||||
return
|
||||
end subroutine psi_zswapidx_vect
|
||||
|
||||
|
||||
subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
|
||||
|
||||
use psi_mod, psb_protect_name => psi_zswap_vidx_vect
|
||||
use psb_error_mod
|
||||
use psb_desc_mod
|
||||
use psb_penv_mod
|
||||
use psb_z_base_vect_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
|
||||
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_z_base_vect_type) :: y
|
||||
complex(psb_dpk_) :: beta
|
||||
complex(psb_dpk_), target :: work(:)
|
||||
class(psb_i_base_vect_type), intent(in) :: idx
|
||||
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
|
||||
|
||||
! locals
|
||||
integer(psb_mpik_) :: ictxt, icomm, np, me,&
|
||||
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
|
||||
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
|
||||
& sdsz, rvsz, prcid, rvhd, sdhd
|
||||
integer(psb_ipk_) :: nesd, nerv,&
|
||||
& err_act, i, idx_pt, totsnd_, totrcv_,&
|
||||
& snd_pt, rcv_pt, pnti, n
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
|
||||
& albf,do_send,do_recv
|
||||
logical, parameter :: usersend=.false.
|
||||
|
||||
complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf
|
||||
#ifdef HAVE_VOLATILE
|
||||
volatile :: sndbuf, rcvbuf
|
||||
#endif
|
||||
character(len=20) :: name
|
||||
|
||||
info=psb_success_
|
||||
name='psi_swap_datav'
|
||||
call psb_erractionsave(err_act)
|
||||
ictxt = iictxt
|
||||
icomm = iicomm
|
||||
call psb_info(ictxt,me,np)
|
||||
if (np == -1) then
|
||||
info=psb_err_context_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
n=1
|
||||
|
||||
swap_mpi = iand(flag,psb_swap_mpi_) /= 0
|
||||
swap_sync = iand(flag,psb_swap_sync_) /= 0
|
||||
swap_send = iand(flag,psb_swap_send_) /= 0
|
||||
swap_recv = iand(flag,psb_swap_recv_) /= 0
|
||||
do_send = swap_mpi .or. swap_sync .or. swap_send
|
||||
do_recv = swap_mpi .or. swap_sync .or. swap_recv
|
||||
|
||||
totrcv_ = totrcv * n
|
||||
totsnd_ = totsnd * n
|
||||
|
||||
if (swap_mpi) then
|
||||
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
|
||||
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
|
||||
& stat=info)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
rvhd(:) = mpi_request_null
|
||||
sdsz(:) = 0
|
||||
rvsz(:) = 0
|
||||
|
||||
! prepare info for communications
|
||||
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
|
||||
|
||||
brvidx(proc_to_comm) = rcv_pt
|
||||
rvsz(proc_to_comm) = nerv
|
||||
|
||||
bsdidx(proc_to_comm) = snd_pt
|
||||
sdsz(proc_to_comm) = nesd
|
||||
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
|
||||
end do
|
||||
|
||||
else
|
||||
allocate(rvhd(totxch),prcid(totxch),stat=info)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,name)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
|
||||
|
||||
totrcv_ = max(totrcv_,1)
|
||||
totsnd_ = max(totsnd_,1)
|
||||
if((totrcv_+totsnd_) < size(work)) then
|
||||
sndbuf => work(1:totsnd_)
|
||||
rcvbuf => work(totsnd_+1:totsnd_+totrcv_)
|
||||
albf=.false.
|
||||
else
|
||||
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,name)
|
||||
goto 9999
|
||||
end if
|
||||
albf=.true.
|
||||
end if
|
||||
|
||||
|
||||
if (do_send) then
|
||||
|
||||
! Pack send buffers
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
do i=1, totxch
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
idx_pt = 1+pnti+nerv+psb_n_elem_send_
|
||||
call y%gth(idx_pt,nesd,idx,&
|
||||
& sndbuf(snd_pt:snd_pt+nesd-1))
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
end if
|
||||
|
||||
! Case SWAP_MPI
|
||||
if (swap_mpi) then
|
||||
|
||||
! swap elements using mpi_alltoallv
|
||||
call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
|
||||
& psb_mpi_c_dpk_,rcvbuf,rvsz,&
|
||||
& brvidx,psb_mpi_c_dpk_,icomm,iret)
|
||||
if(iret /= mpi_success) then
|
||||
ierr(1) = iret
|
||||
info=psb_err_mpi_error_
|
||||
call psb_errpush(info,name,i_err=ierr)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
else if (swap_sync) then
|
||||
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
|
||||
if (proc_to_comm < me) then
|
||||
if (nesd>0) call psb_snd(ictxt,&
|
||||
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
|
||||
if (nerv>0) call psb_rcv(ictxt,&
|
||||
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
|
||||
else if (proc_to_comm > me) then
|
||||
if (nerv>0) call psb_rcv(ictxt,&
|
||||
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
|
||||
if (nesd>0) call psb_snd(ictxt,&
|
||||
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
|
||||
else if (proc_to_comm == me) then
|
||||
if (nesd /= nerv) then
|
||||
write(psb_err_unit,*) &
|
||||
& 'Fatal error in swapdata: mismatch on self send',&
|
||||
& nerv,nesd
|
||||
end if
|
||||
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
|
||||
end if
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
|
||||
else if (swap_send .and. swap_recv) then
|
||||
|
||||
! First I post all the non blocking receives
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
|
||||
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
|
||||
if ((nerv>0).and.(proc_to_comm /= me)) then
|
||||
p2ptag = psb_dcomplex_swap_tag
|
||||
call mpi_irecv(rcvbuf(rcv_pt),nerv,&
|
||||
& psb_mpi_c_dpk_,prcid(i),&
|
||||
& p2ptag, icomm,rvhd(i),iret)
|
||||
end if
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
|
||||
! Then I post all the blocking sends
|
||||
if (usersend) call mpi_barrier(icomm,iret)
|
||||
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
|
||||
p2ptag = psb_dcomplex_swap_tag
|
||||
|
||||
if ((nesd>0).and.(proc_to_comm /= me)) then
|
||||
if (usersend) then
|
||||
call mpi_rsend(sndbuf(snd_pt),nesd,&
|
||||
& psb_mpi_c_dpk_,prcid(i),&
|
||||
& p2ptag,icomm,iret)
|
||||
else
|
||||
call mpi_send(sndbuf(snd_pt),nesd,&
|
||||
& psb_mpi_c_dpk_,prcid(i),&
|
||||
& p2ptag,icomm,iret)
|
||||
end if
|
||||
|
||||
if(iret /= mpi_success) then
|
||||
ierr(1) = iret
|
||||
info=psb_err_mpi_error_
|
||||
call psb_errpush(info,name,i_err=ierr)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
|
||||
pnti = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
|
||||
p2ptag = psb_dcomplex_swap_tag
|
||||
|
||||
if ((proc_to_comm /= me).and.(nerv>0)) then
|
||||
call mpi_wait(rvhd(i),p2pstat,iret)
|
||||
if(iret /= mpi_success) then
|
||||
ierr(1) = iret
|
||||
info=psb_err_mpi_error_
|
||||
call psb_errpush(info,name,i_err=ierr)
|
||||
goto 9999
|
||||
end if
|
||||
else if (proc_to_comm == me) then
|
||||
if (nesd /= nerv) then
|
||||
write(psb_err_unit,*) &
|
||||
& 'Fatal error in swapdata: mismatch on self send',&
|
||||
& nerv,nesd
|
||||
end if
|
||||
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
|
||||
end if
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
|
||||
else if (swap_send) then
|
||||
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
if (nesd>0) call psb_snd(ictxt,&
|
||||
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
else if (swap_recv) then
|
||||
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
if (nerv>0) call psb_rcv(ictxt,&
|
||||
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
end if
|
||||
|
||||
if (do_recv) then
|
||||
|
||||
pnti = 1
|
||||
snd_pt = 1
|
||||
rcv_pt = 1
|
||||
do i=1, totxch
|
||||
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
||||
nerv = idx%v(pnti+psb_n_elem_recv_)
|
||||
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
||||
idx_pt = 1+pnti+psb_n_elem_recv_
|
||||
call y%sct(idx_pt,nerv,idx,&
|
||||
& rcvbuf(rcv_pt:rcv_pt+nerv-1),beta)
|
||||
rcv_pt = rcv_pt + nerv
|
||||
snd_pt = snd_pt + nesd
|
||||
pnti = pnti + nerv + nesd + 3
|
||||
end do
|
||||
|
||||
end if
|
||||
|
||||
if (swap_mpi) then
|
||||
deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,&
|
||||
& stat=info)
|
||||
else
|
||||
deallocate(rvhd,prcid,stat=info)
|
||||
end if
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,name)
|
||||
goto 9999
|
||||
end if
|
||||
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error(ictxt)
|
||||
return
|
||||
end if
|
||||
return
|
||||
end subroutine psi_zswap_vidx_vect
|
||||
|
||||
|
||||
@@ -61,9 +61,10 @@ psb_ip_reord_mod.o psi_serial_mod.o psb_sort_mod.o: $(BASIC_MODS)
|
||||
psb_base_mat_mod.o: psi_serial_mod.o
|
||||
psb_s_base_mat_mod.o psb_d_base_mat_mod.o psb_c_base_mat_mod.o psb_z_base_mat_mod.o: psb_base_mat_mod.o
|
||||
psb_s_base_mat_mod.o: psb_s_base_vect_mod.o
|
||||
psb_d_base_mat_mod.o: psb_d_base_vect_mod.o
|
||||
psb_d_base_mat_mod.o: psb_d_base_vect_mod.o
|
||||
psb_c_base_mat_mod.o: psb_c_base_vect_mod.o
|
||||
psb_z_base_mat_mod.o: psb_z_base_vect_mod.o
|
||||
psb_c_base_vect_mod.o psb_s_base_vect_mod.o psb_d_base_vect_mod.o psb_z_base_vect_mod.o: psb_i_base_vect_mod.o
|
||||
psb_i_base_vect_mod.o psb_c_base_vect_mod.o psb_s_base_vect_mod.o psb_d_base_vect_mod.o psb_z_base_vect_mod.o: psi_serial_mod.o psb_realloc_mod.o
|
||||
psb_s_mat_mod.o: psb_s_base_mat_mod.o psb_s_csr_mat_mod.o psb_s_csc_mat_mod.o psb_s_vect_mod.o
|
||||
psb_d_mat_mod.o: psb_d_base_mat_mod.o psb_d_csr_mat_mod.o psb_d_csc_mat_mod.o psb_d_vect_mod.o
|
||||
@@ -87,7 +88,7 @@ psi_mod.o: psb_penv_mod.o psb_desc_mod.o psi_serial_mod.o psb_serial_mod.o\
|
||||
psb_desc_mod.o: psb_penv_mod.o psb_realloc_mod.o\
|
||||
psb_hash_mod.o psb_hash_map_mod.o psb_list_map_mod.o \
|
||||
psb_repl_map_mod.o psb_gen_block_map_mod.o psb_desc_const_mod.o\
|
||||
psb_indx_map_mod.o
|
||||
psb_indx_map_mod.o psb_i_vect_mod.o
|
||||
psb_indx_map_mod.o: psb_desc_const_mod.o psb_error_mod.o psb_penv_mod.o
|
||||
psb_hash_map_mod.o psb_list_map_mod.o psb_repl_map_mod.o psb_gen_block_map_mod.o:\
|
||||
psb_indx_map_mod.o psb_desc_const_mod.o \
|
||||
|
||||
@@ -46,6 +46,7 @@ module psb_c_base_vect_mod
|
||||
|
||||
use psb_const_mod
|
||||
use psb_error_mod
|
||||
use psb_i_base_vect_mod
|
||||
|
||||
|
||||
!> \namespace psb_base_mod \class psb_c_base_vect_type
|
||||
@@ -141,9 +142,11 @@ module psb_c_base_vect_mod
|
||||
!
|
||||
procedure, pass(x) :: gthab => c_base_gthab
|
||||
procedure, pass(x) :: gthzv => c_base_gthzv
|
||||
generic, public :: gth => gthab, gthzv
|
||||
procedure, pass(x) :: gthzv_x => c_base_gthzv_x
|
||||
generic, public :: gth => gthab, gthzv, gthzv_x
|
||||
procedure, pass(y) :: sctb => c_base_sctb
|
||||
generic, public :: sct => sctb
|
||||
procedure, pass(y) :: sctb_x => c_base_sctb_x
|
||||
generic, public :: sct => sctb, sctb_x
|
||||
end type psb_c_base_vect_type
|
||||
|
||||
public :: psb_c_base_vect
|
||||
@@ -1042,6 +1045,26 @@ contains
|
||||
call psi_gth(n,idx,alpha,x%v,beta,y)
|
||||
|
||||
end subroutine c_base_gthab
|
||||
!
|
||||
! shortcut alpha=1 beta=0
|
||||
!
|
||||
!> Function base_gthzv
|
||||
!! \memberof psb_c_base_vect_type
|
||||
!! \brief gather into an array special alpha=1 beta=0
|
||||
!! Y = X(IDX(:))
|
||||
!! \param n how many entries to consider
|
||||
!! \param idx(:) indices
|
||||
subroutine c_base_gthzv_x(i,n,idx,x,y)
|
||||
use psi_serial_mod
|
||||
integer(psb_ipk_) :: i,n
|
||||
class(psb_i_base_vect_type) :: idx
|
||||
complex(psb_spk_) :: y(:)
|
||||
class(psb_c_base_vect_type) :: x
|
||||
|
||||
call x%gth(n,idx%v(i:),y)
|
||||
|
||||
end subroutine c_base_gthzv_x
|
||||
|
||||
!
|
||||
! shortcut alpha=1 beta=0
|
||||
!
|
||||
@@ -1087,4 +1110,15 @@ contains
|
||||
|
||||
end subroutine c_base_sctb
|
||||
|
||||
subroutine c_base_sctb_x(i,n,idx,x,beta,y)
|
||||
use psi_serial_mod
|
||||
integer(psb_ipk_) :: i, n
|
||||
class(psb_i_base_vect_type) :: idx
|
||||
complex(psb_spk_) :: beta, x(:)
|
||||
class(psb_c_base_vect_type) :: y
|
||||
|
||||
call y%sct(n,idx%v(i:),x,beta)
|
||||
|
||||
end subroutine c_base_sctb_x
|
||||
|
||||
end module psb_c_base_vect_mod
|
||||
|
||||
@@ -50,6 +50,7 @@ module psb_c_linmap_mod
|
||||
procedure, pass(map) :: is_asb => c_is_asb
|
||||
procedure, pass(map) :: free => c_free
|
||||
procedure, pass(map) :: clone => c_clone
|
||||
procedure, pass(map) :: cnv => psb_c_map_cscnv
|
||||
end type psb_clinmap_type
|
||||
|
||||
|
||||
@@ -159,17 +160,23 @@ contains
|
||||
end function c_is_asb
|
||||
|
||||
|
||||
subroutine psb_c_map_cscnv(map,info,type,mold)
|
||||
subroutine psb_c_map_cscnv(map,info,type,mold,imold)
|
||||
use psb_i_vect_mod
|
||||
use psb_c_mat_mod
|
||||
implicit none
|
||||
type(psb_clinmap_type), intent(inout) :: map
|
||||
class(psb_clinmap_type), intent(inout) :: map
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: type
|
||||
class(psb_c_base_sparse_mat), intent(in), optional :: mold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
|
||||
call map%map_X2Y%cscnv(info,type=type,mold=mold)
|
||||
if (info == psb_success_)&
|
||||
& call map%map_Y2X%cscnv(info,type=type,mold=mold)
|
||||
if (present(imold)) then
|
||||
call map%desc_X%cnv(mold=imold)
|
||||
call map%desc_Y%cnv(mold=imold)
|
||||
end if
|
||||
|
||||
end subroutine psb_c_map_cscnv
|
||||
|
||||
|
||||
@@ -227,9 +227,9 @@ Module psb_c_tools_mod
|
||||
& psb_c_base_vect_type, psb_c_vect_type, &
|
||||
& psb_cspmat_type, psb_c_base_sparse_mat
|
||||
integer(psb_ipk_), intent(in) :: novr
|
||||
Type(psb_cspmat_type), Intent(in) :: a
|
||||
Type(psb_desc_type), Intent(in), target :: desc_a
|
||||
Type(psb_desc_type), Intent(out) :: desc_ov
|
||||
Type(psb_cspmat_type), Intent(in) :: a
|
||||
Type(psb_desc_type), Intent(inout), target :: desc_a
|
||||
Type(psb_desc_type), Intent(out) :: desc_ov
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in),optional :: extype
|
||||
end Subroutine psb_ccdbldext
|
||||
|
||||
@@ -578,21 +578,23 @@ contains
|
||||
|
||||
subroutine c_vect_cnv(x,mold)
|
||||
class(psb_c_vect_type), intent(inout) :: x
|
||||
class(psb_c_base_vect_type), intent(in) :: mold
|
||||
class(psb_c_base_vect_type), intent(in), optional :: mold
|
||||
class(psb_c_base_vect_type), allocatable :: tmp
|
||||
complex(psb_spk_), allocatable :: invect(:)
|
||||
integer(psb_ipk_) :: info
|
||||
|
||||
if (present(mold)) then
|
||||
#ifdef HAVE_MOLD
|
||||
allocate(tmp,stat=info,mold=mold)
|
||||
#else
|
||||
call mold%mold(tmp,info)
|
||||
#endif
|
||||
call x%v%sync()
|
||||
if (info == psb_success_) call tmp%bld(x%v%v)
|
||||
call x%v%free(info)
|
||||
call move_alloc(tmp,x%v)
|
||||
|
||||
if (allocated(x%v)) then
|
||||
call x%v%sync()
|
||||
if (info == psb_success_) call tmp%bld(x%v%v)
|
||||
call x%v%free(info)
|
||||
end if
|
||||
call move_alloc(tmp,x%v)
|
||||
end if
|
||||
end subroutine c_vect_cnv
|
||||
|
||||
end module psb_c_vect_mod
|
||||
|
||||
@@ -73,9 +73,9 @@ module psb_cd_tools_mod
|
||||
implicit none
|
||||
!....parameters...
|
||||
|
||||
type(psb_desc_type), intent(in) :: desc_in
|
||||
type(psb_desc_type), intent(out) :: desc_out
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
type(psb_desc_type), intent(inout) :: desc_in
|
||||
type(psb_desc_type), intent(out) :: desc_out
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine psb_cdcpy
|
||||
end interface
|
||||
|
||||
@@ -113,7 +113,7 @@ module psb_cd_tools_mod
|
||||
Subroutine psb_cd_lstext(desc_a,in_list,desc_ov,info, mask,extype)
|
||||
import :: psb_ipk_, psb_desc_type
|
||||
Implicit None
|
||||
Type(psb_desc_type), Intent(in), target :: desc_a
|
||||
Type(psb_desc_type), Intent(inout), target :: desc_a
|
||||
integer(psb_ipk_), intent(in) :: in_list(:)
|
||||
Type(psb_desc_type), Intent(out) :: desc_ov
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
@@ -144,11 +144,12 @@ module psb_cd_tools_mod
|
||||
end interface
|
||||
|
||||
interface psb_icdasb
|
||||
subroutine psb_icdasb(desc,info,ext_hv)
|
||||
import :: psb_ipk_, psb_desc_type
|
||||
subroutine psb_icdasb(desc,info,ext_hv, mold)
|
||||
import :: psb_ipk_, psb_desc_type, psb_i_base_vect_type
|
||||
Type(psb_desc_type), intent(inout) :: desc
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
logical, intent(in),optional :: ext_hv
|
||||
class(psb_i_base_vect_type), optional, intent(in) :: mold
|
||||
end subroutine psb_icdasb
|
||||
end interface
|
||||
|
||||
@@ -200,12 +201,13 @@ contains
|
||||
|
||||
end subroutine psb_get_boundary
|
||||
|
||||
subroutine psb_cdasb(desc,info)
|
||||
subroutine psb_cdasb(desc,info,mold)
|
||||
|
||||
Type(psb_desc_type), intent(inout) :: desc
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_i_base_vect_type), optional, intent(in) :: mold
|
||||
|
||||
call psb_icdasb(desc,info,ext_hv=.false.)
|
||||
call psb_icdasb(desc,info,ext_hv=.false.,mold=mold)
|
||||
end subroutine psb_cdasb
|
||||
|
||||
end module psb_cd_tools_mod
|
||||
|
||||
@@ -46,6 +46,7 @@ module psb_d_base_vect_mod
|
||||
|
||||
use psb_const_mod
|
||||
use psb_error_mod
|
||||
use psb_i_base_vect_mod
|
||||
|
||||
|
||||
!> \namespace psb_base_mod \class psb_d_base_vect_type
|
||||
@@ -141,9 +142,11 @@ module psb_d_base_vect_mod
|
||||
!
|
||||
procedure, pass(x) :: gthab => d_base_gthab
|
||||
procedure, pass(x) :: gthzv => d_base_gthzv
|
||||
generic, public :: gth => gthab, gthzv
|
||||
procedure, pass(x) :: gthzv_x => d_base_gthzv_x
|
||||
generic, public :: gth => gthab, gthzv, gthzv_x
|
||||
procedure, pass(y) :: sctb => d_base_sctb
|
||||
generic, public :: sct => sctb
|
||||
procedure, pass(y) :: sctb_x => d_base_sctb_x
|
||||
generic, public :: sct => sctb, sctb_x
|
||||
end type psb_d_base_vect_type
|
||||
|
||||
public :: psb_d_base_vect
|
||||
@@ -1043,6 +1046,26 @@ contains
|
||||
call psi_gth(n,idx,alpha,x%v,beta,y)
|
||||
|
||||
end subroutine d_base_gthab
|
||||
!
|
||||
! shortcut alpha=1 beta=0
|
||||
!
|
||||
!> Function base_gthzv
|
||||
!! \memberof psb_d_base_vect_type
|
||||
!! \brief gather into an array special alpha=1 beta=0
|
||||
!! Y = X(IDX(:))
|
||||
!! \param n how many entries to consider
|
||||
!! \param idx(:) indices
|
||||
subroutine d_base_gthzv_x(i,n,idx,x,y)
|
||||
use psi_serial_mod
|
||||
integer(psb_ipk_) :: i,n
|
||||
class(psb_i_base_vect_type) :: idx
|
||||
real(psb_dpk_) :: y(:)
|
||||
class(psb_d_base_vect_type) :: x
|
||||
|
||||
call x%gth(n,idx%v(i:),y)
|
||||
|
||||
end subroutine d_base_gthzv_x
|
||||
|
||||
!
|
||||
! shortcut alpha=1 beta=0
|
||||
!
|
||||
@@ -1088,4 +1111,15 @@ contains
|
||||
|
||||
end subroutine d_base_sctb
|
||||
|
||||
subroutine d_base_sctb_x(i,n,idx,x,beta,y)
|
||||
use psi_serial_mod
|
||||
integer(psb_ipk_) :: i, n
|
||||
class(psb_i_base_vect_type) :: idx
|
||||
real(psb_dpk_) :: beta, x(:)
|
||||
class(psb_d_base_vect_type) :: y
|
||||
|
||||
call y%sct(n,idx%v(i:),x,beta)
|
||||
|
||||
end subroutine d_base_sctb_x
|
||||
|
||||
end module psb_d_base_vect_mod
|
||||
|
||||
@@ -50,6 +50,7 @@ module psb_d_linmap_mod
|
||||
procedure, pass(map) :: is_asb => d_is_asb
|
||||
procedure, pass(map) :: free => d_free
|
||||
procedure, pass(map) :: clone => d_clone
|
||||
procedure, pass(map) :: cnv => psb_d_map_cscnv
|
||||
end type psb_dlinmap_type
|
||||
|
||||
|
||||
@@ -159,17 +160,23 @@ contains
|
||||
end function d_is_asb
|
||||
|
||||
|
||||
subroutine psb_d_map_cscnv(map,info,type,mold)
|
||||
subroutine psb_d_map_cscnv(map,info,type,mold,imold)
|
||||
use psb_i_vect_mod
|
||||
use psb_d_mat_mod
|
||||
implicit none
|
||||
type(psb_dlinmap_type), intent(inout) :: map
|
||||
class(psb_dlinmap_type), intent(inout) :: map
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: type
|
||||
class(psb_d_base_sparse_mat), intent(in), optional :: mold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
|
||||
call map%map_X2Y%cscnv(info,type=type,mold=mold)
|
||||
if (info == psb_success_)&
|
||||
& call map%map_Y2X%cscnv(info,type=type,mold=mold)
|
||||
if (present(imold)) then
|
||||
call map%desc_X%cnv(mold=imold)
|
||||
call map%desc_Y%cnv(mold=imold)
|
||||
end if
|
||||
|
||||
end subroutine psb_d_map_cscnv
|
||||
|
||||
|
||||
@@ -227,9 +227,9 @@ Module psb_d_tools_mod
|
||||
& psb_d_base_vect_type, psb_d_vect_type, &
|
||||
& psb_dspmat_type, psb_d_base_sparse_mat
|
||||
integer(psb_ipk_), intent(in) :: novr
|
||||
Type(psb_dspmat_type), Intent(in) :: a
|
||||
Type(psb_desc_type), Intent(in), target :: desc_a
|
||||
Type(psb_desc_type), Intent(out) :: desc_ov
|
||||
Type(psb_dspmat_type), Intent(in) :: a
|
||||
Type(psb_desc_type), Intent(inout), target :: desc_a
|
||||
Type(psb_desc_type), Intent(out) :: desc_ov
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in),optional :: extype
|
||||
end Subroutine psb_dcdbldext
|
||||
|
||||
@@ -578,21 +578,23 @@ contains
|
||||
|
||||
subroutine d_vect_cnv(x,mold)
|
||||
class(psb_d_vect_type), intent(inout) :: x
|
||||
class(psb_d_base_vect_type), intent(in) :: mold
|
||||
class(psb_d_base_vect_type), intent(in), optional :: mold
|
||||
class(psb_d_base_vect_type), allocatable :: tmp
|
||||
real(psb_dpk_), allocatable :: invect(:)
|
||||
integer(psb_ipk_) :: info
|
||||
|
||||
if (present(mold)) then
|
||||
#ifdef HAVE_MOLD
|
||||
allocate(tmp,stat=info,mold=mold)
|
||||
#else
|
||||
call mold%mold(tmp,info)
|
||||
#endif
|
||||
call x%v%sync()
|
||||
if (info == psb_success_) call tmp%bld(x%v%v)
|
||||
call x%v%free(info)
|
||||
call move_alloc(tmp,x%v)
|
||||
|
||||
if (allocated(x%v)) then
|
||||
call x%v%sync()
|
||||
if (info == psb_success_) call tmp%bld(x%v%v)
|
||||
call x%v%free(info)
|
||||
end if
|
||||
call move_alloc(tmp,x%v)
|
||||
end if
|
||||
end subroutine d_vect_cnv
|
||||
|
||||
end module psb_d_vect_mod
|
||||
|
||||
@@ -37,9 +37,9 @@
|
||||
|
||||
module psb_desc_mod
|
||||
use psb_const_mod
|
||||
use psb_hash_mod
|
||||
use psb_desc_const_mod
|
||||
use psb_indx_map_mod
|
||||
use psb_i_vect_mod
|
||||
|
||||
implicit none
|
||||
|
||||
@@ -202,8 +202,14 @@ module psb_desc_mod
|
||||
integer(psb_ipk_), allocatable :: halo_index(:)
|
||||
integer(psb_ipk_), allocatable :: ext_index(:)
|
||||
integer(psb_ipk_), allocatable :: ovrlap_index(:)
|
||||
integer(psb_ipk_), allocatable :: ovrlap_elem(:,:)
|
||||
integer(psb_ipk_), allocatable :: ovr_mst_idx(:)
|
||||
|
||||
type(psb_i_vect_type) :: v_halo_index
|
||||
type(psb_i_vect_type) :: v_ext_index
|
||||
type(psb_i_vect_type) :: v_ovrlap_index
|
||||
type(psb_i_vect_type) :: v_ovr_mst_idx
|
||||
|
||||
integer(psb_ipk_), allocatable :: ovrlap_elem(:,:)
|
||||
integer(psb_ipk_), allocatable :: bnd_elem(:)
|
||||
class(psb_indx_map), allocatable :: indxmap
|
||||
integer(psb_ipk_), allocatable :: lprm(:)
|
||||
@@ -225,9 +231,12 @@ module psb_desc_mod
|
||||
procedure, pass(desc) :: get_local_cols => psb_cd_get_local_cols
|
||||
procedure, pass(desc) :: get_global_rows => psb_cd_get_global_rows
|
||||
procedure, pass(desc) :: get_global_cols => psb_cd_get_global_cols
|
||||
procedure, pass(desc) :: get_list => psb_cd_get_list
|
||||
procedure, pass(desc) :: a_get_list => psb_cd_get_list
|
||||
procedure, pass(desc) :: v_get_list => psb_cd_v_get_list
|
||||
generic, public :: get_list => a_get_list, v_get_list
|
||||
procedure, pass(desc) :: sizeof => psb_cd_sizeof
|
||||
procedure, pass(desc) :: clone => psb_cd_clone
|
||||
procedure, pass(desc) :: cnv => psb_cd_cnv
|
||||
procedure, pass(desc) :: free => psb_cdfree
|
||||
procedure, pass(desc) :: destroy => psb_cd_destroy
|
||||
procedure, pass(desc) :: nullify => nullify_desc
|
||||
@@ -309,6 +318,10 @@ contains
|
||||
if (allocated(desc%lprm)) val = val + psb_sizeof_int*size(desc%lprm)
|
||||
if (allocated(desc%idx_space)) val = val + psb_sizeof_int*size(desc%idx_space)
|
||||
if (allocated(desc%indxmap)) val = val + desc%indxmap%sizeof()
|
||||
val = val + desc%v_halo_index%sizeof()
|
||||
val = val + desc%v_ext_index%sizeof()
|
||||
val = val + desc%v_ovrlap_index%sizeof()
|
||||
val = val + desc%v_ovr_mst_idx%sizeof()
|
||||
|
||||
end function psb_cd_sizeof
|
||||
|
||||
@@ -597,6 +610,19 @@ contains
|
||||
end subroutine psb_get_xch_idx
|
||||
|
||||
|
||||
subroutine psb_get_v_xch_idx(idx,totxch,totsnd,totrcv)
|
||||
implicit none
|
||||
class(psb_i_base_vect_type), intent(in) :: idx
|
||||
integer(psb_ipk_), intent(out) :: totxch,totsnd,totrcv
|
||||
|
||||
integer(psb_ipk_) :: ip, nerv, nesd
|
||||
character(len=20), parameter :: name='psb_get_v_xch_idx'
|
||||
|
||||
call psb_get_xch_idx(idx%v,totxch,totsnd,totrcv)
|
||||
|
||||
end subroutine psb_get_v_xch_idx
|
||||
|
||||
|
||||
|
||||
subroutine psb_cd_get_list(data,desc,ipnt,totxch,idxr,idxs,info)
|
||||
use psb_const_mod
|
||||
@@ -666,6 +692,86 @@ contains
|
||||
return
|
||||
end subroutine psb_cd_get_list
|
||||
|
||||
|
||||
subroutine psb_cd_v_get_list(data,desc,ipnt,totxch,idxr,idxs,info)
|
||||
use psb_const_mod
|
||||
use psb_error_mod
|
||||
use psb_penv_mod
|
||||
implicit none
|
||||
integer(psb_ipk_), intent(in) :: data
|
||||
class(psb_i_base_vect_type), pointer :: ipnt
|
||||
class(psb_desc_type), target :: desc
|
||||
integer(psb_ipk_), intent(out) :: totxch,idxr,idxs,info
|
||||
|
||||
!locals
|
||||
integer(psb_ipk_) :: np,me,ictxt,err_act, debug_level,debug_unit
|
||||
logical, parameter :: debug=.false.,debugprt=.false.
|
||||
character(len=20), parameter :: name='psb_cd_v_get_list'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
|
||||
ictxt = psb_cd_get_context(desc)
|
||||
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
select case(data)
|
||||
case(psb_comm_halo_)
|
||||
ipnt => desc%v_halo_index%v
|
||||
if (.not.allocated(desc%v_halo_index%v)) &
|
||||
& info = psb_err_inconsistent_index_lists_
|
||||
case(psb_comm_ovr_)
|
||||
ipnt => desc%v_ovrlap_index%v
|
||||
if (.not.allocated(desc%v_ovrlap_index%v)) &
|
||||
& info = psb_err_inconsistent_index_lists_
|
||||
case(psb_comm_ext_)
|
||||
ipnt => desc%v_ext_index%v
|
||||
if (.not.allocated(desc%v_ext_index%v)) &
|
||||
& info = psb_err_inconsistent_index_lists_
|
||||
if (debug_level >= psb_debug_ext_) then
|
||||
if (.not.associated(desc%base_desc)) then
|
||||
write(debug_unit,*) trim(name),&
|
||||
& ': Warning: trying to get ext_index on a descriptor ',&
|
||||
& 'which does not have a base_desc!'
|
||||
end if
|
||||
if (.not.psb_is_ovl_desc(desc)) then
|
||||
write(debug_unit,*) trim(name),&
|
||||
& ': Warning: trying to get ext_index on a descriptor ',&
|
||||
& 'which is not overlap-extended!'
|
||||
end if
|
||||
end if
|
||||
case(psb_comm_mov_)
|
||||
ipnt => desc%v_ovr_mst_idx%v
|
||||
if (.not.allocated(desc%v_ovr_mst_idx%v)) &
|
||||
& info = psb_err_inconsistent_index_lists_
|
||||
|
||||
case default
|
||||
info=psb_err_from_subroutine_
|
||||
end select
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(info,name,a_err='wrong Data selector')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_get_v_xch_idx(ipnt,totxch,idxs,idxr)
|
||||
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
|
||||
if (err_act == psb_act_ret_) then
|
||||
return
|
||||
else
|
||||
call psb_error(ictxt)
|
||||
end if
|
||||
return
|
||||
end subroutine psb_cd_v_get_list
|
||||
|
||||
!
|
||||
! Subroutine: psb_cdfree
|
||||
! Frees a descriptor data structure.
|
||||
@@ -752,6 +858,10 @@ contains
|
||||
call desc%indxmap%free()
|
||||
deallocate(desc%indxmap, stat=info)
|
||||
end if
|
||||
call desc%v_halo_index%free(info)
|
||||
call desc%v_ovrlap_index%free(info)
|
||||
call desc%v_ext_index%free(info)
|
||||
call desc%v_ovr_mst_idx%free(info)
|
||||
|
||||
call desc%nullify()
|
||||
|
||||
@@ -820,6 +930,15 @@ contains
|
||||
& call psb_move_alloc( desc_in%idx_space , desc_out%idx_space , info)
|
||||
if (info == psb_success_) &
|
||||
& call move_alloc(desc_in%indxmap, desc_out%indxmap)
|
||||
if (info == psb_success_) &
|
||||
& call desc_in%v_halo_index%clone(desc_out%v_halo_index,info)
|
||||
if (info == psb_success_) &
|
||||
& call desc_in%v_ext_index%clone(desc_out%v_ext_index,info)
|
||||
if (info == psb_success_) &
|
||||
& call desc_in%v_ovrlap_index%clone(desc_out%v_ovrlap_index,info)
|
||||
if (info == psb_success_) &
|
||||
& call desc_in%v_ovr_mst_idx%clone(desc_out%v_ovr_mst_idx,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info = psb_err_from_subroutine_
|
||||
call psb_errpush(info,name)
|
||||
@@ -951,6 +1070,17 @@ contains
|
||||
|
||||
end Subroutine psb_cd_get_recv_idx
|
||||
|
||||
subroutine psb_cd_cnv(desc, mold)
|
||||
class(psb_desc_type), intent(inout), target :: desc
|
||||
class(psb_i_base_vect_type), intent(in) :: mold
|
||||
|
||||
call desc%v_halo_index%cnv(mold)
|
||||
call desc%v_ext_index%cnv(mold)
|
||||
call desc%v_ovrlap_index%cnv(mold)
|
||||
call desc%v_ovr_mst_idx%cnv(mold)
|
||||
|
||||
end subroutine psb_cd_cnv
|
||||
|
||||
|
||||
subroutine cd_l2gs1(idx,desc,info,mask,owned)
|
||||
use psb_error_mod
|
||||
|
||||
@@ -574,7 +574,7 @@ contains
|
||||
!
|
||||
function i_base_get_vect(x) result(res)
|
||||
class(psb_i_base_vect_type), intent(inout) :: x
|
||||
integer(psb_ipk_), allocatable :: res(:)
|
||||
integer(psb_ipk_), allocatable :: res(:)
|
||||
integer(psb_ipk_) :: info
|
||||
|
||||
if (.not.allocated(x%v)) return
|
||||
|
||||
@@ -152,7 +152,7 @@ contains
|
||||
|
||||
function i_vect_get_vect(x) result(res)
|
||||
class(psb_i_vect_type), intent(inout) :: x
|
||||
integer(psb_ipk_), allocatable :: res(:)
|
||||
integer(psb_ipk_), allocatable :: res(:)
|
||||
integer(psb_ipk_) :: info
|
||||
|
||||
if (allocated(x%v)) then
|
||||
@@ -558,10 +558,10 @@ contains
|
||||
use psi_serial_mod
|
||||
implicit none
|
||||
class(psb_i_vect_type), intent(inout) :: x
|
||||
integer(psb_ipk_), intent(in) :: n, dupl
|
||||
integer(psb_ipk_), intent(in) :: irl(:)
|
||||
integer(psb_ipk_), intent(in) :: val(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in) :: n, dupl
|
||||
integer(psb_ipk_), intent(in) :: irl(:)
|
||||
integer(psb_ipk_), intent(in) :: val(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
@@ -578,21 +578,24 @@ contains
|
||||
|
||||
subroutine i_vect_cnv(x,mold)
|
||||
class(psb_i_vect_type), intent(inout) :: x
|
||||
class(psb_i_base_vect_type), intent(in) :: mold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: mold
|
||||
class(psb_i_base_vect_type), allocatable :: tmp
|
||||
integer(psb_ipk_), allocatable :: invect(:)
|
||||
integer(psb_ipk_) :: info
|
||||
integer(psb_ipk_) :: info
|
||||
|
||||
|
||||
if (present(mold)) then
|
||||
#ifdef HAVE_MOLD
|
||||
allocate(tmp,stat=info,mold=mold)
|
||||
#else
|
||||
call mold%mold(tmp,info)
|
||||
#endif
|
||||
call x%v%sync()
|
||||
if (info == psb_success_) call tmp%bld(x%v%v)
|
||||
call x%v%free(info)
|
||||
call move_alloc(tmp,x%v)
|
||||
|
||||
if (allocated(x%v)) then
|
||||
call x%v%sync()
|
||||
if (info == psb_success_) call tmp%bld(x%v%v)
|
||||
call x%v%free(info)
|
||||
end if
|
||||
call move_alloc(tmp,x%v)
|
||||
end if
|
||||
end subroutine i_vect_cnv
|
||||
|
||||
end module psb_i_vect_mod
|
||||
|
||||
@@ -46,6 +46,7 @@ module psb_s_base_vect_mod
|
||||
|
||||
use psb_const_mod
|
||||
use psb_error_mod
|
||||
use psb_i_base_vect_mod
|
||||
|
||||
|
||||
!> \namespace psb_base_mod \class psb_s_base_vect_type
|
||||
@@ -141,9 +142,11 @@ module psb_s_base_vect_mod
|
||||
!
|
||||
procedure, pass(x) :: gthab => s_base_gthab
|
||||
procedure, pass(x) :: gthzv => s_base_gthzv
|
||||
generic, public :: gth => gthab, gthzv
|
||||
procedure, pass(x) :: gthzv_x => s_base_gthzv_x
|
||||
generic, public :: gth => gthab, gthzv, gthzv_x
|
||||
procedure, pass(y) :: sctb => s_base_sctb
|
||||
generic, public :: sct => sctb
|
||||
procedure, pass(y) :: sctb_x => s_base_sctb_x
|
||||
generic, public :: sct => sctb, sctb_x
|
||||
end type psb_s_base_vect_type
|
||||
|
||||
public :: psb_s_base_vect
|
||||
@@ -1042,6 +1045,26 @@ contains
|
||||
call psi_gth(n,idx,alpha,x%v,beta,y)
|
||||
|
||||
end subroutine s_base_gthab
|
||||
!
|
||||
! shortcut alpha=1 beta=0
|
||||
!
|
||||
!> Function base_gthzv
|
||||
!! \memberof psb_s_base_vect_type
|
||||
!! \brief gather into an array special alpha=1 beta=0
|
||||
!! Y = X(IDX(:))
|
||||
!! \param n how many entries to consider
|
||||
!! \param idx(:) indices
|
||||
subroutine s_base_gthzv_x(i,n,idx,x,y)
|
||||
use psi_serial_mod
|
||||
integer(psb_ipk_) :: i,n
|
||||
class(psb_i_base_vect_type) :: idx
|
||||
real(psb_spk_) :: y(:)
|
||||
class(psb_s_base_vect_type) :: x
|
||||
|
||||
call x%gth(n,idx%v(i:),y)
|
||||
|
||||
end subroutine s_base_gthzv_x
|
||||
|
||||
!
|
||||
! shortcut alpha=1 beta=0
|
||||
!
|
||||
@@ -1087,4 +1110,15 @@ contains
|
||||
|
||||
end subroutine s_base_sctb
|
||||
|
||||
subroutine s_base_sctb_x(i,n,idx,x,beta,y)
|
||||
use psi_serial_mod
|
||||
integer(psb_ipk_) :: i, n
|
||||
class(psb_i_base_vect_type) :: idx
|
||||
real(psb_spk_) :: beta, x(:)
|
||||
class(psb_s_base_vect_type) :: y
|
||||
|
||||
call y%sct(n,idx%v(i:),x,beta)
|
||||
|
||||
end subroutine s_base_sctb_x
|
||||
|
||||
end module psb_s_base_vect_mod
|
||||
|
||||
@@ -50,6 +50,7 @@ module psb_s_linmap_mod
|
||||
procedure, pass(map) :: is_asb => s_is_asb
|
||||
procedure, pass(map) :: free => s_free
|
||||
procedure, pass(map) :: clone => s_clone
|
||||
procedure, pass(map) :: cnv => psb_s_map_cscnv
|
||||
end type psb_slinmap_type
|
||||
|
||||
|
||||
@@ -159,17 +160,23 @@ contains
|
||||
end function s_is_asb
|
||||
|
||||
|
||||
subroutine psb_s_map_cscnv(map,info,type,mold)
|
||||
subroutine psb_s_map_cscnv(map,info,type,mold,imold)
|
||||
use psb_i_vect_mod
|
||||
use psb_s_mat_mod
|
||||
implicit none
|
||||
type(psb_slinmap_type), intent(inout) :: map
|
||||
class(psb_slinmap_type), intent(inout) :: map
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: type
|
||||
class(psb_s_base_sparse_mat), intent(in), optional :: mold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
|
||||
call map%map_X2Y%cscnv(info,type=type,mold=mold)
|
||||
if (info == psb_success_)&
|
||||
& call map%map_Y2X%cscnv(info,type=type,mold=mold)
|
||||
if (present(imold)) then
|
||||
call map%desc_X%cnv(mold=imold)
|
||||
call map%desc_Y%cnv(mold=imold)
|
||||
end if
|
||||
|
||||
end subroutine psb_s_map_cscnv
|
||||
|
||||
|
||||
@@ -227,9 +227,9 @@ Module psb_s_tools_mod
|
||||
& psb_s_base_vect_type, psb_s_vect_type, &
|
||||
& psb_sspmat_type, psb_s_base_sparse_mat
|
||||
integer(psb_ipk_), intent(in) :: novr
|
||||
Type(psb_sspmat_type), Intent(in) :: a
|
||||
Type(psb_desc_type), Intent(in), target :: desc_a
|
||||
Type(psb_desc_type), Intent(out) :: desc_ov
|
||||
Type(psb_sspmat_type), Intent(in) :: a
|
||||
Type(psb_desc_type), Intent(inout), target :: desc_a
|
||||
Type(psb_desc_type), Intent(out) :: desc_ov
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in),optional :: extype
|
||||
end Subroutine psb_scdbldext
|
||||
|
||||
@@ -578,21 +578,23 @@ contains
|
||||
|
||||
subroutine s_vect_cnv(x,mold)
|
||||
class(psb_s_vect_type), intent(inout) :: x
|
||||
class(psb_s_base_vect_type), intent(in) :: mold
|
||||
class(psb_s_base_vect_type), intent(in), optional :: mold
|
||||
class(psb_s_base_vect_type), allocatable :: tmp
|
||||
real(psb_spk_), allocatable :: invect(:)
|
||||
integer(psb_ipk_) :: info
|
||||
|
||||
if (present(mold)) then
|
||||
#ifdef HAVE_MOLD
|
||||
allocate(tmp,stat=info,mold=mold)
|
||||
#else
|
||||
call mold%mold(tmp,info)
|
||||
#endif
|
||||
call x%v%sync()
|
||||
if (info == psb_success_) call tmp%bld(x%v%v)
|
||||
call x%v%free(info)
|
||||
call move_alloc(tmp,x%v)
|
||||
|
||||
if (allocated(x%v)) then
|
||||
call x%v%sync()
|
||||
if (info == psb_success_) call tmp%bld(x%v%v)
|
||||
call x%v%free(info)
|
||||
end if
|
||||
call move_alloc(tmp,x%v)
|
||||
end if
|
||||
end subroutine s_vect_cnv
|
||||
|
||||
end module psb_s_vect_mod
|
||||
|
||||
@@ -46,6 +46,7 @@ module psb_z_base_vect_mod
|
||||
|
||||
use psb_const_mod
|
||||
use psb_error_mod
|
||||
use psb_i_base_vect_mod
|
||||
|
||||
|
||||
!> \namespace psb_base_mod \class psb_z_base_vect_type
|
||||
@@ -141,9 +142,11 @@ module psb_z_base_vect_mod
|
||||
!
|
||||
procedure, pass(x) :: gthab => z_base_gthab
|
||||
procedure, pass(x) :: gthzv => z_base_gthzv
|
||||
generic, public :: gth => gthab, gthzv
|
||||
procedure, pass(x) :: gthzv_x => z_base_gthzv_x
|
||||
generic, public :: gth => gthab, gthzv, gthzv_x
|
||||
procedure, pass(y) :: sctb => z_base_sctb
|
||||
generic, public :: sct => sctb
|
||||
procedure, pass(y) :: sctb_x => z_base_sctb_x
|
||||
generic, public :: sct => sctb, sctb_x
|
||||
end type psb_z_base_vect_type
|
||||
|
||||
public :: psb_z_base_vect
|
||||
@@ -1042,6 +1045,26 @@ contains
|
||||
call psi_gth(n,idx,alpha,x%v,beta,y)
|
||||
|
||||
end subroutine z_base_gthab
|
||||
!
|
||||
! shortcut alpha=1 beta=0
|
||||
!
|
||||
!> Function base_gthzv
|
||||
!! \memberof psb_z_base_vect_type
|
||||
!! \brief gather into an array special alpha=1 beta=0
|
||||
!! Y = X(IDX(:))
|
||||
!! \param n how many entries to consider
|
||||
!! \param idx(:) indices
|
||||
subroutine z_base_gthzv_x(i,n,idx,x,y)
|
||||
use psi_serial_mod
|
||||
integer(psb_ipk_) :: i,n
|
||||
class(psb_i_base_vect_type) :: idx
|
||||
complex(psb_dpk_) :: y(:)
|
||||
class(psb_z_base_vect_type) :: x
|
||||
|
||||
call x%gth(n,idx%v(i:),y)
|
||||
|
||||
end subroutine z_base_gthzv_x
|
||||
|
||||
!
|
||||
! shortcut alpha=1 beta=0
|
||||
!
|
||||
@@ -1087,4 +1110,15 @@ contains
|
||||
|
||||
end subroutine z_base_sctb
|
||||
|
||||
subroutine z_base_sctb_x(i,n,idx,x,beta,y)
|
||||
use psi_serial_mod
|
||||
integer(psb_ipk_) :: i, n
|
||||
class(psb_i_base_vect_type) :: idx
|
||||
complex(psb_dpk_) :: beta, x(:)
|
||||
class(psb_z_base_vect_type) :: y
|
||||
|
||||
call y%sct(n,idx%v(i:),x,beta)
|
||||
|
||||
end subroutine z_base_sctb_x
|
||||
|
||||
end module psb_z_base_vect_mod
|
||||
|
||||
@@ -50,6 +50,7 @@ module psb_z_linmap_mod
|
||||
procedure, pass(map) :: is_asb => z_is_asb
|
||||
procedure, pass(map) :: free => z_free
|
||||
procedure, pass(map) :: clone => z_clone
|
||||
procedure, pass(map) :: cnv => psb_z_map_cscnv
|
||||
end type psb_zlinmap_type
|
||||
|
||||
|
||||
@@ -159,17 +160,23 @@ contains
|
||||
end function z_is_asb
|
||||
|
||||
|
||||
subroutine psb_z_map_cscnv(map,info,type,mold)
|
||||
subroutine psb_z_map_cscnv(map,info,type,mold,imold)
|
||||
use psb_i_vect_mod
|
||||
use psb_z_mat_mod
|
||||
implicit none
|
||||
type(psb_zlinmap_type), intent(inout) :: map
|
||||
class(psb_zlinmap_type), intent(inout) :: map
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: type
|
||||
class(psb_z_base_sparse_mat), intent(in), optional :: mold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
|
||||
call map%map_X2Y%cscnv(info,type=type,mold=mold)
|
||||
if (info == psb_success_)&
|
||||
& call map%map_Y2X%cscnv(info,type=type,mold=mold)
|
||||
if (present(imold)) then
|
||||
call map%desc_X%cnv(mold=imold)
|
||||
call map%desc_Y%cnv(mold=imold)
|
||||
end if
|
||||
|
||||
end subroutine psb_z_map_cscnv
|
||||
|
||||
|
||||
@@ -227,9 +227,9 @@ Module psb_z_tools_mod
|
||||
& psb_z_base_vect_type, psb_z_vect_type, &
|
||||
& psb_zspmat_type, psb_z_base_sparse_mat
|
||||
integer(psb_ipk_), intent(in) :: novr
|
||||
Type(psb_zspmat_type), Intent(in) :: a
|
||||
Type(psb_desc_type), Intent(in), target :: desc_a
|
||||
Type(psb_desc_type), Intent(out) :: desc_ov
|
||||
Type(psb_zspmat_type), Intent(in) :: a
|
||||
Type(psb_desc_type), Intent(inout), target :: desc_a
|
||||
Type(psb_desc_type), Intent(out) :: desc_ov
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in),optional :: extype
|
||||
end Subroutine psb_zcdbldext
|
||||
|
||||
@@ -578,21 +578,23 @@ contains
|
||||
|
||||
subroutine z_vect_cnv(x,mold)
|
||||
class(psb_z_vect_type), intent(inout) :: x
|
||||
class(psb_z_base_vect_type), intent(in) :: mold
|
||||
class(psb_z_base_vect_type), intent(in), optional :: mold
|
||||
class(psb_z_base_vect_type), allocatable :: tmp
|
||||
complex(psb_dpk_), allocatable :: invect(:)
|
||||
integer(psb_ipk_) :: info
|
||||
|
||||
if (present(mold)) then
|
||||
#ifdef HAVE_MOLD
|
||||
allocate(tmp,stat=info,mold=mold)
|
||||
#else
|
||||
call mold%mold(tmp,info)
|
||||
#endif
|
||||
call x%v%sync()
|
||||
if (info == psb_success_) call tmp%bld(x%v%v)
|
||||
call x%v%free(info)
|
||||
call move_alloc(tmp,x%v)
|
||||
|
||||
if (allocated(x%v)) then
|
||||
call x%v%sync()
|
||||
if (info == psb_success_) call tmp%bld(x%v%v)
|
||||
call x%v%free(info)
|
||||
end if
|
||||
call move_alloc(tmp,x%v)
|
||||
end if
|
||||
end subroutine z_vect_cnv
|
||||
|
||||
end module psb_z_vect_mod
|
||||
|
||||
@@ -30,7 +30,7 @@
|
||||
!!$
|
||||
!!$
|
||||
module psi_c_mod
|
||||
use psb_desc_mod, only : psb_desc_type, psb_spk_, psb_ipk_
|
||||
use psb_desc_mod, only : psb_desc_type, psb_spk_, psb_ipk_, psb_i_base_vect_type
|
||||
use psb_c_vect_mod, only : psb_c_base_vect_type
|
||||
|
||||
interface psi_swapdata
|
||||
@@ -90,6 +90,16 @@ module psi_c_mod
|
||||
complex(psb_spk_),target :: work(:)
|
||||
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
|
||||
end subroutine psi_cswapidx_vect
|
||||
subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
|
||||
import :: psb_desc_type, psb_ipk_, psb_spk_, psb_c_base_vect_type, psb_i_base_vect_type
|
||||
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_c_base_vect_type) :: y
|
||||
complex(psb_spk_) :: beta
|
||||
complex(psb_spk_), target :: work(:)
|
||||
class(psb_i_base_vect_type), intent(in) :: idx
|
||||
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
|
||||
end subroutine psi_cswap_vidx_vect
|
||||
end interface
|
||||
|
||||
|
||||
|
||||
@@ -30,8 +30,9 @@
|
||||
!!$
|
||||
!!$
|
||||
module psi_d_mod
|
||||
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_
|
||||
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_, psb_i_base_vect_type
|
||||
use psb_d_vect_mod, only : psb_d_base_vect_type
|
||||
|
||||
interface psi_swapdata
|
||||
subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
|
||||
import :: psb_desc_type, psb_ipk_, psb_dpk_, psb_d_base_vect_type
|
||||
@@ -89,6 +90,16 @@ module psi_d_mod
|
||||
real(psb_dpk_),target :: work(:)
|
||||
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
|
||||
end subroutine psi_dswapidx_vect
|
||||
subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
|
||||
import :: psb_desc_type, psb_ipk_, psb_dpk_, psb_d_base_vect_type, psb_i_base_vect_type
|
||||
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_d_base_vect_type) :: y
|
||||
real(psb_dpk_) :: beta
|
||||
real(psb_dpk_), target :: work(:)
|
||||
class(psb_i_base_vect_type), intent(in) :: idx
|
||||
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
|
||||
end subroutine psi_dswap_vidx_vect
|
||||
end interface
|
||||
|
||||
|
||||
|
||||
@@ -139,11 +139,12 @@ module psi_i_mod
|
||||
end interface
|
||||
|
||||
interface psi_cnv_dsc
|
||||
subroutine psi_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info)
|
||||
import :: psb_desc_type, psb_ipk_
|
||||
subroutine psi_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold)
|
||||
import :: psb_desc_type, psb_ipk_, psb_i_base_vect_type
|
||||
integer(psb_ipk_), intent(in) :: halo_in(:), ovrlap_in(:),ext_in(:)
|
||||
type(psb_desc_type), intent(inout) :: cdesc
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_i_base_vect_type), optional, intent(in) :: mold
|
||||
end subroutine psi_cnv_dsc
|
||||
end interface
|
||||
|
||||
|
||||
@@ -30,7 +30,7 @@
|
||||
!!$
|
||||
!!$
|
||||
module psi_s_mod
|
||||
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_
|
||||
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_, psb_i_base_vect_type
|
||||
use psb_s_vect_mod, only : psb_s_base_vect_type
|
||||
|
||||
interface psi_swapdata
|
||||
@@ -90,6 +90,16 @@ module psi_s_mod
|
||||
real(psb_spk_),target :: work(:)
|
||||
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
|
||||
end subroutine psi_sswapidx_vect
|
||||
subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
|
||||
import :: psb_desc_type, psb_ipk_, psb_spk_, psb_s_base_vect_type, psb_i_base_vect_type
|
||||
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_s_base_vect_type) :: y
|
||||
real(psb_spk_) :: beta
|
||||
real(psb_spk_), target :: work(:)
|
||||
class(psb_i_base_vect_type), intent(in) :: idx
|
||||
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
|
||||
end subroutine psi_sswap_vidx_vect
|
||||
end interface
|
||||
|
||||
|
||||
|
||||
@@ -30,7 +30,7 @@
|
||||
!!$
|
||||
!!$
|
||||
module psi_z_mod
|
||||
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_
|
||||
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_, psb_i_base_vect_type
|
||||
use psb_z_vect_mod, only : psb_z_base_vect_type
|
||||
|
||||
interface psi_swapdata
|
||||
@@ -90,6 +90,16 @@ module psi_z_mod
|
||||
complex(psb_dpk_),target :: work(:)
|
||||
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
|
||||
end subroutine psi_zswapidx_vect
|
||||
subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
|
||||
import :: psb_desc_type, psb_ipk_, psb_dpk_, psb_z_base_vect_type, psb_i_base_vect_type
|
||||
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_z_base_vect_type) :: y
|
||||
complex(psb_dpk_) :: beta
|
||||
complex(psb_dpk_), target :: work(:)
|
||||
class(psb_i_base_vect_type), intent(in) :: idx
|
||||
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
|
||||
end subroutine psi_zswap_vidx_vect
|
||||
end interface
|
||||
|
||||
|
||||
|
||||
@@ -124,7 +124,7 @@ subroutine psb_c_map_X2Y_vect(alpha,x,beta,y,map,info,work)
|
||||
complex(psb_spk_), allocatable :: xta(:), yta(:)
|
||||
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2 ,&
|
||||
& map_kind, nr, ictxt
|
||||
character(len=20), parameter :: name='psb_map_X2Y'
|
||||
character(len=20), parameter :: name='psb_map_X2Yv'
|
||||
|
||||
info = psb_success_
|
||||
if (.not.map%is_asb()) then
|
||||
@@ -153,8 +153,9 @@ subroutine psb_c_map_X2Y_vect(alpha,x,beta,y,map,info,work)
|
||||
if (info /= psb_success_) then
|
||||
write(psb_err_unit,*) trim(name),' Error from inner routines',info
|
||||
info = -1
|
||||
else
|
||||
call yt%free(info)
|
||||
end if
|
||||
call yt%free(info)
|
||||
|
||||
case(psb_map_gen_linear_)
|
||||
|
||||
@@ -180,10 +181,11 @@ subroutine psb_c_map_X2Y_vect(alpha,x,beta,y,map,info,work)
|
||||
if (info /= psb_success_) then
|
||||
write(psb_err_unit,*) trim(name),' Error from inner routines',info
|
||||
info = -1
|
||||
else
|
||||
call xt%free(info)
|
||||
call yt%free(info)
|
||||
end if
|
||||
|
||||
call xt%free(info)
|
||||
call yt%free(info)
|
||||
|
||||
case default
|
||||
write(psb_err_unit,*) trim(name),' Invalid descriptor input', &
|
||||
@@ -287,7 +289,7 @@ subroutine psb_c_map_Y2X_vect(alpha,x,beta,y,map,info,work)
|
||||
complex(psb_spk_), allocatable :: xta(:), yta(:)
|
||||
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,&
|
||||
& map_kind, nr, ictxt
|
||||
character(len=20), parameter :: name='psb_map_Y2X'
|
||||
character(len=20), parameter :: name='psb_map_Y2Xv'
|
||||
|
||||
info = psb_success_
|
||||
if (.not.map%is_asb()) then
|
||||
@@ -316,8 +318,9 @@ subroutine psb_c_map_Y2X_vect(alpha,x,beta,y,map,info,work)
|
||||
if (info /= psb_success_) then
|
||||
write(psb_err_unit,*) trim(name),' Error from inner routines',info
|
||||
info = -1
|
||||
else
|
||||
call yt%free(info)
|
||||
end if
|
||||
call yt%free(info)
|
||||
|
||||
case(psb_map_gen_linear_)
|
||||
|
||||
@@ -342,10 +345,10 @@ subroutine psb_c_map_Y2X_vect(alpha,x,beta,y,map,info,work)
|
||||
if (info /= psb_success_) then
|
||||
write(psb_err_unit,*) trim(name),' Error from inner routines',info
|
||||
info = -1
|
||||
else
|
||||
call xt%free(info)
|
||||
call yt%free(info)
|
||||
end if
|
||||
|
||||
call xt%free(info)
|
||||
call yt%free(info)
|
||||
|
||||
case default
|
||||
write(psb_err_unit,*) trim(name),' Invalid descriptor input'
|
||||
|
||||
@@ -75,7 +75,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
|
||||
! .. Array Arguments ..
|
||||
integer(psb_ipk_), intent(in) :: novr
|
||||
Type(psb_cspmat_type), Intent(in) :: a
|
||||
Type(psb_desc_type), Intent(in), target :: desc_a
|
||||
Type(psb_desc_type), Intent(inout), target :: desc_a
|
||||
Type(psb_desc_type), Intent(out) :: desc_ov
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in),optional :: extype
|
||||
@@ -90,11 +90,11 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
|
||||
& idxr, idxs, iszr, iszs, nxch, nsnd, nrcv,lidx, extype_
|
||||
integer(psb_mpik_) :: icomm, ictxt, me, np, minfo
|
||||
|
||||
integer(psb_ipk_), allocatable :: irow(:), icol(:)
|
||||
integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:)
|
||||
integer(psb_ipk_),allocatable :: halo(:),works(:),workr(:),t_halo_in(:),&
|
||||
& t_halo_out(:),temp(:),maskr(:)
|
||||
integer(psb_mpik_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:)
|
||||
integer(psb_ipk_), allocatable :: irow(:), icol(:)
|
||||
integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:)
|
||||
integer(psb_ipk_), allocatable :: halo(:),ovrlap(:),works(:),workr(:),&
|
||||
& t_halo_in(:), t_halo_out(:),temp(:),maskr(:)
|
||||
integer(psb_mpik_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:)
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
character(len=20) :: name, ch_err
|
||||
@@ -203,11 +203,11 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
|
||||
If (debug_level >= psb_debug_outer_)&
|
||||
& Write(debug_unit,*) me,' ',trim(name),':ovr_est done',novr,lovr
|
||||
|
||||
index_dim = size(desc_a%halo_index)
|
||||
elem_dim = size(desc_a%halo_index)
|
||||
index_dim = max(desc_a%v_halo_index%get_nrows(),1_psb_ipk_)
|
||||
elem_dim = index_dim
|
||||
|
||||
l_tmp_ovr_idx = novr*(3*Max(2*index_dim,1)+1)
|
||||
l_tmp_halo = novr*(3*Size(desc_a%halo_index))
|
||||
l_tmp_halo = novr*(3*index_dim)
|
||||
|
||||
desc_ov%base_desc => desc_a
|
||||
|
||||
@@ -228,13 +228,18 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
|
||||
& t_halo_out(l_tmp_halo), temp(lworkr),stat=info)
|
||||
if (info == psb_success_) allocate(orig_ovr(l_tmp_ovr_idx),&
|
||||
& tmp_ovr_idx(l_tmp_ovr_idx), &
|
||||
& tmp_halo(l_tmp_halo), halo(size(desc_a%halo_index)),stat=info)
|
||||
& tmp_halo(l_tmp_halo),stat=info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,name)
|
||||
goto 9999
|
||||
end if
|
||||
halo(:) = desc_a%halo_index(:)
|
||||
|
||||
halo = desc_a%v_halo_index%get_vect()
|
||||
if (.not.allocated(halo)) halo = (/ -ione /)
|
||||
ovrlap = desc_a%v_ovrlap_index%get_vect()
|
||||
if (.not.allocated(ovrlap)) ovrlap = (/ -ione /)
|
||||
|
||||
tmp_ovr_idx(:) = -1
|
||||
orig_ovr(:) = -1
|
||||
tmp_halo(:) = -1
|
||||
@@ -246,14 +251,14 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
|
||||
cntov_o = 1
|
||||
! Init overlap with desc_a%ovrlap (if any)
|
||||
counter = 1
|
||||
Do While (desc_a%ovrlap_index(counter) /= -1)
|
||||
proc = desc_a%ovrlap_index(counter+psb_proc_id_)
|
||||
n_elem_recv = desc_a%ovrlap_index(counter+psb_n_elem_recv_)
|
||||
n_elem_send = desc_a%ovrlap_index(counter+n_elem_recv+psb_n_elem_send_)
|
||||
Do While (ovrlap(counter) /= -1)
|
||||
proc = ovrlap(counter+psb_proc_id_)
|
||||
n_elem_recv = ovrlap(counter+psb_n_elem_recv_)
|
||||
n_elem_send = ovrlap(counter+n_elem_recv+psb_n_elem_send_)
|
||||
|
||||
Do j=0,n_elem_recv-1
|
||||
|
||||
idx = desc_a%ovrlap_index(counter+psb_elem_recv_+j)
|
||||
idx = ovrlap(counter+psb_elem_recv_+j)
|
||||
call desc_ov%indxmap%l2g(idx,gidx,info)
|
||||
If (gidx < 0) then
|
||||
info=-3
|
||||
@@ -467,7 +472,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
|
||||
! accumulated RECV requests, we have an all-to-all to build
|
||||
! matchings SENDs.
|
||||
!
|
||||
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,rvsz,1,psb_mpi_def_integer,icomm,minfo)
|
||||
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,rvsz,1, &
|
||||
& psb_mpi_def_integer,icomm,minfo)
|
||||
if (minfo /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
call psb_errpush(info,name,a_err='mpi_alltoall')
|
||||
|
||||
@@ -37,7 +37,7 @@ Subroutine psb_cd_lstext(desc_a,in_list,desc_ov,info, mask,extype)
|
||||
Implicit None
|
||||
|
||||
! .. Array Arguments ..
|
||||
Type(psb_desc_type), Intent(in), target :: desc_a
|
||||
Type(psb_desc_type), Intent(inout), target :: desc_a
|
||||
integer(psb_ipk_), intent(in) :: in_list(:)
|
||||
Type(psb_desc_type), Intent(out) :: desc_ov
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
@@ -44,9 +44,9 @@ subroutine psb_cdcpy(desc_in, desc_out, info)
|
||||
implicit none
|
||||
!....parameters...
|
||||
|
||||
type(psb_desc_type), intent(in) :: desc_in
|
||||
type(psb_desc_type), intent(out) :: desc_out
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
type(psb_desc_type), intent(inout) :: desc_in
|
||||
type(psb_desc_type), intent(out) :: desc_out
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
!locals
|
||||
integer(psb_ipk_) :: np,me,ictxt, err_act
|
||||
@@ -73,27 +73,7 @@ subroutine psb_cdcpy(desc_in, desc_out, info)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
!!$ call psb_safe_ab_cpy(desc_in%matrix_data,desc_out%matrix_data,info)
|
||||
if (info == psb_success_) call psb_safe_ab_cpy(desc_in%halo_index,desc_out%halo_index,info)
|
||||
if (info == psb_success_) call psb_safe_ab_cpy(desc_in%ext_index,desc_out%ext_index,info)
|
||||
if (info == psb_success_) call psb_safe_ab_cpy(desc_in%ovrlap_index,&
|
||||
& desc_out%ovrlap_index,info)
|
||||
if (info == psb_success_) call psb_safe_ab_cpy(desc_in%bnd_elem,desc_out%bnd_elem,info)
|
||||
if (info == psb_success_) call psb_safe_ab_cpy(desc_in%ovrlap_elem,desc_out%ovrlap_elem,info)
|
||||
if (info == psb_success_) call psb_safe_ab_cpy(desc_in%ovr_mst_idx,desc_out%ovr_mst_idx,info)
|
||||
if (info == psb_success_) call psb_safe_ab_cpy(desc_in%lprm,desc_out%lprm,info)
|
||||
if (info == psb_success_) call psb_safe_ab_cpy(desc_in%idx_space,desc_out%idx_space,info)
|
||||
|
||||
if (allocated(desc_in%indxmap)) then
|
||||
|
||||
#ifdef SOURCE_WORKAROUND
|
||||
call desc_in%indxmap%clone(desc_out%indxmap,info)
|
||||
#else
|
||||
if (info == psb_success_)&
|
||||
& allocate(desc_out%indxmap, source=desc_in%indxmap, stat=info)
|
||||
#endif
|
||||
|
||||
end if
|
||||
call desc_in%clone(desc_out,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info = psb_err_from_subroutine_
|
||||
|
||||
+21
-17
@@ -87,6 +87,8 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,&
|
||||
complex(psb_spk_), allocatable :: valsnd(:)
|
||||
type(psb_c_coo_sparse_mat), allocatable :: acoo
|
||||
integer(psb_ipk_), pointer :: idxv(:)
|
||||
class(psb_i_base_vect_type), pointer :: pdxv
|
||||
integer(psb_ipk_), allocatable :: ipdxv(:)
|
||||
logical :: rowcnv_,colcnv_,rowscale_,colscale_
|
||||
character(len=5) :: outfmt_
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
@@ -158,12 +160,9 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,&
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
call desc_a%get_list(data_,idxv,totxch,nxr,nxs,info)
|
||||
|
||||
l1 = 0
|
||||
|
||||
sdsz(:)=0
|
||||
rvsz(:)=0
|
||||
l1 = 0
|
||||
ipx = 1
|
||||
brvindx(ipx) = 0
|
||||
bsdindx(ipx) = 0
|
||||
@@ -171,17 +170,22 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,&
|
||||
idx = 0
|
||||
idxs = 0
|
||||
idxr = 0
|
||||
|
||||
call acoo%allocate(izero,a%get_ncols(),info)
|
||||
|
||||
|
||||
call desc_a%get_list(data_,pdxv,totxch,nxr,nxs,info)
|
||||
ipdxv = pdxv%get_vect()
|
||||
! For all rows in the halo descriptor, extract and send/receive.
|
||||
Do
|
||||
proc=idxv(counter)
|
||||
proc=ipdxv(counter)
|
||||
if (proc == -1) exit
|
||||
n_el_recv = idxv(counter+psb_n_elem_recv_)
|
||||
n_el_recv = ipdxv(counter+psb_n_elem_recv_)
|
||||
counter = counter+n_el_recv
|
||||
n_el_send = idxv(counter+psb_n_elem_send_)
|
||||
n_el_send = ipdxv(counter+psb_n_elem_send_)
|
||||
tot_elem = 0
|
||||
Do j=0,n_el_send-1
|
||||
idx = idxv(counter+psb_elem_send_+j)
|
||||
idx = ipdxv(counter+psb_elem_send_+j)
|
||||
n_elem = a%get_nz_row(idx)
|
||||
tot_elem = tot_elem+n_elem
|
||||
Enddo
|
||||
@@ -203,11 +207,11 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,&
|
||||
idxr = 0
|
||||
counter = 1
|
||||
Do
|
||||
proc=idxv(counter)
|
||||
proc=ipdxv(counter)
|
||||
if (proc == -1) exit
|
||||
n_el_recv = idxv(counter+psb_n_elem_recv_)
|
||||
n_el_recv = ipdxv(counter+psb_n_elem_recv_)
|
||||
counter = counter+n_el_recv
|
||||
n_el_send = idxv(counter+psb_n_elem_send_)
|
||||
n_el_send = ipdxv(counter+psb_n_elem_send_)
|
||||
|
||||
bsdindx(proc+1) = idxs
|
||||
idxs = idxs + sdsz(proc+1)
|
||||
@@ -240,14 +244,14 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,&
|
||||
|
||||
tot_elem=0
|
||||
Do
|
||||
proc=idxv(counter)
|
||||
proc=ipdxv(counter)
|
||||
if (proc == -1) exit
|
||||
n_el_recv=idxv(counter+psb_n_elem_recv_)
|
||||
n_el_recv=ipdxv(counter+psb_n_elem_recv_)
|
||||
counter=counter+n_el_recv
|
||||
n_el_send=idxv(counter+psb_n_elem_send_)
|
||||
n_el_send=ipdxv(counter+psb_n_elem_send_)
|
||||
|
||||
Do j=0,n_el_send-1
|
||||
idx = idxv(counter+psb_elem_send_+j)
|
||||
idx = ipdxv(counter+psb_elem_send_+j)
|
||||
n_elem = a%get_nz_row(idx)
|
||||
call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,&
|
||||
& append=.true.,nzin=tot_elem)
|
||||
@@ -274,8 +278,8 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,&
|
||||
end if
|
||||
|
||||
|
||||
call mpi_alltoallv(valsnd,sdsz,bsdindx,mpi_complex,&
|
||||
& acoo%val,rvsz,brvindx,mpi_complex,icomm,minfo)
|
||||
call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_spk_,&
|
||||
& acoo%val,rvsz,brvindx,psb_mpi_c_spk_,icomm,minfo)
|
||||
call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_ipk_integer,&
|
||||
& acoo%ia,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo)
|
||||
call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_ipk_integer,&
|
||||
|
||||
+15
-10
@@ -124,7 +124,7 @@ subroutine psb_d_map_X2Y_vect(alpha,x,beta,y,map,info,work)
|
||||
real(psb_dpk_), allocatable :: xta(:), yta(:)
|
||||
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2 ,&
|
||||
& map_kind, nr, ictxt
|
||||
character(len=20), parameter :: name='psb_map_X2Y'
|
||||
character(len=20), parameter :: name='psb_map_X2Yv'
|
||||
|
||||
info = psb_success_
|
||||
if (.not.map%is_asb()) then
|
||||
@@ -137,11 +137,12 @@ subroutine psb_d_map_X2Y_vect(alpha,x,beta,y,map,info,work)
|
||||
|
||||
select case(map_kind)
|
||||
case(psb_map_aggr_)
|
||||
|
||||
|
||||
ictxt = map%p_desc_Y%get_context()
|
||||
nr2 = map%p_desc_Y%get_global_rows()
|
||||
nc2 = map%p_desc_Y%get_local_cols()
|
||||
call yt%bld(nc2,mold=x%v)
|
||||
!!$ write(0,*)'From map_aggr_X2Y apply: ',map%p_desc_X%v_halo_index%get_fmt()
|
||||
if (info == psb_success_) call psb_halo(x,map%p_desc_X,info,work=work)
|
||||
if (info == psb_success_) call psb_csmm(done,map%map_X2Y,x,dzero,yt,info)
|
||||
if ((info == psb_success_) .and. map%p_desc_Y%is_repl()) then
|
||||
@@ -153,8 +154,9 @@ subroutine psb_d_map_X2Y_vect(alpha,x,beta,y,map,info,work)
|
||||
if (info /= psb_success_) then
|
||||
write(psb_err_unit,*) trim(name),' Error from inner routines',info
|
||||
info = -1
|
||||
else
|
||||
call yt%free(info)
|
||||
end if
|
||||
call yt%free(info)
|
||||
|
||||
case(psb_map_gen_linear_)
|
||||
|
||||
@@ -180,10 +182,11 @@ subroutine psb_d_map_X2Y_vect(alpha,x,beta,y,map,info,work)
|
||||
if (info /= psb_success_) then
|
||||
write(psb_err_unit,*) trim(name),' Error from inner routines',info
|
||||
info = -1
|
||||
else
|
||||
call xt%free(info)
|
||||
call yt%free(info)
|
||||
end if
|
||||
|
||||
call xt%free(info)
|
||||
call yt%free(info)
|
||||
|
||||
case default
|
||||
write(psb_err_unit,*) trim(name),' Invalid descriptor input', &
|
||||
@@ -287,7 +290,7 @@ subroutine psb_d_map_Y2X_vect(alpha,x,beta,y,map,info,work)
|
||||
real(psb_dpk_), allocatable :: xta(:), yta(:)
|
||||
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,&
|
||||
& map_kind, nr, ictxt
|
||||
character(len=20), parameter :: name='psb_map_Y2X'
|
||||
character(len=20), parameter :: name='psb_map_Y2Xv'
|
||||
|
||||
info = psb_success_
|
||||
if (.not.map%is_asb()) then
|
||||
@@ -305,6 +308,7 @@ subroutine psb_d_map_Y2X_vect(alpha,x,beta,y,map,info,work)
|
||||
nr2 = map%p_desc_X%get_global_rows()
|
||||
nc2 = map%p_desc_X%get_local_cols()
|
||||
call yt%bld(nc2,mold=y%v)
|
||||
!!$ write(0,*)'From map_aggr_Y2X apply: ',map%p_desc_Y%v_halo_index%get_fmt()
|
||||
if (info == psb_success_) call psb_halo(x,map%p_desc_Y,info,work=work)
|
||||
if (info == psb_success_) call psb_csmm(done,map%map_Y2X,x,dzero,yt,info)
|
||||
if ((info == psb_success_) .and. map%p_desc_X%is_repl()) then
|
||||
@@ -316,8 +320,9 @@ subroutine psb_d_map_Y2X_vect(alpha,x,beta,y,map,info,work)
|
||||
if (info /= psb_success_) then
|
||||
write(psb_err_unit,*) trim(name),' Error from inner routines',info
|
||||
info = -1
|
||||
else
|
||||
call yt%free(info)
|
||||
end if
|
||||
call yt%free(info)
|
||||
|
||||
case(psb_map_gen_linear_)
|
||||
|
||||
@@ -342,10 +347,10 @@ subroutine psb_d_map_Y2X_vect(alpha,x,beta,y,map,info,work)
|
||||
if (info /= psb_success_) then
|
||||
write(psb_err_unit,*) trim(name),' Error from inner routines',info
|
||||
info = -1
|
||||
else
|
||||
call xt%free(info)
|
||||
call yt%free(info)
|
||||
end if
|
||||
|
||||
call xt%free(info)
|
||||
call yt%free(info)
|
||||
|
||||
case default
|
||||
write(psb_err_unit,*) trim(name),' Invalid descriptor input'
|
||||
|
||||
@@ -75,7 +75,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype)
|
||||
! .. Array Arguments ..
|
||||
integer(psb_ipk_), intent(in) :: novr
|
||||
Type(psb_dspmat_type), Intent(in) :: a
|
||||
Type(psb_desc_type), Intent(in), target :: desc_a
|
||||
Type(psb_desc_type), Intent(inout), target :: desc_a
|
||||
Type(psb_desc_type), Intent(out) :: desc_ov
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in),optional :: extype
|
||||
@@ -90,11 +90,11 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype)
|
||||
& idxr, idxs, iszr, iszs, nxch, nsnd, nrcv,lidx, extype_
|
||||
integer(psb_mpik_) :: icomm, ictxt, me, np, minfo
|
||||
|
||||
integer(psb_ipk_), allocatable :: irow(:), icol(:)
|
||||
integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:)
|
||||
integer(psb_ipk_),allocatable :: halo(:),works(:),workr(:),t_halo_in(:),&
|
||||
& t_halo_out(:),temp(:),maskr(:)
|
||||
integer(psb_mpik_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:)
|
||||
integer(psb_ipk_), allocatable :: irow(:), icol(:)
|
||||
integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:)
|
||||
integer(psb_ipk_), allocatable :: halo(:),ovrlap(:),works(:),workr(:),&
|
||||
& t_halo_in(:), t_halo_out(:),temp(:),maskr(:)
|
||||
integer(psb_mpik_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:)
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
character(len=20) :: name, ch_err
|
||||
@@ -203,11 +203,11 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype)
|
||||
If (debug_level >= psb_debug_outer_)&
|
||||
& Write(debug_unit,*) me,' ',trim(name),':ovr_est done',novr,lovr
|
||||
|
||||
index_dim = size(desc_a%halo_index)
|
||||
elem_dim = size(desc_a%halo_index)
|
||||
index_dim = max(desc_a%v_halo_index%get_nrows(),1_psb_ipk_)
|
||||
elem_dim = index_dim
|
||||
|
||||
l_tmp_ovr_idx = novr*(3*Max(2*index_dim,1)+1)
|
||||
l_tmp_halo = novr*(3*Size(desc_a%halo_index))
|
||||
l_tmp_halo = novr*(3*index_dim)
|
||||
|
||||
desc_ov%base_desc => desc_a
|
||||
|
||||
@@ -228,13 +228,18 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype)
|
||||
& t_halo_out(l_tmp_halo), temp(lworkr),stat=info)
|
||||
if (info == psb_success_) allocate(orig_ovr(l_tmp_ovr_idx),&
|
||||
& tmp_ovr_idx(l_tmp_ovr_idx), &
|
||||
& tmp_halo(l_tmp_halo), halo(size(desc_a%halo_index)),stat=info)
|
||||
& tmp_halo(l_tmp_halo),stat=info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,name)
|
||||
goto 9999
|
||||
end if
|
||||
halo(:) = desc_a%halo_index(:)
|
||||
|
||||
halo = desc_a%v_halo_index%get_vect()
|
||||
if (.not.allocated(halo)) halo = (/ -ione /)
|
||||
ovrlap = desc_a%v_ovrlap_index%get_vect()
|
||||
if (.not.allocated(ovrlap)) ovrlap = (/ -ione /)
|
||||
|
||||
tmp_ovr_idx(:) = -1
|
||||
orig_ovr(:) = -1
|
||||
tmp_halo(:) = -1
|
||||
@@ -246,14 +251,14 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype)
|
||||
cntov_o = 1
|
||||
! Init overlap with desc_a%ovrlap (if any)
|
||||
counter = 1
|
||||
Do While (desc_a%ovrlap_index(counter) /= -1)
|
||||
proc = desc_a%ovrlap_index(counter+psb_proc_id_)
|
||||
n_elem_recv = desc_a%ovrlap_index(counter+psb_n_elem_recv_)
|
||||
n_elem_send = desc_a%ovrlap_index(counter+n_elem_recv+psb_n_elem_send_)
|
||||
Do While (ovrlap(counter) /= -1)
|
||||
proc = ovrlap(counter+psb_proc_id_)
|
||||
n_elem_recv = ovrlap(counter+psb_n_elem_recv_)
|
||||
n_elem_send = ovrlap(counter+n_elem_recv+psb_n_elem_send_)
|
||||
|
||||
Do j=0,n_elem_recv-1
|
||||
|
||||
idx = desc_a%ovrlap_index(counter+psb_elem_recv_+j)
|
||||
idx = ovrlap(counter+psb_elem_recv_+j)
|
||||
call desc_ov%indxmap%l2g(idx,gidx,info)
|
||||
If (gidx < 0) then
|
||||
info=-3
|
||||
@@ -467,7 +472,8 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype)
|
||||
! accumulated RECV requests, we have an all-to-all to build
|
||||
! matchings SENDs.
|
||||
!
|
||||
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,rvsz,1,psb_mpi_def_integer,icomm,minfo)
|
||||
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,rvsz,1, &
|
||||
& psb_mpi_def_integer,icomm,minfo)
|
||||
if (minfo /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
call psb_errpush(info,name,a_err='mpi_alltoall')
|
||||
|
||||
+21
-17
@@ -87,6 +87,8 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,&
|
||||
real(psb_dpk_), allocatable :: valsnd(:)
|
||||
type(psb_d_coo_sparse_mat), allocatable :: acoo
|
||||
integer(psb_ipk_), pointer :: idxv(:)
|
||||
class(psb_i_base_vect_type), pointer :: pdxv
|
||||
integer(psb_ipk_), allocatable :: ipdxv(:)
|
||||
logical :: rowcnv_,colcnv_,rowscale_,colscale_
|
||||
character(len=5) :: outfmt_
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
@@ -158,12 +160,9 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,&
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
call desc_a%get_list(data_,idxv,totxch,nxr,nxs,info)
|
||||
|
||||
l1 = 0
|
||||
|
||||
sdsz(:)=0
|
||||
rvsz(:)=0
|
||||
l1 = 0
|
||||
ipx = 1
|
||||
brvindx(ipx) = 0
|
||||
bsdindx(ipx) = 0
|
||||
@@ -171,17 +170,22 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,&
|
||||
idx = 0
|
||||
idxs = 0
|
||||
idxr = 0
|
||||
|
||||
call acoo%allocate(izero,a%get_ncols(),info)
|
||||
|
||||
|
||||
call desc_a%get_list(data_,pdxv,totxch,nxr,nxs,info)
|
||||
ipdxv = pdxv%get_vect()
|
||||
! For all rows in the halo descriptor, extract and send/receive.
|
||||
Do
|
||||
proc=idxv(counter)
|
||||
proc=ipdxv(counter)
|
||||
if (proc == -1) exit
|
||||
n_el_recv = idxv(counter+psb_n_elem_recv_)
|
||||
n_el_recv = ipdxv(counter+psb_n_elem_recv_)
|
||||
counter = counter+n_el_recv
|
||||
n_el_send = idxv(counter+psb_n_elem_send_)
|
||||
n_el_send = ipdxv(counter+psb_n_elem_send_)
|
||||
tot_elem = 0
|
||||
Do j=0,n_el_send-1
|
||||
idx = idxv(counter+psb_elem_send_+j)
|
||||
idx = ipdxv(counter+psb_elem_send_+j)
|
||||
n_elem = a%get_nz_row(idx)
|
||||
tot_elem = tot_elem+n_elem
|
||||
Enddo
|
||||
@@ -203,11 +207,11 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,&
|
||||
idxr = 0
|
||||
counter = 1
|
||||
Do
|
||||
proc=idxv(counter)
|
||||
proc=ipdxv(counter)
|
||||
if (proc == -1) exit
|
||||
n_el_recv = idxv(counter+psb_n_elem_recv_)
|
||||
n_el_recv = ipdxv(counter+psb_n_elem_recv_)
|
||||
counter = counter+n_el_recv
|
||||
n_el_send = idxv(counter+psb_n_elem_send_)
|
||||
n_el_send = ipdxv(counter+psb_n_elem_send_)
|
||||
|
||||
bsdindx(proc+1) = idxs
|
||||
idxs = idxs + sdsz(proc+1)
|
||||
@@ -240,14 +244,14 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,&
|
||||
|
||||
tot_elem=0
|
||||
Do
|
||||
proc=idxv(counter)
|
||||
proc=ipdxv(counter)
|
||||
if (proc == -1) exit
|
||||
n_el_recv=idxv(counter+psb_n_elem_recv_)
|
||||
n_el_recv=ipdxv(counter+psb_n_elem_recv_)
|
||||
counter=counter+n_el_recv
|
||||
n_el_send=idxv(counter+psb_n_elem_send_)
|
||||
n_el_send=ipdxv(counter+psb_n_elem_send_)
|
||||
|
||||
Do j=0,n_el_send-1
|
||||
idx = idxv(counter+psb_elem_send_+j)
|
||||
idx = ipdxv(counter+psb_elem_send_+j)
|
||||
n_elem = a%get_nz_row(idx)
|
||||
call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,&
|
||||
& append=.true.,nzin=tot_elem)
|
||||
@@ -274,8 +278,8 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,&
|
||||
end if
|
||||
|
||||
|
||||
call mpi_alltoallv(valsnd,sdsz,bsdindx,mpi_double_precision,&
|
||||
& acoo%val,rvsz,brvindx,mpi_double_precision,icomm,minfo)
|
||||
call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_dpk_,&
|
||||
& acoo%val,rvsz,brvindx,psb_mpi_r_dpk_,icomm,minfo)
|
||||
call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_ipk_integer,&
|
||||
& acoo%ia,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo)
|
||||
call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_ipk_integer,&
|
||||
|
||||
@@ -42,7 +42,7 @@
|
||||
! coming from the build of an extended
|
||||
! halo descriptor with respect to a normal call.
|
||||
!
|
||||
subroutine psb_icdasb(desc,info,ext_hv)
|
||||
subroutine psb_icdasb(desc,info,ext_hv,mold)
|
||||
use psb_base_mod, psb_protect_name => psb_icdasb
|
||||
use psi_mod
|
||||
#ifdef MPI_MOD
|
||||
@@ -56,6 +56,7 @@ subroutine psb_icdasb(desc,info,ext_hv)
|
||||
type(psb_desc_type), intent(inout) :: desc
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
logical, intent(in), optional :: ext_hv
|
||||
class(psb_i_base_vect_type), optional, intent(in) :: mold
|
||||
|
||||
!....Locals....
|
||||
integer(psb_ipk_) :: int_err(5)
|
||||
@@ -130,7 +131,7 @@ subroutine psb_icdasb(desc,info,ext_hv)
|
||||
if (debug_level >= psb_debug_ext_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),': Final conversion'
|
||||
! Then convert and put them back where they belong.
|
||||
call psi_cnv_dsc(halo_index,ovrlap_index,ext_index,desc,info)
|
||||
call psi_cnv_dsc(halo_index,ovrlap_index,ext_index,desc,info,mold=mold)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_cnv_dsc')
|
||||
@@ -160,6 +161,9 @@ subroutine psb_icdasb(desc,info,ext_hv)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
if (present(mold)) &
|
||||
& call desc%cnv(mold)
|
||||
|
||||
if (debug_level >= psb_debug_ext_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),': Done'
|
||||
|
||||
|
||||
@@ -82,7 +82,6 @@ subroutine psb_iinsvi(m, irw, val, x, desc_a, info, dupl,local)
|
||||
call psb_errpush(info,name)
|
||||
return
|
||||
end if
|
||||
|
||||
ictxt=desc_a%get_context()
|
||||
|
||||
call psb_info(ictxt, me, np)
|
||||
@@ -268,7 +267,6 @@ subroutine psb_iinsi(m, irw, val, x, desc_a, info, dupl,local)
|
||||
call psb_errpush(info,name)
|
||||
return
|
||||
end if
|
||||
|
||||
ictxt=desc_a%get_context()
|
||||
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
@@ -124,7 +124,7 @@ subroutine psb_s_map_X2Y_vect(alpha,x,beta,y,map,info,work)
|
||||
real(psb_spk_), allocatable :: xta(:), yta(:)
|
||||
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2 ,&
|
||||
& map_kind, nr, ictxt
|
||||
character(len=20), parameter :: name='psb_map_X2Y'
|
||||
character(len=20), parameter :: name='psb_map_X2Yv'
|
||||
|
||||
info = psb_success_
|
||||
if (.not.map%is_asb()) then
|
||||
@@ -153,8 +153,9 @@ subroutine psb_s_map_X2Y_vect(alpha,x,beta,y,map,info,work)
|
||||
if (info /= psb_success_) then
|
||||
write(psb_err_unit,*) trim(name),' Error from inner routines',info
|
||||
info = -1
|
||||
else
|
||||
call yt%free(info)
|
||||
end if
|
||||
call yt%free(info)
|
||||
|
||||
case(psb_map_gen_linear_)
|
||||
|
||||
@@ -180,10 +181,11 @@ subroutine psb_s_map_X2Y_vect(alpha,x,beta,y,map,info,work)
|
||||
if (info /= psb_success_) then
|
||||
write(psb_err_unit,*) trim(name),' Error from inner routines',info
|
||||
info = -1
|
||||
else
|
||||
call xt%free(info)
|
||||
call yt%free(info)
|
||||
end if
|
||||
|
||||
call xt%free(info)
|
||||
call yt%free(info)
|
||||
|
||||
case default
|
||||
write(psb_err_unit,*) trim(name),' Invalid descriptor input', &
|
||||
@@ -287,7 +289,7 @@ subroutine psb_s_map_Y2X_vect(alpha,x,beta,y,map,info,work)
|
||||
real(psb_spk_), allocatable :: xta(:), yta(:)
|
||||
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,&
|
||||
& map_kind, nr, ictxt
|
||||
character(len=20), parameter :: name='psb_map_Y2X'
|
||||
character(len=20), parameter :: name='psb_map_Y2Xv'
|
||||
|
||||
info = psb_success_
|
||||
if (.not.map%is_asb()) then
|
||||
@@ -316,8 +318,9 @@ subroutine psb_s_map_Y2X_vect(alpha,x,beta,y,map,info,work)
|
||||
if (info /= psb_success_) then
|
||||
write(psb_err_unit,*) trim(name),' Error from inner routines',info
|
||||
info = -1
|
||||
else
|
||||
call yt%free(info)
|
||||
end if
|
||||
call yt%free(info)
|
||||
|
||||
case(psb_map_gen_linear_)
|
||||
|
||||
@@ -342,10 +345,10 @@ subroutine psb_s_map_Y2X_vect(alpha,x,beta,y,map,info,work)
|
||||
if (info /= psb_success_) then
|
||||
write(psb_err_unit,*) trim(name),' Error from inner routines',info
|
||||
info = -1
|
||||
else
|
||||
call xt%free(info)
|
||||
call yt%free(info)
|
||||
end if
|
||||
|
||||
call xt%free(info)
|
||||
call yt%free(info)
|
||||
|
||||
case default
|
||||
write(psb_err_unit,*) trim(name),' Invalid descriptor input'
|
||||
|
||||
@@ -75,7 +75,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
|
||||
! .. Array Arguments ..
|
||||
integer(psb_ipk_), intent(in) :: novr
|
||||
Type(psb_sspmat_type), Intent(in) :: a
|
||||
Type(psb_desc_type), Intent(in), target :: desc_a
|
||||
Type(psb_desc_type), Intent(inout), target :: desc_a
|
||||
Type(psb_desc_type), Intent(out) :: desc_ov
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in),optional :: extype
|
||||
@@ -90,11 +90,11 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
|
||||
& idxr, idxs, iszr, iszs, nxch, nsnd, nrcv,lidx, extype_
|
||||
integer(psb_mpik_) :: icomm, ictxt, me, np, minfo
|
||||
|
||||
integer(psb_ipk_), allocatable :: irow(:), icol(:)
|
||||
integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:)
|
||||
integer(psb_ipk_),allocatable :: halo(:),works(:),workr(:),t_halo_in(:),&
|
||||
& t_halo_out(:),temp(:),maskr(:)
|
||||
integer(psb_mpik_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:)
|
||||
integer(psb_ipk_), allocatable :: irow(:), icol(:)
|
||||
integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:)
|
||||
integer(psb_ipk_), allocatable :: halo(:),ovrlap(:),works(:),workr(:),&
|
||||
& t_halo_in(:), t_halo_out(:),temp(:),maskr(:)
|
||||
integer(psb_mpik_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:)
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
character(len=20) :: name, ch_err
|
||||
@@ -203,11 +203,11 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
|
||||
If (debug_level >= psb_debug_outer_)&
|
||||
& Write(debug_unit,*) me,' ',trim(name),':ovr_est done',novr,lovr
|
||||
|
||||
index_dim = size(desc_a%halo_index)
|
||||
elem_dim = size(desc_a%halo_index)
|
||||
index_dim = max(desc_a%v_halo_index%get_nrows(),1_psb_ipk_)
|
||||
elem_dim = index_dim
|
||||
|
||||
l_tmp_ovr_idx = novr*(3*Max(2*index_dim,1)+1)
|
||||
l_tmp_halo = novr*(3*Size(desc_a%halo_index))
|
||||
l_tmp_halo = novr*(3*index_dim)
|
||||
|
||||
desc_ov%base_desc => desc_a
|
||||
|
||||
@@ -228,13 +228,18 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
|
||||
& t_halo_out(l_tmp_halo), temp(lworkr),stat=info)
|
||||
if (info == psb_success_) allocate(orig_ovr(l_tmp_ovr_idx),&
|
||||
& tmp_ovr_idx(l_tmp_ovr_idx), &
|
||||
& tmp_halo(l_tmp_halo), halo(size(desc_a%halo_index)),stat=info)
|
||||
& tmp_halo(l_tmp_halo),stat=info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,name)
|
||||
goto 9999
|
||||
end if
|
||||
halo(:) = desc_a%halo_index(:)
|
||||
|
||||
halo = desc_a%v_halo_index%get_vect()
|
||||
if (.not.allocated(halo)) halo = (/ -ione /)
|
||||
ovrlap = desc_a%v_ovrlap_index%get_vect()
|
||||
if (.not.allocated(ovrlap)) ovrlap = (/ -ione /)
|
||||
|
||||
tmp_ovr_idx(:) = -1
|
||||
orig_ovr(:) = -1
|
||||
tmp_halo(:) = -1
|
||||
@@ -246,14 +251,14 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
|
||||
cntov_o = 1
|
||||
! Init overlap with desc_a%ovrlap (if any)
|
||||
counter = 1
|
||||
Do While (desc_a%ovrlap_index(counter) /= -1)
|
||||
proc = desc_a%ovrlap_index(counter+psb_proc_id_)
|
||||
n_elem_recv = desc_a%ovrlap_index(counter+psb_n_elem_recv_)
|
||||
n_elem_send = desc_a%ovrlap_index(counter+n_elem_recv+psb_n_elem_send_)
|
||||
Do While (ovrlap(counter) /= -1)
|
||||
proc = ovrlap(counter+psb_proc_id_)
|
||||
n_elem_recv = ovrlap(counter+psb_n_elem_recv_)
|
||||
n_elem_send = ovrlap(counter+n_elem_recv+psb_n_elem_send_)
|
||||
|
||||
Do j=0,n_elem_recv-1
|
||||
|
||||
idx = desc_a%ovrlap_index(counter+psb_elem_recv_+j)
|
||||
idx = ovrlap(counter+psb_elem_recv_+j)
|
||||
call desc_ov%indxmap%l2g(idx,gidx,info)
|
||||
If (gidx < 0) then
|
||||
info=-3
|
||||
@@ -467,7 +472,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
|
||||
! accumulated RECV requests, we have an all-to-all to build
|
||||
! matchings SENDs.
|
||||
!
|
||||
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,rvsz,1,psb_mpi_def_integer,icomm,minfo)
|
||||
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,rvsz,1, &
|
||||
& psb_mpi_def_integer,icomm,minfo)
|
||||
if (minfo /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
call psb_errpush(info,name,a_err='mpi_alltoall')
|
||||
|
||||
+21
-17
@@ -87,6 +87,8 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,&
|
||||
real(psb_spk_), allocatable :: valsnd(:)
|
||||
type(psb_s_coo_sparse_mat), allocatable :: acoo
|
||||
integer(psb_ipk_), pointer :: idxv(:)
|
||||
class(psb_i_base_vect_type), pointer :: pdxv
|
||||
integer(psb_ipk_), allocatable :: ipdxv(:)
|
||||
logical :: rowcnv_,colcnv_,rowscale_,colscale_
|
||||
character(len=5) :: outfmt_
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
@@ -158,12 +160,9 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,&
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
call desc_a%get_list(data_,idxv,totxch,nxr,nxs,info)
|
||||
|
||||
l1 = 0
|
||||
|
||||
sdsz(:)=0
|
||||
rvsz(:)=0
|
||||
l1 = 0
|
||||
ipx = 1
|
||||
brvindx(ipx) = 0
|
||||
bsdindx(ipx) = 0
|
||||
@@ -171,17 +170,22 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,&
|
||||
idx = 0
|
||||
idxs = 0
|
||||
idxr = 0
|
||||
|
||||
call acoo%allocate(izero,a%get_ncols(),info)
|
||||
|
||||
|
||||
call desc_a%get_list(data_,pdxv,totxch,nxr,nxs,info)
|
||||
ipdxv = pdxv%get_vect()
|
||||
! For all rows in the halo descriptor, extract and send/receive.
|
||||
Do
|
||||
proc=idxv(counter)
|
||||
proc=ipdxv(counter)
|
||||
if (proc == -1) exit
|
||||
n_el_recv = idxv(counter+psb_n_elem_recv_)
|
||||
n_el_recv = ipdxv(counter+psb_n_elem_recv_)
|
||||
counter = counter+n_el_recv
|
||||
n_el_send = idxv(counter+psb_n_elem_send_)
|
||||
n_el_send = ipdxv(counter+psb_n_elem_send_)
|
||||
tot_elem = 0
|
||||
Do j=0,n_el_send-1
|
||||
idx = idxv(counter+psb_elem_send_+j)
|
||||
idx = ipdxv(counter+psb_elem_send_+j)
|
||||
n_elem = a%get_nz_row(idx)
|
||||
tot_elem = tot_elem+n_elem
|
||||
Enddo
|
||||
@@ -203,11 +207,11 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,&
|
||||
idxr = 0
|
||||
counter = 1
|
||||
Do
|
||||
proc=idxv(counter)
|
||||
proc=ipdxv(counter)
|
||||
if (proc == -1) exit
|
||||
n_el_recv = idxv(counter+psb_n_elem_recv_)
|
||||
n_el_recv = ipdxv(counter+psb_n_elem_recv_)
|
||||
counter = counter+n_el_recv
|
||||
n_el_send = idxv(counter+psb_n_elem_send_)
|
||||
n_el_send = ipdxv(counter+psb_n_elem_send_)
|
||||
|
||||
bsdindx(proc+1) = idxs
|
||||
idxs = idxs + sdsz(proc+1)
|
||||
@@ -240,14 +244,14 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,&
|
||||
|
||||
tot_elem=0
|
||||
Do
|
||||
proc=idxv(counter)
|
||||
proc=ipdxv(counter)
|
||||
if (proc == -1) exit
|
||||
n_el_recv=idxv(counter+psb_n_elem_recv_)
|
||||
n_el_recv=ipdxv(counter+psb_n_elem_recv_)
|
||||
counter=counter+n_el_recv
|
||||
n_el_send=idxv(counter+psb_n_elem_send_)
|
||||
n_el_send=ipdxv(counter+psb_n_elem_send_)
|
||||
|
||||
Do j=0,n_el_send-1
|
||||
idx = idxv(counter+psb_elem_send_+j)
|
||||
idx = ipdxv(counter+psb_elem_send_+j)
|
||||
n_elem = a%get_nz_row(idx)
|
||||
call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,&
|
||||
& append=.true.,nzin=tot_elem)
|
||||
@@ -274,8 +278,8 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,&
|
||||
end if
|
||||
|
||||
|
||||
call mpi_alltoallv(valsnd,sdsz,bsdindx,mpi_real,&
|
||||
& acoo%val,rvsz,brvindx,mpi_real,icomm,minfo)
|
||||
call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_spk_,&
|
||||
& acoo%val,rvsz,brvindx,psb_mpi_r_spk_,icomm,minfo)
|
||||
call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_ipk_integer,&
|
||||
& acoo%ia,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo)
|
||||
call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_ipk_integer,&
|
||||
|
||||
@@ -124,7 +124,7 @@ subroutine psb_z_map_X2Y_vect(alpha,x,beta,y,map,info,work)
|
||||
complex(psb_dpk_), allocatable :: xta(:), yta(:)
|
||||
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2 ,&
|
||||
& map_kind, nr, ictxt
|
||||
character(len=20), parameter :: name='psb_map_X2Y'
|
||||
character(len=20), parameter :: name='psb_map_X2Yv'
|
||||
|
||||
info = psb_success_
|
||||
if (.not.map%is_asb()) then
|
||||
@@ -153,8 +153,9 @@ subroutine psb_z_map_X2Y_vect(alpha,x,beta,y,map,info,work)
|
||||
if (info /= psb_success_) then
|
||||
write(psb_err_unit,*) trim(name),' Error from inner routines',info
|
||||
info = -1
|
||||
else
|
||||
call yt%free(info)
|
||||
end if
|
||||
call yt%free(info)
|
||||
|
||||
case(psb_map_gen_linear_)
|
||||
|
||||
@@ -180,10 +181,11 @@ subroutine psb_z_map_X2Y_vect(alpha,x,beta,y,map,info,work)
|
||||
if (info /= psb_success_) then
|
||||
write(psb_err_unit,*) trim(name),' Error from inner routines',info
|
||||
info = -1
|
||||
else
|
||||
call xt%free(info)
|
||||
call yt%free(info)
|
||||
end if
|
||||
|
||||
call xt%free(info)
|
||||
call yt%free(info)
|
||||
|
||||
case default
|
||||
write(psb_err_unit,*) trim(name),' Invalid descriptor input', &
|
||||
@@ -287,7 +289,7 @@ subroutine psb_z_map_Y2X_vect(alpha,x,beta,y,map,info,work)
|
||||
complex(psb_dpk_), allocatable :: xta(:), yta(:)
|
||||
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,&
|
||||
& map_kind, nr, ictxt
|
||||
character(len=20), parameter :: name='psb_map_Y2X'
|
||||
character(len=20), parameter :: name='psb_map_Y2Xv'
|
||||
|
||||
info = psb_success_
|
||||
if (.not.map%is_asb()) then
|
||||
@@ -316,8 +318,9 @@ subroutine psb_z_map_Y2X_vect(alpha,x,beta,y,map,info,work)
|
||||
if (info /= psb_success_) then
|
||||
write(psb_err_unit,*) trim(name),' Error from inner routines',info
|
||||
info = -1
|
||||
else
|
||||
call yt%free(info)
|
||||
end if
|
||||
call yt%free(info)
|
||||
|
||||
case(psb_map_gen_linear_)
|
||||
|
||||
@@ -342,10 +345,10 @@ subroutine psb_z_map_Y2X_vect(alpha,x,beta,y,map,info,work)
|
||||
if (info /= psb_success_) then
|
||||
write(psb_err_unit,*) trim(name),' Error from inner routines',info
|
||||
info = -1
|
||||
else
|
||||
call xt%free(info)
|
||||
call yt%free(info)
|
||||
end if
|
||||
|
||||
call xt%free(info)
|
||||
call yt%free(info)
|
||||
|
||||
case default
|
||||
write(psb_err_unit,*) trim(name),' Invalid descriptor input'
|
||||
|
||||
@@ -75,7 +75,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
|
||||
! .. Array Arguments ..
|
||||
integer(psb_ipk_), intent(in) :: novr
|
||||
Type(psb_zspmat_type), Intent(in) :: a
|
||||
Type(psb_desc_type), Intent(in), target :: desc_a
|
||||
Type(psb_desc_type), Intent(inout), target :: desc_a
|
||||
Type(psb_desc_type), Intent(out) :: desc_ov
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in),optional :: extype
|
||||
@@ -90,11 +90,11 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
|
||||
& idxr, idxs, iszr, iszs, nxch, nsnd, nrcv,lidx, extype_
|
||||
integer(psb_mpik_) :: icomm, ictxt, me, np, minfo
|
||||
|
||||
integer(psb_ipk_), allocatable :: irow(:), icol(:)
|
||||
integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:)
|
||||
integer(psb_ipk_),allocatable :: halo(:),works(:),workr(:),t_halo_in(:),&
|
||||
& t_halo_out(:),temp(:),maskr(:)
|
||||
integer(psb_mpik_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:)
|
||||
integer(psb_ipk_), allocatable :: irow(:), icol(:)
|
||||
integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:)
|
||||
integer(psb_ipk_), allocatable :: halo(:),ovrlap(:),works(:),workr(:),&
|
||||
& t_halo_in(:), t_halo_out(:),temp(:),maskr(:)
|
||||
integer(psb_mpik_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:)
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
character(len=20) :: name, ch_err
|
||||
@@ -203,11 +203,11 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
|
||||
If (debug_level >= psb_debug_outer_)&
|
||||
& Write(debug_unit,*) me,' ',trim(name),':ovr_est done',novr,lovr
|
||||
|
||||
index_dim = size(desc_a%halo_index)
|
||||
elem_dim = size(desc_a%halo_index)
|
||||
index_dim = max(desc_a%v_halo_index%get_nrows(),1_psb_ipk_)
|
||||
elem_dim = index_dim
|
||||
|
||||
l_tmp_ovr_idx = novr*(3*Max(2*index_dim,1)+1)
|
||||
l_tmp_halo = novr*(3*Size(desc_a%halo_index))
|
||||
l_tmp_halo = novr*(3*index_dim)
|
||||
|
||||
desc_ov%base_desc => desc_a
|
||||
|
||||
@@ -228,13 +228,18 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
|
||||
& t_halo_out(l_tmp_halo), temp(lworkr),stat=info)
|
||||
if (info == psb_success_) allocate(orig_ovr(l_tmp_ovr_idx),&
|
||||
& tmp_ovr_idx(l_tmp_ovr_idx), &
|
||||
& tmp_halo(l_tmp_halo), halo(size(desc_a%halo_index)),stat=info)
|
||||
& tmp_halo(l_tmp_halo),stat=info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,name)
|
||||
goto 9999
|
||||
end if
|
||||
halo(:) = desc_a%halo_index(:)
|
||||
|
||||
halo = desc_a%v_halo_index%get_vect()
|
||||
if (.not.allocated(halo)) halo = (/ -ione /)
|
||||
ovrlap = desc_a%v_ovrlap_index%get_vect()
|
||||
if (.not.allocated(ovrlap)) ovrlap = (/ -ione /)
|
||||
|
||||
tmp_ovr_idx(:) = -1
|
||||
orig_ovr(:) = -1
|
||||
tmp_halo(:) = -1
|
||||
@@ -246,14 +251,14 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
|
||||
cntov_o = 1
|
||||
! Init overlap with desc_a%ovrlap (if any)
|
||||
counter = 1
|
||||
Do While (desc_a%ovrlap_index(counter) /= -1)
|
||||
proc = desc_a%ovrlap_index(counter+psb_proc_id_)
|
||||
n_elem_recv = desc_a%ovrlap_index(counter+psb_n_elem_recv_)
|
||||
n_elem_send = desc_a%ovrlap_index(counter+n_elem_recv+psb_n_elem_send_)
|
||||
Do While (ovrlap(counter) /= -1)
|
||||
proc = ovrlap(counter+psb_proc_id_)
|
||||
n_elem_recv = ovrlap(counter+psb_n_elem_recv_)
|
||||
n_elem_send = ovrlap(counter+n_elem_recv+psb_n_elem_send_)
|
||||
|
||||
Do j=0,n_elem_recv-1
|
||||
|
||||
idx = desc_a%ovrlap_index(counter+psb_elem_recv_+j)
|
||||
idx = ovrlap(counter+psb_elem_recv_+j)
|
||||
call desc_ov%indxmap%l2g(idx,gidx,info)
|
||||
If (gidx < 0) then
|
||||
info=-3
|
||||
@@ -467,7 +472,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
|
||||
! accumulated RECV requests, we have an all-to-all to build
|
||||
! matchings SENDs.
|
||||
!
|
||||
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,rvsz,1,psb_mpi_def_integer,icomm,minfo)
|
||||
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,rvsz,1, &
|
||||
& psb_mpi_def_integer,icomm,minfo)
|
||||
if (minfo /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
call psb_errpush(info,name,a_err='mpi_alltoall')
|
||||
|
||||
+21
-17
@@ -87,6 +87,8 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,&
|
||||
complex(psb_dpk_), allocatable :: valsnd(:)
|
||||
type(psb_z_coo_sparse_mat), allocatable :: acoo
|
||||
integer(psb_ipk_), pointer :: idxv(:)
|
||||
class(psb_i_base_vect_type), pointer :: pdxv
|
||||
integer(psb_ipk_), allocatable :: ipdxv(:)
|
||||
logical :: rowcnv_,colcnv_,rowscale_,colscale_
|
||||
character(len=5) :: outfmt_
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
@@ -158,12 +160,9 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,&
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
call desc_a%get_list(data_,idxv,totxch,nxr,nxs,info)
|
||||
|
||||
l1 = 0
|
||||
|
||||
sdsz(:)=0
|
||||
rvsz(:)=0
|
||||
l1 = 0
|
||||
ipx = 1
|
||||
brvindx(ipx) = 0
|
||||
bsdindx(ipx) = 0
|
||||
@@ -171,17 +170,22 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,&
|
||||
idx = 0
|
||||
idxs = 0
|
||||
idxr = 0
|
||||
|
||||
call acoo%allocate(izero,a%get_ncols(),info)
|
||||
|
||||
|
||||
call desc_a%get_list(data_,pdxv,totxch,nxr,nxs,info)
|
||||
ipdxv = pdxv%get_vect()
|
||||
! For all rows in the halo descriptor, extract and send/receive.
|
||||
Do
|
||||
proc=idxv(counter)
|
||||
proc=ipdxv(counter)
|
||||
if (proc == -1) exit
|
||||
n_el_recv = idxv(counter+psb_n_elem_recv_)
|
||||
n_el_recv = ipdxv(counter+psb_n_elem_recv_)
|
||||
counter = counter+n_el_recv
|
||||
n_el_send = idxv(counter+psb_n_elem_send_)
|
||||
n_el_send = ipdxv(counter+psb_n_elem_send_)
|
||||
tot_elem = 0
|
||||
Do j=0,n_el_send-1
|
||||
idx = idxv(counter+psb_elem_send_+j)
|
||||
idx = ipdxv(counter+psb_elem_send_+j)
|
||||
n_elem = a%get_nz_row(idx)
|
||||
tot_elem = tot_elem+n_elem
|
||||
Enddo
|
||||
@@ -203,11 +207,11 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,&
|
||||
idxr = 0
|
||||
counter = 1
|
||||
Do
|
||||
proc=idxv(counter)
|
||||
proc=ipdxv(counter)
|
||||
if (proc == -1) exit
|
||||
n_el_recv = idxv(counter+psb_n_elem_recv_)
|
||||
n_el_recv = ipdxv(counter+psb_n_elem_recv_)
|
||||
counter = counter+n_el_recv
|
||||
n_el_send = idxv(counter+psb_n_elem_send_)
|
||||
n_el_send = ipdxv(counter+psb_n_elem_send_)
|
||||
|
||||
bsdindx(proc+1) = idxs
|
||||
idxs = idxs + sdsz(proc+1)
|
||||
@@ -240,14 +244,14 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,&
|
||||
|
||||
tot_elem=0
|
||||
Do
|
||||
proc=idxv(counter)
|
||||
proc=ipdxv(counter)
|
||||
if (proc == -1) exit
|
||||
n_el_recv=idxv(counter+psb_n_elem_recv_)
|
||||
n_el_recv=ipdxv(counter+psb_n_elem_recv_)
|
||||
counter=counter+n_el_recv
|
||||
n_el_send=idxv(counter+psb_n_elem_send_)
|
||||
n_el_send=ipdxv(counter+psb_n_elem_send_)
|
||||
|
||||
Do j=0,n_el_send-1
|
||||
idx = idxv(counter+psb_elem_send_+j)
|
||||
idx = ipdxv(counter+psb_elem_send_+j)
|
||||
n_elem = a%get_nz_row(idx)
|
||||
call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,&
|
||||
& append=.true.,nzin=tot_elem)
|
||||
@@ -274,8 +278,8 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,&
|
||||
end if
|
||||
|
||||
|
||||
call mpi_alltoallv(valsnd,sdsz,bsdindx,mpi_double_complex,&
|
||||
& acoo%val,rvsz,brvindx,mpi_double_complex,icomm,minfo)
|
||||
call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_dpk_,&
|
||||
& acoo%val,rvsz,brvindx,psb_mpi_c_dpk_,icomm,minfo)
|
||||
call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_ipk_integer,&
|
||||
& acoo%ia,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo)
|
||||
call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_ipk_integer,&
|
||||
|
||||
+111
@@ -1726,3 +1726,114 @@ LIBS="$SAVE_LIBS";
|
||||
CPPFLAGS="$SAVE_CPPFLAGS";
|
||||
])dnl
|
||||
|
||||
dnl @synopsis PAC_CHECK_METIS
|
||||
dnl
|
||||
dnl Will try to find the METIS library and headers.
|
||||
dnl
|
||||
dnl Will use $CC
|
||||
dnl
|
||||
dnl If the test passes, will execute ACTION-IF-FOUND. Otherwise, ACTION-IF-NOT-FOUND.
|
||||
dnl Note : This file will be likely to induce the compiler to create a module file
|
||||
dnl (for a module called conftest).
|
||||
dnl Depending on the compiler flags, this could cause a conftest.mod file to appear
|
||||
dnl in the present directory, or in another, or with another name. So be warned!
|
||||
dnl
|
||||
dnl @author Salvatore Filippone <salvatore.filippone@uniroma2.it>
|
||||
dnl
|
||||
AC_DEFUN(PAC_CHECK_METIS,
|
||||
[AC_ARG_WITH(metis, AC_HELP_STRING([--with-metis=LIBNAME], [Specify the library name for METIS library.
|
||||
Default: "-lmetis"]),
|
||||
[psblas_cv_metis=$withval],
|
||||
[psblas_cv_metis='-lmetis'])
|
||||
AC_ARG_WITH(metisdir, AC_HELP_STRING([--with-metisdir=DIR], [Specify the directory for METIS library and includes.]),
|
||||
[psblas_cv_metisdir=$withval],
|
||||
[psblas_cv_metisdir=''])
|
||||
AC_ARG_WITH(metisincdir, AC_HELP_STRING([--with-metisincdir=DIR], [Specify the directory for METIS includes.]),
|
||||
[psblas_cv_metisincdir=$withval],
|
||||
[psblas_cv_metisincdir=''])
|
||||
AC_ARG_WITH(metislibdir, AC_HELP_STRING([--with-metislibdir=DIR], [Specify the directory for METIS library.]),
|
||||
[psblas_cv_metislibdir=$withval],
|
||||
[psblas_cv_metislibdir=''])
|
||||
|
||||
AC_LANG([C])
|
||||
SAVE_LIBS="$LIBS"
|
||||
SAVE_CPPFLAGS="$CPPFLAGS"
|
||||
if test "x$psblas_cv_metisdir" != "x"; then
|
||||
METIS_LIBDIR="-L$psblas_cv_metisdir"
|
||||
LIBS="-L$psblas_cv_metisdir $LIBS"
|
||||
METIS_INCLUDES="-I$psblas_cv_metisdir"
|
||||
CPPFLAGS="$METIS_INCLUDES $CPPFLAGS"
|
||||
fi
|
||||
if test "x$psblas_cv_metisincdir" != "x"; then
|
||||
METIS_INCLUDES="-I$psblas_cv_metisincdir"
|
||||
CPPFLAGS="$METIS_INCLUDES $CPPFLAGS"
|
||||
fi
|
||||
if test "x$psblas_cv_metislibdir" != "x"; then
|
||||
LIBS="-L$psblas_cv_metislibdir $LIBS"
|
||||
METIS_LIBDIR="-L$psblas_cv_metislibdir"
|
||||
fi
|
||||
|
||||
AC_MSG_NOTICE([metis dir $psblas_cv_metisdir])
|
||||
AC_CHECK_HEADER([metis.h],
|
||||
[pac_metis_header_ok=yes],
|
||||
[pac_metis_header_ok=no; METIS_INCLUDES=""])
|
||||
if test "x$pac_metis_header_ok" == "xno" ; then
|
||||
dnl Maybe Include or include subdirs?
|
||||
unset ac_cv_header_metis_h
|
||||
METIS_INCLUDES="-I$psblas_cv_metisdir/include -I$psblas_cv_metisdir/Include "
|
||||
CPPFLAGS="$METIS_INCLUDES $SAVE_CPPFLAGS"
|
||||
|
||||
AC_MSG_CHECKING([for metis_h in $METIS_INCLUDES])
|
||||
AC_CHECK_HEADER([metis.h],
|
||||
[pac_metis_header_ok=yes],
|
||||
[pac_metis_header_ok=no; METIS_INCLUDES=""])
|
||||
fi
|
||||
if test "x$pac_metis_header_ok" == "xno" ; then
|
||||
dnl Maybe new structure with METIS UFconfig METIS?
|
||||
unset ac_cv_header_metis_h
|
||||
METIS_INCLUDES="-I$psblas_cv_metisdir/UFconfig -I$psblas_cv_metisdir/METIS/Include -I$psblas_cv_metisdir/METIS/Include"
|
||||
CPPFLAGS="$METIS_INCLUDES $SAVE_CPPFLAGS"
|
||||
AC_CHECK_HEADER([metis.h],
|
||||
[pac_metis_header_ok=yes],
|
||||
[pac_metis_header_ok=no; METIS_INCLUDES=""])
|
||||
fi
|
||||
|
||||
|
||||
if test "x$pac_metis_header_ok" == "xyes" ; then
|
||||
psblas_cv_metis_includes="$METIS_INCLUDES"
|
||||
METIS_LIBS="$psblas_cv_metis $METIS_LIBDIR"
|
||||
LIBS="$METIS_LIBS -lm $LIBS";
|
||||
AC_MSG_CHECKING([for METIS_PartGraphRecursive in $METIS_LIBS])
|
||||
AC_TRY_LINK_FUNC(METIS_PartGraphRecursive,
|
||||
[psblas_cv_have_metis=yes;pac_metis_lib_ok=yes; ],
|
||||
[psblas_cv_have_metis=no;pac_metis_lib_ok=no; METIS_LIBS=""])
|
||||
AC_MSG_RESULT($pac_metis_lib_ok)
|
||||
if test "x$pac_metis_lib_ok" == "xno" ; then
|
||||
dnl Maybe Lib or lib?
|
||||
METIS_LIBDIR="-L$psblas_cv_metisdir/Lib -L$psblas_cv_metisdir/lib"
|
||||
METIS_LIBS="$psblas_cv_metis $METIS_LIBDIR"
|
||||
LIBS="$METIS_LIBS -lm $SAVE_LIBS"
|
||||
|
||||
AC_MSG_CHECKING([for METIS_PartGraphRecursive in $METIS_LIBS])
|
||||
AC_TRY_LINK_FUNC(METIS_PartGraphRecursive,
|
||||
[psblas_cv_have_metis=yes;pac_metis_lib_ok=yes; ],
|
||||
[psblas_cv_have_metis=no;pac_metis_lib_ok=no; METIS_LIBS=""])
|
||||
AC_MSG_RESULT($pac_metis_lib_ok)
|
||||
fi
|
||||
if test "x$pac_metis_lib_ok" == "xno" ; then
|
||||
dnl Maybe METIS/Lib?
|
||||
METIS_LIBDIR="-L$psblas_cv_metisdir/METIS/Lib -L$psblas_cv_metisdir/METIS/Lib"
|
||||
METIS_LIBS="$psblas_cv_metis $METIS_LIBDIR"
|
||||
LIBS="$METIS_LIBS -lm $SAVE_LIBS"
|
||||
AC_MSG_CHECKING([for METIS_PartGraphRecursive in $METIS_LIBS])
|
||||
AC_TRY_LINK_FUNC(METIS_PartGraphRecursive,
|
||||
[psblas_cv_have_metis=yes;pac_metis_lib_ok=yes; ],
|
||||
[psblas_cv_have_metis=no;pac_metis_lib_ok=no; METIS_LIBS=""])
|
||||
AC_MSG_RESULT($pac_metis_lib_ok)
|
||||
fi
|
||||
fi
|
||||
LIBS="$SAVE_LIBS";
|
||||
CPPFLAGS="$SAVE_CPPFLAGS";
|
||||
])dnl
|
||||
|
||||
|
||||
|
||||
@@ -790,6 +790,9 @@ with_blas
|
||||
with_lapack
|
||||
with_rsb
|
||||
with_metis
|
||||
with_metisdir
|
||||
with_metisincdir
|
||||
with_metislibdir
|
||||
with_amd
|
||||
with_amddir
|
||||
with_amdincdir
|
||||
@@ -1473,8 +1476,12 @@ Optional Packages:
|
||||
bin/include/lib subdirs with a regular RSB
|
||||
installation resides, or nothing to make the
|
||||
configure script invoke librsb-config)
|
||||
--with-metis=LIB Specify -lMETISLIBNAME or the absolute library
|
||||
filename.
|
||||
--with-metis=LIBNAME Specify the library name for METIS library. Default:
|
||||
"-lmetis"
|
||||
--with-metisdir=DIR Specify the directory for METIS library and
|
||||
includes.
|
||||
--with-metisincdir=DIR Specify the directory for METIS includes.
|
||||
--with-metislibdir=DIR Specify the directory for METIS library.
|
||||
--with-amd=LIBNAME Specify the library name for AMD library. Default:
|
||||
"-lamd"
|
||||
--with-amddir=DIR Specify the directory for AMD library and includes.
|
||||
@@ -9425,27 +9432,505 @@ LIBS="$RSB_LIBS ${LIBS}"
|
||||
|
||||
# Check whether --with-metis was given.
|
||||
if test "${with_metis+set}" = set; then
|
||||
withval=$with_metis; psblas_cv_metis="$withval"
|
||||
withval=$with_metis; psblas_cv_metis=$withval
|
||||
else
|
||||
psblas_cv_metis=''
|
||||
psblas_cv_metis='-lmetis'
|
||||
fi
|
||||
|
||||
|
||||
# Check whether --with-metisdir was given.
|
||||
if test "${with_metisdir+set}" = set; then
|
||||
withval=$with_metisdir; psblas_cv_metisdir=$withval
|
||||
else
|
||||
psblas_cv_metisdir=''
|
||||
fi
|
||||
|
||||
if test "x$psblas_cv_metis" != "x" ; then
|
||||
{ $as_echo "$as_me:$LINENO: checking for METIS_PartGraphRecursive in -l\"m\"" >&5
|
||||
$as_echo_n "checking for METIS_PartGraphRecursive in -l\"m\"... " >&6; }
|
||||
if test "${ac_cv_lib__m__METIS_PartGraphRecursive+set}" = set; then
|
||||
|
||||
# Check whether --with-metisincdir was given.
|
||||
if test "${with_metisincdir+set}" = set; then
|
||||
withval=$with_metisincdir; psblas_cv_metisincdir=$withval
|
||||
else
|
||||
psblas_cv_metisincdir=''
|
||||
fi
|
||||
|
||||
|
||||
# Check whether --with-metislibdir was given.
|
||||
if test "${with_metislibdir+set}" = set; then
|
||||
withval=$with_metislibdir; psblas_cv_metislibdir=$withval
|
||||
else
|
||||
psblas_cv_metislibdir=''
|
||||
fi
|
||||
|
||||
|
||||
ac_ext=c
|
||||
ac_cpp='$CPP $CPPFLAGS'
|
||||
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
|
||||
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
|
||||
ac_compiler_gnu=$ac_cv_c_compiler_gnu
|
||||
|
||||
SAVE_LIBS="$LIBS"
|
||||
SAVE_CPPFLAGS="$CPPFLAGS"
|
||||
if test "x$psblas_cv_metisdir" != "x"; then
|
||||
METIS_LIBDIR="-L$psblas_cv_metisdir"
|
||||
LIBS="-L$psblas_cv_metisdir $LIBS"
|
||||
METIS_INCLUDES="-I$psblas_cv_metisdir"
|
||||
CPPFLAGS="$METIS_INCLUDES $CPPFLAGS"
|
||||
fi
|
||||
if test "x$psblas_cv_metisincdir" != "x"; then
|
||||
METIS_INCLUDES="-I$psblas_cv_metisincdir"
|
||||
CPPFLAGS="$METIS_INCLUDES $CPPFLAGS"
|
||||
fi
|
||||
if test "x$psblas_cv_metislibdir" != "x"; then
|
||||
LIBS="-L$psblas_cv_metislibdir $LIBS"
|
||||
METIS_LIBDIR="-L$psblas_cv_metislibdir"
|
||||
fi
|
||||
|
||||
{ $as_echo "$as_me:$LINENO: metis dir $psblas_cv_metisdir" >&5
|
||||
$as_echo "$as_me: metis dir $psblas_cv_metisdir" >&6;}
|
||||
if test "${ac_cv_header_metis_h+set}" = set; then
|
||||
{ $as_echo "$as_me:$LINENO: checking for metis.h" >&5
|
||||
$as_echo_n "checking for metis.h... " >&6; }
|
||||
if test "${ac_cv_header_metis_h+set}" = set; then
|
||||
$as_echo_n "(cached) " >&6
|
||||
fi
|
||||
{ $as_echo "$as_me:$LINENO: result: $ac_cv_header_metis_h" >&5
|
||||
$as_echo "$ac_cv_header_metis_h" >&6; }
|
||||
else
|
||||
# Is the header compilable?
|
||||
{ $as_echo "$as_me:$LINENO: checking metis.h usability" >&5
|
||||
$as_echo_n "checking metis.h usability... " >&6; }
|
||||
cat >conftest.$ac_ext <<_ACEOF
|
||||
/* confdefs.h. */
|
||||
_ACEOF
|
||||
cat confdefs.h >>conftest.$ac_ext
|
||||
cat >>conftest.$ac_ext <<_ACEOF
|
||||
/* end confdefs.h. */
|
||||
$ac_includes_default
|
||||
#include <metis.h>
|
||||
_ACEOF
|
||||
rm -f conftest.$ac_objext
|
||||
if { (ac_try="$ac_compile"
|
||||
case "(($ac_try" in
|
||||
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
|
||||
*) ac_try_echo=$ac_try;;
|
||||
esac
|
||||
eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\""
|
||||
$as_echo "$ac_try_echo") >&5
|
||||
(eval "$ac_compile") 2>conftest.er1
|
||||
ac_status=$?
|
||||
grep -v '^ *+' conftest.er1 >conftest.err
|
||||
rm -f conftest.er1
|
||||
cat conftest.err >&5
|
||||
$as_echo "$as_me:$LINENO: \$? = $ac_status" >&5
|
||||
(exit $ac_status); } && {
|
||||
test -z "$ac_c_werror_flag" ||
|
||||
test ! -s conftest.err
|
||||
} && test -s conftest.$ac_objext; then
|
||||
ac_header_compiler=yes
|
||||
else
|
||||
$as_echo "$as_me: failed program was:" >&5
|
||||
sed 's/^/| /' conftest.$ac_ext >&5
|
||||
|
||||
ac_header_compiler=no
|
||||
fi
|
||||
|
||||
rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
|
||||
{ $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
|
||||
$as_echo "$ac_header_compiler" >&6; }
|
||||
|
||||
# Is the header present?
|
||||
{ $as_echo "$as_me:$LINENO: checking metis.h presence" >&5
|
||||
$as_echo_n "checking metis.h presence... " >&6; }
|
||||
cat >conftest.$ac_ext <<_ACEOF
|
||||
/* confdefs.h. */
|
||||
_ACEOF
|
||||
cat confdefs.h >>conftest.$ac_ext
|
||||
cat >>conftest.$ac_ext <<_ACEOF
|
||||
/* end confdefs.h. */
|
||||
#include <metis.h>
|
||||
_ACEOF
|
||||
if { (ac_try="$ac_cpp conftest.$ac_ext"
|
||||
case "(($ac_try" in
|
||||
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
|
||||
*) ac_try_echo=$ac_try;;
|
||||
esac
|
||||
eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\""
|
||||
$as_echo "$ac_try_echo") >&5
|
||||
(eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1
|
||||
ac_status=$?
|
||||
grep -v '^ *+' conftest.er1 >conftest.err
|
||||
rm -f conftest.er1
|
||||
cat conftest.err >&5
|
||||
$as_echo "$as_me:$LINENO: \$? = $ac_status" >&5
|
||||
(exit $ac_status); } >/dev/null && {
|
||||
test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||
|
||||
test ! -s conftest.err
|
||||
}; then
|
||||
ac_header_preproc=yes
|
||||
else
|
||||
$as_echo "$as_me: failed program was:" >&5
|
||||
sed 's/^/| /' conftest.$ac_ext >&5
|
||||
|
||||
ac_header_preproc=no
|
||||
fi
|
||||
|
||||
rm -f conftest.err conftest.$ac_ext
|
||||
{ $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
|
||||
$as_echo "$ac_header_preproc" >&6; }
|
||||
|
||||
# So? What about this header?
|
||||
case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
|
||||
yes:no: )
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: metis.h: accepted by the compiler, rejected by the preprocessor!" >&5
|
||||
$as_echo "$as_me: WARNING: metis.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: metis.h: proceeding with the compiler's result" >&5
|
||||
$as_echo "$as_me: WARNING: metis.h: proceeding with the compiler's result" >&2;}
|
||||
ac_header_preproc=yes
|
||||
;;
|
||||
no:yes:* )
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: metis.h: present but cannot be compiled" >&5
|
||||
$as_echo "$as_me: WARNING: metis.h: present but cannot be compiled" >&2;}
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: metis.h: check for missing prerequisite headers?" >&5
|
||||
$as_echo "$as_me: WARNING: metis.h: check for missing prerequisite headers?" >&2;}
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: metis.h: see the Autoconf documentation" >&5
|
||||
$as_echo "$as_me: WARNING: metis.h: see the Autoconf documentation" >&2;}
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: metis.h: section \"Present But Cannot Be Compiled\"" >&5
|
||||
$as_echo "$as_me: WARNING: metis.h: section \"Present But Cannot Be Compiled\"" >&2;}
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: metis.h: proceeding with the preprocessor's result" >&5
|
||||
$as_echo "$as_me: WARNING: metis.h: proceeding with the preprocessor's result" >&2;}
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: metis.h: in the future, the compiler will take precedence" >&5
|
||||
$as_echo "$as_me: WARNING: metis.h: in the future, the compiler will take precedence" >&2;}
|
||||
( cat <<\_ASBOX
|
||||
## ---------------------------------------------- ##
|
||||
## Report this to salvatore.filippone@uniroma2.it ##
|
||||
## ---------------------------------------------- ##
|
||||
_ASBOX
|
||||
) | sed "s/^/$as_me: WARNING: /" >&2
|
||||
;;
|
||||
esac
|
||||
{ $as_echo "$as_me:$LINENO: checking for metis.h" >&5
|
||||
$as_echo_n "checking for metis.h... " >&6; }
|
||||
if test "${ac_cv_header_metis_h+set}" = set; then
|
||||
$as_echo_n "(cached) " >&6
|
||||
else
|
||||
ac_check_lib_save_LIBS=$LIBS
|
||||
LIBS="-l"m" "$psblas_cv_metis" $LIBS"
|
||||
ac_cv_header_metis_h=$ac_header_preproc
|
||||
fi
|
||||
{ $as_echo "$as_me:$LINENO: result: $ac_cv_header_metis_h" >&5
|
||||
$as_echo "$ac_cv_header_metis_h" >&6; }
|
||||
|
||||
fi
|
||||
if test "x$ac_cv_header_metis_h" = x""yes; then
|
||||
pac_metis_header_ok=yes
|
||||
else
|
||||
pac_metis_header_ok=no; METIS_INCLUDES=""
|
||||
fi
|
||||
|
||||
|
||||
if test "x$pac_metis_header_ok" == "xno" ; then
|
||||
unset ac_cv_header_metis_h
|
||||
METIS_INCLUDES="-I$psblas_cv_metisdir/include -I$psblas_cv_metisdir/Include "
|
||||
CPPFLAGS="$METIS_INCLUDES $SAVE_CPPFLAGS"
|
||||
|
||||
{ $as_echo "$as_me:$LINENO: checking for metis_h in $METIS_INCLUDES" >&5
|
||||
$as_echo_n "checking for metis_h in $METIS_INCLUDES... " >&6; }
|
||||
if test "${ac_cv_header_metis_h+set}" = set; then
|
||||
{ $as_echo "$as_me:$LINENO: checking for metis.h" >&5
|
||||
$as_echo_n "checking for metis.h... " >&6; }
|
||||
if test "${ac_cv_header_metis_h+set}" = set; then
|
||||
$as_echo_n "(cached) " >&6
|
||||
fi
|
||||
{ $as_echo "$as_me:$LINENO: result: $ac_cv_header_metis_h" >&5
|
||||
$as_echo "$ac_cv_header_metis_h" >&6; }
|
||||
else
|
||||
# Is the header compilable?
|
||||
{ $as_echo "$as_me:$LINENO: checking metis.h usability" >&5
|
||||
$as_echo_n "checking metis.h usability... " >&6; }
|
||||
cat >conftest.$ac_ext <<_ACEOF
|
||||
/* confdefs.h. */
|
||||
_ACEOF
|
||||
cat confdefs.h >>conftest.$ac_ext
|
||||
cat >>conftest.$ac_ext <<_ACEOF
|
||||
/* end confdefs.h. */
|
||||
$ac_includes_default
|
||||
#include <metis.h>
|
||||
_ACEOF
|
||||
rm -f conftest.$ac_objext
|
||||
if { (ac_try="$ac_compile"
|
||||
case "(($ac_try" in
|
||||
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
|
||||
*) ac_try_echo=$ac_try;;
|
||||
esac
|
||||
eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\""
|
||||
$as_echo "$ac_try_echo") >&5
|
||||
(eval "$ac_compile") 2>conftest.er1
|
||||
ac_status=$?
|
||||
grep -v '^ *+' conftest.er1 >conftest.err
|
||||
rm -f conftest.er1
|
||||
cat conftest.err >&5
|
||||
$as_echo "$as_me:$LINENO: \$? = $ac_status" >&5
|
||||
(exit $ac_status); } && {
|
||||
test -z "$ac_c_werror_flag" ||
|
||||
test ! -s conftest.err
|
||||
} && test -s conftest.$ac_objext; then
|
||||
ac_header_compiler=yes
|
||||
else
|
||||
$as_echo "$as_me: failed program was:" >&5
|
||||
sed 's/^/| /' conftest.$ac_ext >&5
|
||||
|
||||
ac_header_compiler=no
|
||||
fi
|
||||
|
||||
rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
|
||||
{ $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
|
||||
$as_echo "$ac_header_compiler" >&6; }
|
||||
|
||||
# Is the header present?
|
||||
{ $as_echo "$as_me:$LINENO: checking metis.h presence" >&5
|
||||
$as_echo_n "checking metis.h presence... " >&6; }
|
||||
cat >conftest.$ac_ext <<_ACEOF
|
||||
/* confdefs.h. */
|
||||
_ACEOF
|
||||
cat confdefs.h >>conftest.$ac_ext
|
||||
cat >>conftest.$ac_ext <<_ACEOF
|
||||
/* end confdefs.h. */
|
||||
#include <metis.h>
|
||||
_ACEOF
|
||||
if { (ac_try="$ac_cpp conftest.$ac_ext"
|
||||
case "(($ac_try" in
|
||||
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
|
||||
*) ac_try_echo=$ac_try;;
|
||||
esac
|
||||
eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\""
|
||||
$as_echo "$ac_try_echo") >&5
|
||||
(eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1
|
||||
ac_status=$?
|
||||
grep -v '^ *+' conftest.er1 >conftest.err
|
||||
rm -f conftest.er1
|
||||
cat conftest.err >&5
|
||||
$as_echo "$as_me:$LINENO: \$? = $ac_status" >&5
|
||||
(exit $ac_status); } >/dev/null && {
|
||||
test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||
|
||||
test ! -s conftest.err
|
||||
}; then
|
||||
ac_header_preproc=yes
|
||||
else
|
||||
$as_echo "$as_me: failed program was:" >&5
|
||||
sed 's/^/| /' conftest.$ac_ext >&5
|
||||
|
||||
ac_header_preproc=no
|
||||
fi
|
||||
|
||||
rm -f conftest.err conftest.$ac_ext
|
||||
{ $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
|
||||
$as_echo "$ac_header_preproc" >&6; }
|
||||
|
||||
# So? What about this header?
|
||||
case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
|
||||
yes:no: )
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: metis.h: accepted by the compiler, rejected by the preprocessor!" >&5
|
||||
$as_echo "$as_me: WARNING: metis.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: metis.h: proceeding with the compiler's result" >&5
|
||||
$as_echo "$as_me: WARNING: metis.h: proceeding with the compiler's result" >&2;}
|
||||
ac_header_preproc=yes
|
||||
;;
|
||||
no:yes:* )
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: metis.h: present but cannot be compiled" >&5
|
||||
$as_echo "$as_me: WARNING: metis.h: present but cannot be compiled" >&2;}
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: metis.h: check for missing prerequisite headers?" >&5
|
||||
$as_echo "$as_me: WARNING: metis.h: check for missing prerequisite headers?" >&2;}
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: metis.h: see the Autoconf documentation" >&5
|
||||
$as_echo "$as_me: WARNING: metis.h: see the Autoconf documentation" >&2;}
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: metis.h: section \"Present But Cannot Be Compiled\"" >&5
|
||||
$as_echo "$as_me: WARNING: metis.h: section \"Present But Cannot Be Compiled\"" >&2;}
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: metis.h: proceeding with the preprocessor's result" >&5
|
||||
$as_echo "$as_me: WARNING: metis.h: proceeding with the preprocessor's result" >&2;}
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: metis.h: in the future, the compiler will take precedence" >&5
|
||||
$as_echo "$as_me: WARNING: metis.h: in the future, the compiler will take precedence" >&2;}
|
||||
( cat <<\_ASBOX
|
||||
## ---------------------------------------------- ##
|
||||
## Report this to salvatore.filippone@uniroma2.it ##
|
||||
## ---------------------------------------------- ##
|
||||
_ASBOX
|
||||
) | sed "s/^/$as_me: WARNING: /" >&2
|
||||
;;
|
||||
esac
|
||||
{ $as_echo "$as_me:$LINENO: checking for metis.h" >&5
|
||||
$as_echo_n "checking for metis.h... " >&6; }
|
||||
if test "${ac_cv_header_metis_h+set}" = set; then
|
||||
$as_echo_n "(cached) " >&6
|
||||
else
|
||||
ac_cv_header_metis_h=$ac_header_preproc
|
||||
fi
|
||||
{ $as_echo "$as_me:$LINENO: result: $ac_cv_header_metis_h" >&5
|
||||
$as_echo "$ac_cv_header_metis_h" >&6; }
|
||||
|
||||
fi
|
||||
if test "x$ac_cv_header_metis_h" = x""yes; then
|
||||
pac_metis_header_ok=yes
|
||||
else
|
||||
pac_metis_header_ok=no; METIS_INCLUDES=""
|
||||
fi
|
||||
|
||||
|
||||
fi
|
||||
if test "x$pac_metis_header_ok" == "xno" ; then
|
||||
unset ac_cv_header_metis_h
|
||||
METIS_INCLUDES="-I$psblas_cv_metisdir/UFconfig -I$psblas_cv_metisdir/METIS/Include -I$psblas_cv_metisdir/METIS/Include"
|
||||
CPPFLAGS="$METIS_INCLUDES $SAVE_CPPFLAGS"
|
||||
if test "${ac_cv_header_metis_h+set}" = set; then
|
||||
{ $as_echo "$as_me:$LINENO: checking for metis.h" >&5
|
||||
$as_echo_n "checking for metis.h... " >&6; }
|
||||
if test "${ac_cv_header_metis_h+set}" = set; then
|
||||
$as_echo_n "(cached) " >&6
|
||||
fi
|
||||
{ $as_echo "$as_me:$LINENO: result: $ac_cv_header_metis_h" >&5
|
||||
$as_echo "$ac_cv_header_metis_h" >&6; }
|
||||
else
|
||||
# Is the header compilable?
|
||||
{ $as_echo "$as_me:$LINENO: checking metis.h usability" >&5
|
||||
$as_echo_n "checking metis.h usability... " >&6; }
|
||||
cat >conftest.$ac_ext <<_ACEOF
|
||||
/* confdefs.h. */
|
||||
_ACEOF
|
||||
cat confdefs.h >>conftest.$ac_ext
|
||||
cat >>conftest.$ac_ext <<_ACEOF
|
||||
/* end confdefs.h. */
|
||||
$ac_includes_default
|
||||
#include <metis.h>
|
||||
_ACEOF
|
||||
rm -f conftest.$ac_objext
|
||||
if { (ac_try="$ac_compile"
|
||||
case "(($ac_try" in
|
||||
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
|
||||
*) ac_try_echo=$ac_try;;
|
||||
esac
|
||||
eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\""
|
||||
$as_echo "$ac_try_echo") >&5
|
||||
(eval "$ac_compile") 2>conftest.er1
|
||||
ac_status=$?
|
||||
grep -v '^ *+' conftest.er1 >conftest.err
|
||||
rm -f conftest.er1
|
||||
cat conftest.err >&5
|
||||
$as_echo "$as_me:$LINENO: \$? = $ac_status" >&5
|
||||
(exit $ac_status); } && {
|
||||
test -z "$ac_c_werror_flag" ||
|
||||
test ! -s conftest.err
|
||||
} && test -s conftest.$ac_objext; then
|
||||
ac_header_compiler=yes
|
||||
else
|
||||
$as_echo "$as_me: failed program was:" >&5
|
||||
sed 's/^/| /' conftest.$ac_ext >&5
|
||||
|
||||
ac_header_compiler=no
|
||||
fi
|
||||
|
||||
rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
|
||||
{ $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
|
||||
$as_echo "$ac_header_compiler" >&6; }
|
||||
|
||||
# Is the header present?
|
||||
{ $as_echo "$as_me:$LINENO: checking metis.h presence" >&5
|
||||
$as_echo_n "checking metis.h presence... " >&6; }
|
||||
cat >conftest.$ac_ext <<_ACEOF
|
||||
/* confdefs.h. */
|
||||
_ACEOF
|
||||
cat confdefs.h >>conftest.$ac_ext
|
||||
cat >>conftest.$ac_ext <<_ACEOF
|
||||
/* end confdefs.h. */
|
||||
#include <metis.h>
|
||||
_ACEOF
|
||||
if { (ac_try="$ac_cpp conftest.$ac_ext"
|
||||
case "(($ac_try" in
|
||||
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
|
||||
*) ac_try_echo=$ac_try;;
|
||||
esac
|
||||
eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\""
|
||||
$as_echo "$ac_try_echo") >&5
|
||||
(eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1
|
||||
ac_status=$?
|
||||
grep -v '^ *+' conftest.er1 >conftest.err
|
||||
rm -f conftest.er1
|
||||
cat conftest.err >&5
|
||||
$as_echo "$as_me:$LINENO: \$? = $ac_status" >&5
|
||||
(exit $ac_status); } >/dev/null && {
|
||||
test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||
|
||||
test ! -s conftest.err
|
||||
}; then
|
||||
ac_header_preproc=yes
|
||||
else
|
||||
$as_echo "$as_me: failed program was:" >&5
|
||||
sed 's/^/| /' conftest.$ac_ext >&5
|
||||
|
||||
ac_header_preproc=no
|
||||
fi
|
||||
|
||||
rm -f conftest.err conftest.$ac_ext
|
||||
{ $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
|
||||
$as_echo "$ac_header_preproc" >&6; }
|
||||
|
||||
# So? What about this header?
|
||||
case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
|
||||
yes:no: )
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: metis.h: accepted by the compiler, rejected by the preprocessor!" >&5
|
||||
$as_echo "$as_me: WARNING: metis.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: metis.h: proceeding with the compiler's result" >&5
|
||||
$as_echo "$as_me: WARNING: metis.h: proceeding with the compiler's result" >&2;}
|
||||
ac_header_preproc=yes
|
||||
;;
|
||||
no:yes:* )
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: metis.h: present but cannot be compiled" >&5
|
||||
$as_echo "$as_me: WARNING: metis.h: present but cannot be compiled" >&2;}
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: metis.h: check for missing prerequisite headers?" >&5
|
||||
$as_echo "$as_me: WARNING: metis.h: check for missing prerequisite headers?" >&2;}
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: metis.h: see the Autoconf documentation" >&5
|
||||
$as_echo "$as_me: WARNING: metis.h: see the Autoconf documentation" >&2;}
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: metis.h: section \"Present But Cannot Be Compiled\"" >&5
|
||||
$as_echo "$as_me: WARNING: metis.h: section \"Present But Cannot Be Compiled\"" >&2;}
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: metis.h: proceeding with the preprocessor's result" >&5
|
||||
$as_echo "$as_me: WARNING: metis.h: proceeding with the preprocessor's result" >&2;}
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: metis.h: in the future, the compiler will take precedence" >&5
|
||||
$as_echo "$as_me: WARNING: metis.h: in the future, the compiler will take precedence" >&2;}
|
||||
( cat <<\_ASBOX
|
||||
## ---------------------------------------------- ##
|
||||
## Report this to salvatore.filippone@uniroma2.it ##
|
||||
## ---------------------------------------------- ##
|
||||
_ASBOX
|
||||
) | sed "s/^/$as_me: WARNING: /" >&2
|
||||
;;
|
||||
esac
|
||||
{ $as_echo "$as_me:$LINENO: checking for metis.h" >&5
|
||||
$as_echo_n "checking for metis.h... " >&6; }
|
||||
if test "${ac_cv_header_metis_h+set}" = set; then
|
||||
$as_echo_n "(cached) " >&6
|
||||
else
|
||||
ac_cv_header_metis_h=$ac_header_preproc
|
||||
fi
|
||||
{ $as_echo "$as_me:$LINENO: result: $ac_cv_header_metis_h" >&5
|
||||
$as_echo "$ac_cv_header_metis_h" >&6; }
|
||||
|
||||
fi
|
||||
if test "x$ac_cv_header_metis_h" = x""yes; then
|
||||
pac_metis_header_ok=yes
|
||||
else
|
||||
pac_metis_header_ok=no; METIS_INCLUDES=""
|
||||
fi
|
||||
|
||||
|
||||
fi
|
||||
|
||||
|
||||
if test "x$pac_metis_header_ok" == "xyes" ; then
|
||||
psblas_cv_metis_includes="$METIS_INCLUDES"
|
||||
METIS_LIBS="$psblas_cv_metis $METIS_LIBDIR"
|
||||
LIBS="$METIS_LIBS -lm $LIBS";
|
||||
{ $as_echo "$as_me:$LINENO: checking for METIS_PartGraphRecursive in $METIS_LIBS" >&5
|
||||
$as_echo_n "checking for METIS_PartGraphRecursive in $METIS_LIBS... " >&6; }
|
||||
cat >conftest.$ac_ext <<_ACEOF
|
||||
/* confdefs.h. */
|
||||
_ACEOF
|
||||
cat confdefs.h >>conftest.$ac_ext
|
||||
cat >>conftest.$ac_ext <<_ACEOF
|
||||
/* end confdefs.h. */
|
||||
|
||||
/* Override any GCC internal prototype to avoid an error.
|
||||
Use char because int might match the return type of a GCC
|
||||
@@ -9483,38 +9968,27 @@ $as_echo "$ac_try_echo") >&5
|
||||
test "$cross_compiling" = yes ||
|
||||
$as_test_x conftest$ac_exeext
|
||||
}; then
|
||||
ac_cv_lib__m__METIS_PartGraphRecursive=yes
|
||||
psblas_cv_have_metis=yes;pac_metis_lib_ok=yes;
|
||||
else
|
||||
$as_echo "$as_me: failed program was:" >&5
|
||||
sed 's/^/| /' conftest.$ac_ext >&5
|
||||
|
||||
ac_cv_lib__m__METIS_PartGraphRecursive=no
|
||||
psblas_cv_have_metis=no;pac_metis_lib_ok=no; METIS_LIBS=""
|
||||
fi
|
||||
|
||||
rm -rf conftest.dSYM
|
||||
rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \
|
||||
conftest$ac_exeext conftest.$ac_ext
|
||||
LIBS=$ac_check_lib_save_LIBS
|
||||
fi
|
||||
{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib__m__METIS_PartGraphRecursive" >&5
|
||||
$as_echo "$ac_cv_lib__m__METIS_PartGraphRecursive" >&6; }
|
||||
if test "x$ac_cv_lib__m__METIS_PartGraphRecursive" = x""yes; then
|
||||
psblas_cv_have_metis=yes; METIS_LIBS="$psblas_cv_metis"
|
||||
else
|
||||
psblas_cv_have_metis=no
|
||||
fi
|
||||
{ $as_echo "$as_me:$LINENO: result: $pac_metis_lib_ok" >&5
|
||||
$as_echo "$pac_metis_lib_ok" >&6; }
|
||||
if test "x$pac_metis_lib_ok" == "xno" ; then
|
||||
METIS_LIBDIR="-L$psblas_cv_metisdir/Lib -L$psblas_cv_metisdir/lib"
|
||||
METIS_LIBS="$psblas_cv_metis $METIS_LIBDIR"
|
||||
LIBS="$METIS_LIBS -lm $SAVE_LIBS"
|
||||
|
||||
else
|
||||
save_LIBS="$LIBS";
|
||||
LIBS="-lm $LIBS";
|
||||
{ $as_echo "$as_me:$LINENO: checking for METIS_PartGraphRecursive in -lmetis" >&5
|
||||
$as_echo_n "checking for METIS_PartGraphRecursive in -lmetis... " >&6; }
|
||||
if test "${ac_cv_lib_metis_METIS_PartGraphRecursive+set}" = set; then
|
||||
$as_echo_n "(cached) " >&6
|
||||
else
|
||||
ac_check_lib_save_LIBS=$LIBS
|
||||
LIBS="-lmetis $LIBS"
|
||||
cat >conftest.$ac_ext <<_ACEOF
|
||||
{ $as_echo "$as_me:$LINENO: checking for METIS_PartGraphRecursive in $METIS_LIBS" >&5
|
||||
$as_echo_n "checking for METIS_PartGraphRecursive in $METIS_LIBS... " >&6; }
|
||||
cat >conftest.$ac_ext <<_ACEOF
|
||||
/* confdefs.h. */
|
||||
_ACEOF
|
||||
cat confdefs.h >>conftest.$ac_ext
|
||||
@@ -9557,31 +10031,90 @@ $as_echo "$ac_try_echo") >&5
|
||||
test "$cross_compiling" = yes ||
|
||||
$as_test_x conftest$ac_exeext
|
||||
}; then
|
||||
ac_cv_lib_metis_METIS_PartGraphRecursive=yes
|
||||
psblas_cv_have_metis=yes;pac_metis_lib_ok=yes;
|
||||
else
|
||||
$as_echo "$as_me: failed program was:" >&5
|
||||
sed 's/^/| /' conftest.$ac_ext >&5
|
||||
|
||||
ac_cv_lib_metis_METIS_PartGraphRecursive=no
|
||||
psblas_cv_have_metis=no;pac_metis_lib_ok=no; METIS_LIBS=""
|
||||
fi
|
||||
|
||||
rm -rf conftest.dSYM
|
||||
rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \
|
||||
conftest$ac_exeext conftest.$ac_ext
|
||||
LIBS=$ac_check_lib_save_LIBS
|
||||
fi
|
||||
{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_metis_METIS_PartGraphRecursive" >&5
|
||||
$as_echo "$ac_cv_lib_metis_METIS_PartGraphRecursive" >&6; }
|
||||
if test "x$ac_cv_lib_metis_METIS_PartGraphRecursive" = x""yes; then
|
||||
psblas_cv_have_metis=yes;METIS_LIBS="-lmetis"
|
||||
{ $as_echo "$as_me:$LINENO: result: $pac_metis_lib_ok" >&5
|
||||
$as_echo "$pac_metis_lib_ok" >&6; }
|
||||
fi
|
||||
if test "x$pac_metis_lib_ok" == "xno" ; then
|
||||
METIS_LIBDIR="-L$psblas_cv_metisdir/METIS/Lib -L$psblas_cv_metisdir/METIS/Lib"
|
||||
METIS_LIBS="$psblas_cv_metis $METIS_LIBDIR"
|
||||
LIBS="$METIS_LIBS -lm $SAVE_LIBS"
|
||||
{ $as_echo "$as_me:$LINENO: checking for METIS_PartGraphRecursive in $METIS_LIBS" >&5
|
||||
$as_echo_n "checking for METIS_PartGraphRecursive in $METIS_LIBS... " >&6; }
|
||||
cat >conftest.$ac_ext <<_ACEOF
|
||||
/* confdefs.h. */
|
||||
_ACEOF
|
||||
cat confdefs.h >>conftest.$ac_ext
|
||||
cat >>conftest.$ac_ext <<_ACEOF
|
||||
/* end confdefs.h. */
|
||||
|
||||
/* Override any GCC internal prototype to avoid an error.
|
||||
Use char because int might match the return type of a GCC
|
||||
builtin and then its argument prototype would still apply. */
|
||||
#ifdef __cplusplus
|
||||
extern "C"
|
||||
#endif
|
||||
char METIS_PartGraphRecursive ();
|
||||
int
|
||||
main ()
|
||||
{
|
||||
return METIS_PartGraphRecursive ();
|
||||
;
|
||||
return 0;
|
||||
}
|
||||
_ACEOF
|
||||
rm -f conftest.$ac_objext conftest$ac_exeext
|
||||
if { (ac_try="$ac_link"
|
||||
case "(($ac_try" in
|
||||
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
|
||||
*) ac_try_echo=$ac_try;;
|
||||
esac
|
||||
eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\""
|
||||
$as_echo "$ac_try_echo") >&5
|
||||
(eval "$ac_link") 2>conftest.er1
|
||||
ac_status=$?
|
||||
grep -v '^ *+' conftest.er1 >conftest.err
|
||||
rm -f conftest.er1
|
||||
cat conftest.err >&5
|
||||
$as_echo "$as_me:$LINENO: \$? = $ac_status" >&5
|
||||
(exit $ac_status); } && {
|
||||
test -z "$ac_c_werror_flag" ||
|
||||
test ! -s conftest.err
|
||||
} && test -s conftest$ac_exeext && {
|
||||
test "$cross_compiling" = yes ||
|
||||
$as_test_x conftest$ac_exeext
|
||||
}; then
|
||||
psblas_cv_have_metis=yes;pac_metis_lib_ok=yes;
|
||||
else
|
||||
psblas_cv_have_metis=no
|
||||
$as_echo "$as_me: failed program was:" >&5
|
||||
sed 's/^/| /' conftest.$ac_ext >&5
|
||||
|
||||
psblas_cv_have_metis=no;pac_metis_lib_ok=no; METIS_LIBS=""
|
||||
fi
|
||||
|
||||
LIBS="$save_LIBS";
|
||||
rm -rf conftest.dSYM
|
||||
rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \
|
||||
conftest$ac_exeext conftest.$ac_ext
|
||||
{ $as_echo "$as_me:$LINENO: result: $pac_metis_lib_ok" >&5
|
||||
$as_echo "$pac_metis_lib_ok" >&6; }
|
||||
fi
|
||||
fi
|
||||
LIBS="$SAVE_LIBS";
|
||||
CPPFLAGS="$SAVE_CPPFLAGS";
|
||||
|
||||
if test "x$psblas_cv_have_metis" == "xyes" ; then
|
||||
FDEFINES="$FDEFINES $psblas_cv_define_prepend-DHAVE_METIS"
|
||||
FDEFINES="$mld_cv_define_prepend-DHAVE_METIS $FDEFINES"
|
||||
CDEFINES="-DHAVE_METIS_ $psblas_cv_metis_includes $CDEFINES"
|
||||
fi
|
||||
|
||||
|
||||
|
||||
+4
-15
@@ -703,21 +703,10 @@ RSB_LIBS="$want_rsb_libs"
|
||||
LIBS="$RSB_LIBS ${LIBS}"
|
||||
dnl AC_CHECK_HEADERS([rsb.h], [ LIBS="${LIBS} $want_rsb_libs"], [])
|
||||
|
||||
AC_ARG_WITH(metis, AC_HELP_STRING([--with-metis=LIB], [Specify -lMETISLIBNAME or the absolute library filename.]),
|
||||
[psblas_cv_metis="$withval"],
|
||||
[psblas_cv_metis=''])
|
||||
|
||||
|
||||
if test "x$psblas_cv_metis" != "x" ; then
|
||||
AC_CHECK_LIB("m",METIS_PartGraphRecursive, psblas_cv_have_metis=yes; METIS_LIBS="$psblas_cv_metis", psblas_cv_have_metis=no,["$psblas_cv_metis"])
|
||||
else
|
||||
save_LIBS="$LIBS";
|
||||
LIBS="-lm $LIBS";
|
||||
AC_CHECK_LIB(metis,METIS_PartGraphRecursive,psblas_cv_have_metis=yes;METIS_LIBS="-lmetis", psblas_cv_have_metis=no)
|
||||
LIBS="$save_LIBS";
|
||||
fi
|
||||
if test "x$psblas_cv_have_metis" == "xyes" ; then
|
||||
FDEFINES="$FDEFINES $psblas_cv_define_prepend-DHAVE_METIS"
|
||||
PAC_CHECK_METIS
|
||||
if test "x$psblas_cv_have_metis" == "xyes" ; then
|
||||
FDEFINES="$mld_cv_define_prepend-DHAVE_METIS $FDEFINES"
|
||||
CDEFINES="-DHAVE_METIS_ $psblas_cv_metis_includes $CDEFINES"
|
||||
fi
|
||||
|
||||
PAC_CHECK_AMD
|
||||
|
||||
@@ -21,6 +21,10 @@ ppde3d: ppde3d.o
|
||||
$(F90LINK) ppde3d.o -o ppde3d $(PSBLAS_LIB) $(LDLIBS)
|
||||
/bin/mv ppde3d $(EXEDIR)
|
||||
|
||||
ppde3d_ext: ppde3d_ext.o
|
||||
$(F90LINK) ppde3d_ext.o -o ppde3d_ext $(PSBLAS_LIB) $(LDLIBS)
|
||||
/bin/mv ppde3d_ext $(EXEDIR)
|
||||
|
||||
|
||||
spde3d: spde3d.o
|
||||
$(F90LINK) spde3d.o -o spde3d $(PSBLAS_LIB) $(LDLIBS)
|
||||
@@ -37,7 +41,7 @@ spde2d: spde2d.o
|
||||
|
||||
|
||||
clean:
|
||||
/bin/rm -f ppde3d.o spde3d.o ppde2d.o spde2d.o \
|
||||
/bin/rm -f ppde3d.o spde3d.o ppde2d.o spde2d.o ppde3d_ext.o \
|
||||
$(EXEDIR)/ppde3d $(EXEDIR)/spde3d $(EXEDIR)/ppde2d $(EXEDIR)/spde2d
|
||||
verycleanlib:
|
||||
(cd ../..; make veryclean)
|
||||
|
||||
+3
-2
@@ -18,8 +18,8 @@ IMPLOBJS= psb_s_hbio_impl.o psb_d_hbio_impl.o \
|
||||
psb_c_renum_impl.o psb_z_renum_impl.o \
|
||||
psb_d_genpde_impl.o psb_s_genpde_impl.o
|
||||
MODOBJS=psb_util_mod.o $(BASEOBJS)
|
||||
COBJS=psb_amd_order.o
|
||||
OBJS=$(MODOBJS) $(IMPLOBJS) $(COBJS)
|
||||
COBJS=metis_int.o psb_amd_order.o
|
||||
OBJS=$(COBJS) $(MODOBJS) $(IMPLOBJS)# $(COBJS)
|
||||
LOCAL_MODS=$(MODOBJS:.o=$(.mod))
|
||||
LIBNAME=$(UTILLIBNAME)
|
||||
FINCLUDES=$(FMFLAG). $(FMFLAG)$(LIBDIR)
|
||||
@@ -35,6 +35,7 @@ $(HERE)/$(LIBNAME): $(OBJS)
|
||||
|
||||
$(OBJS): $(LIBDIR)/$(BASEMODNAME)$(.mod)
|
||||
psb_util_mod.o: $(BASEOBJS)
|
||||
psb_metispart_mod.o: metis_int.o
|
||||
|
||||
$(IMPLOBJS): $(BASEOBJS)
|
||||
|
||||
|
||||
@@ -0,0 +1,49 @@
|
||||
#include <stdio.h>
|
||||
#if defined(HAVE_METIS_)
|
||||
#include "metis.h"
|
||||
|
||||
/* extern int METIS_PartGraphRecursive(int *, int *, int *, int *, int *, int *, int *, int *, float *, float, int *, int *, int *); */
|
||||
|
||||
|
||||
int metis_PartGraphRecursive_C(int *n, int *ixadj, int *iadj, int *ivwg,
|
||||
int *iajw, int *nparts, float *weights,
|
||||
int *graphpart)
|
||||
{
|
||||
int res = -1;
|
||||
idx_t objval = 0;
|
||||
idx_t options[METIS_NOPTIONS];
|
||||
//printf("Inside Metis/C interface\n");
|
||||
idx_t ncon=1;
|
||||
METIS_SetDefaultOptions(options);
|
||||
options[METIS_OPTION_NUMBERING] = 1;
|
||||
//printf("n:%p ncon:%p ixadj:%p iadj:%p npart:%p weights:%p options:%p objval:%p graphpart: %p\n",n,&ncon,ixadj,iadj,nparts,NULL,options,&objval,graphpart);
|
||||
/* fprintf(stderr,"From metis_int: %f\n",weights[0]); */
|
||||
if (weights[0] == -1.0) {
|
||||
res = METIS_PartGraphRecursive((idx_t*)n,(idx_t *)&ncon,(idx_t *)ixadj,(idx_t *)iadj,
|
||||
NULL,NULL,NULL,(idx_t *)nparts,NULL,NULL,options,
|
||||
&objval,(idx_t *)graphpart);
|
||||
} else {
|
||||
/* res = METIS_PartGraphRecursive((idx_t*)n,(idx_t *)&ncon,(idx_t *)ixadj,(idx_t *)iadj, */
|
||||
/* NULL,NULL,NULL,(idx_t *)nparts,NULL,NULL,NULL, */
|
||||
/* &objval,(idx_t *)graphpart); */
|
||||
res = METIS_PartGraphRecursive((idx_t*)n,(idx_t *)&ncon,(idx_t *)ixadj,(idx_t *)iadj,
|
||||
NULL,NULL,NULL,(idx_t *)nparts,weights,NULL,options,
|
||||
&objval,(idx_t *)graphpart);
|
||||
}
|
||||
if (res == METIS_OK) {
|
||||
return(0);
|
||||
} else {
|
||||
return res;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
#else
|
||||
|
||||
int metis_PartGraphRecursive_C(int *n, int *ixadj, int *iadj, int *ivwg,
|
||||
int *iajw, int *nparts, float *weights,
|
||||
int *graphpart)
|
||||
{
|
||||
return(-1);
|
||||
}
|
||||
#endif
|
||||
+76
-44
@@ -34,7 +34,7 @@
|
||||
! the rhs.
|
||||
!
|
||||
subroutine psb_d_gen_pde3d(ictxt,idim,a,bv,xv,desc_a,afmt,&
|
||||
& a1,a2,a3,b1,b2,b3,c,g,info,f,amold,vmold,nrl)
|
||||
& a1,a2,a3,b1,b2,b3,c,g,info,f,amold,vmold,imold,nrl,iv)
|
||||
use psb_base_mod
|
||||
use psb_d_genpde_mod, psb_protect_name => psb_d_gen_pde3d
|
||||
!
|
||||
@@ -62,8 +62,9 @@ subroutine psb_d_gen_pde3d(ictxt,idim,a,bv,xv,desc_a,afmt,&
|
||||
character(len=*) :: afmt
|
||||
procedure(d_func_3d), optional :: f
|
||||
class(psb_d_base_sparse_mat), optional :: amold
|
||||
class(psb_d_base_vect_type), optional :: vmold
|
||||
integer(psb_ipk_), optional :: nrl
|
||||
class(psb_d_base_vect_type), optional :: vmold
|
||||
class(psb_i_base_vect_type), optional :: imold
|
||||
integer(psb_ipk_), optional :: nrl,iv(:)
|
||||
|
||||
! Local variables.
|
||||
|
||||
@@ -112,29 +113,44 @@ subroutine psb_d_gen_pde3d(ictxt,idim,a,bv,xv,desc_a,afmt,&
|
||||
nnz = ((n*9)/(np))
|
||||
if(iam == psb_root_) write(psb_out_unit,'("Generating Matrix (size=",i0,")...")')n
|
||||
|
||||
if (present(nrl)) then
|
||||
nr = nrl
|
||||
if (.not.present(iv)) then
|
||||
if (present(nrl)) then
|
||||
nr = nrl
|
||||
else
|
||||
!
|
||||
! Using a simple BLOCK distribution.
|
||||
!
|
||||
nt = (m+np-1)/np
|
||||
nr = max(0,min(nt,m-(iam*nt)))
|
||||
end if
|
||||
|
||||
nt = nr
|
||||
call psb_sum(ictxt,nt)
|
||||
if (nt /= m) then
|
||||
write(psb_err_unit,*) iam, 'Initialization error ',nr,nt,m
|
||||
info = -1
|
||||
call psb_barrier(ictxt)
|
||||
call psb_abort(ictxt)
|
||||
return
|
||||
end if
|
||||
else
|
||||
!
|
||||
! Using a simple BLOCK distribution.
|
||||
!
|
||||
nt = (m+np-1)/np
|
||||
nr = max(0,min(nt,m-(iam*nt)))
|
||||
if (size(iv) /= m) then
|
||||
write(psb_err_unit,*) iam, 'Initialization error IV',size(iv),m
|
||||
info = -1
|
||||
call psb_barrier(ictxt)
|
||||
call psb_abort(ictxt)
|
||||
return
|
||||
end if
|
||||
|
||||
end if
|
||||
|
||||
nt = nr
|
||||
call psb_sum(ictxt,nt)
|
||||
if (nt /= m) then
|
||||
write(psb_err_unit,*) iam, 'Initialization error ',nr,nt,m
|
||||
info = -1
|
||||
call psb_barrier(ictxt)
|
||||
call psb_abort(ictxt)
|
||||
return
|
||||
end if
|
||||
|
||||
call psb_barrier(ictxt)
|
||||
t0 = psb_wtime()
|
||||
call psb_cdall(ictxt,desc_a,info,nl=nr)
|
||||
if (present(iv)) then
|
||||
call psb_cdall(ictxt,desc_a,info,vg=iv)
|
||||
else
|
||||
call psb_cdall(ictxt,desc_a,info,nl=nr)
|
||||
end if
|
||||
|
||||
if (info == psb_success_) call psb_spall(a,desc_a,info,nnz=nnz)
|
||||
! define rhs from boundary conditions; also build initial guess
|
||||
if (info == psb_success_) call psb_geall(xv,desc_a,info)
|
||||
@@ -285,7 +301,7 @@ subroutine psb_d_gen_pde3d(ictxt,idim,a,bv,xv,desc_a,afmt,&
|
||||
|
||||
call psb_barrier(ictxt)
|
||||
t1 = psb_wtime()
|
||||
call psb_cdasb(desc_a,info)
|
||||
call psb_cdasb(desc_a,info,mold=imold)
|
||||
tcdasb = psb_wtime()-t1
|
||||
call psb_barrier(ictxt)
|
||||
t1 = psb_wtime()
|
||||
@@ -349,7 +365,7 @@ end subroutine psb_d_gen_pde3d
|
||||
! the rhs.
|
||||
!
|
||||
subroutine psb_d_gen_pde2d(ictxt,idim,a,bv,xv,desc_a,afmt,&
|
||||
& a1,a2,b1,b2,c,g,info,f,amold,vmold,nrl)
|
||||
& a1,a2,b1,b2,c,g,info,f,amold,vmold,imold,nrl,iv)
|
||||
use psb_base_mod
|
||||
use psb_d_genpde_mod, psb_protect_name => psb_d_gen_pde2d
|
||||
!
|
||||
@@ -378,7 +394,8 @@ subroutine psb_d_gen_pde2d(ictxt,idim,a,bv,xv,desc_a,afmt,&
|
||||
procedure(d_func_2d), optional :: f
|
||||
class(psb_d_base_sparse_mat), optional :: amold
|
||||
class(psb_d_base_vect_type), optional :: vmold
|
||||
integer(psb_ipk_), optional :: nrl
|
||||
class(psb_i_base_vect_type), optional :: imold
|
||||
integer(psb_ipk_), optional :: nrl, iv(:)
|
||||
|
||||
! Local variables.
|
||||
|
||||
@@ -427,28 +444,43 @@ subroutine psb_d_gen_pde2d(ictxt,idim,a,bv,xv,desc_a,afmt,&
|
||||
nnz = ((n*7)/(np))
|
||||
if(iam == psb_root_) write(psb_out_unit,'("Generating Matrix (size=",i0,")...")')n
|
||||
|
||||
if (present(nrl)) then
|
||||
nr = nrl
|
||||
if (.not.present(iv)) then
|
||||
if (present(nrl)) then
|
||||
nr = nrl
|
||||
else
|
||||
!
|
||||
! Using a simple BLOCK distribution.
|
||||
!
|
||||
nt = (m+np-1)/np
|
||||
nr = max(0,min(nt,m-(iam*nt)))
|
||||
end if
|
||||
|
||||
nt = nr
|
||||
call psb_sum(ictxt,nt)
|
||||
if (nt /= m) then
|
||||
write(psb_err_unit,*) iam, 'Initialization error ',nr,nt,m
|
||||
info = -1
|
||||
call psb_barrier(ictxt)
|
||||
call psb_abort(ictxt)
|
||||
return
|
||||
end if
|
||||
else
|
||||
!
|
||||
! Using a simple BLOCK distribution.
|
||||
!
|
||||
nt = (m+np-1)/np
|
||||
nr = max(0,min(nt,m-(iam*nt)))
|
||||
end if
|
||||
|
||||
nt = nr
|
||||
call psb_sum(ictxt,nt)
|
||||
if (nt /= m) then
|
||||
write(psb_err_unit,*) iam, 'Initialization error ',nr,nt,m
|
||||
info = -1
|
||||
call psb_barrier(ictxt)
|
||||
call psb_abort(ictxt)
|
||||
return
|
||||
if (size(iv) /= m) then
|
||||
write(psb_err_unit,*) iam, 'Initialization error IV',size(iv),m
|
||||
info = -1
|
||||
call psb_barrier(ictxt)
|
||||
call psb_abort(ictxt)
|
||||
return
|
||||
end if
|
||||
|
||||
end if
|
||||
call psb_barrier(ictxt)
|
||||
t0 = psb_wtime()
|
||||
call psb_cdall(ictxt,desc_a,info,nl=nr)
|
||||
if (present(iv)) then
|
||||
call psb_cdall(ictxt,desc_a,info,vg=iv)
|
||||
else
|
||||
call psb_cdall(ictxt,desc_a,info,nl=nr)
|
||||
end if
|
||||
if (info == psb_success_) call psb_spall(a,desc_a,info,nnz=nnz)
|
||||
! define rhs from boundary conditions; also build initial guess
|
||||
if (info == psb_success_) call psb_geall(xv,desc_a,info)
|
||||
@@ -575,7 +607,7 @@ subroutine psb_d_gen_pde2d(ictxt,idim,a,bv,xv,desc_a,afmt,&
|
||||
|
||||
call psb_barrier(ictxt)
|
||||
t1 = psb_wtime()
|
||||
call psb_cdasb(desc_a,info)
|
||||
call psb_cdasb(desc_a,info,mold=imold)
|
||||
tcdasb = psb_wtime()-t1
|
||||
call psb_barrier(ictxt)
|
||||
t1 = psb_wtime()
|
||||
|
||||
@@ -33,7 +33,7 @@ module psb_d_genpde_mod
|
||||
|
||||
use psb_base_mod, only : psb_dpk_, psb_ipk_, psb_desc_type,&
|
||||
& psb_dspmat_type, psb_d_vect_type, dzero,&
|
||||
& psb_d_base_sparse_mat, psb_d_base_vect_type
|
||||
& psb_d_base_sparse_mat, psb_d_base_vect_type, psb_i_base_vect_type
|
||||
|
||||
interface
|
||||
function d_func_3d(x,y,z) result(val)
|
||||
@@ -45,7 +45,7 @@ module psb_d_genpde_mod
|
||||
|
||||
interface psb_gen_pde3d
|
||||
subroutine psb_d_gen_pde3d(ictxt,idim,a,bv,xv,desc_a,afmt, &
|
||||
& a1,a2,a3,b1,b2,b3,c,g,info,f,amold,vmold,nrl)
|
||||
& a1,a2,a3,b1,b2,b3,c,g,info,f,amold,vmold,imold,nrl,iv)
|
||||
!
|
||||
! Discretizes the partial differential equation
|
||||
!
|
||||
@@ -62,7 +62,7 @@ module psb_d_genpde_mod
|
||||
! Note that if b1=b2=b3=c=0., the PDE is the Laplace equation.
|
||||
!
|
||||
import :: psb_ipk_, psb_desc_type, psb_dspmat_type, psb_d_vect_type,&
|
||||
& d_func_3d, psb_d_base_sparse_mat, psb_d_base_vect_type
|
||||
& d_func_3d, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_i_base_vect_type
|
||||
implicit none
|
||||
procedure(d_func_3d) :: a1,a2,a3,c,b1,b2,b3,g
|
||||
integer(psb_ipk_) :: idim
|
||||
@@ -74,7 +74,8 @@ module psb_d_genpde_mod
|
||||
procedure(d_func_3d), optional :: f
|
||||
class(psb_d_base_sparse_mat), optional :: amold
|
||||
class(psb_d_base_vect_type), optional :: vmold
|
||||
integer(psb_ipk_), optional :: nrl
|
||||
class(psb_i_base_vect_type), optional :: imold
|
||||
integer(psb_ipk_), optional :: nrl,iv(:)
|
||||
end subroutine psb_d_gen_pde3d
|
||||
end interface
|
||||
|
||||
@@ -89,7 +90,7 @@ module psb_d_genpde_mod
|
||||
|
||||
interface psb_gen_pde2d
|
||||
subroutine psb_d_gen_pde2d(ictxt,idim,a,bv,xv,desc_a,afmt,&
|
||||
& a1,a2,b1,b2,c,g,info,f,amold,vmold,nrl)
|
||||
& a1,a2,b1,b2,c,g,info,f,amold,vmold,imold,nrl,iv)
|
||||
!
|
||||
! Discretizes the partial differential equation
|
||||
!
|
||||
@@ -106,7 +107,7 @@ module psb_d_genpde_mod
|
||||
! Note that if b1=b2=c=0., the PDE is the Laplace equation.
|
||||
!
|
||||
import :: psb_ipk_, psb_desc_type, psb_dspmat_type, psb_d_vect_type,&
|
||||
& d_func_2d, psb_d_base_sparse_mat, psb_d_base_vect_type
|
||||
& d_func_2d, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_i_base_vect_type
|
||||
implicit none
|
||||
procedure(d_func_2d) :: a1,a2,c,b1,b2,g
|
||||
integer(psb_ipk_) :: idim
|
||||
@@ -118,7 +119,8 @@ module psb_d_genpde_mod
|
||||
procedure(d_func_2d), optional :: f
|
||||
class(psb_d_base_sparse_mat), optional :: amold
|
||||
class(psb_d_base_vect_type), optional :: vmold
|
||||
integer(psb_ipk_), optional :: nrl
|
||||
class(psb_i_base_vect_type), optional :: imold
|
||||
integer(psb_ipk_), optional :: nrl,iv(:)
|
||||
end subroutine psb_d_gen_pde2d
|
||||
end interface
|
||||
|
||||
|
||||
+111
-44
@@ -136,15 +136,26 @@ contains
|
||||
end if
|
||||
end subroutine getv_mtpart
|
||||
|
||||
subroutine d_mat_build_mtpart(a,nparts)
|
||||
subroutine d_mat_build_mtpart(a,nparts,weights)
|
||||
use psb_base_mod
|
||||
type(psb_dspmat_type), intent(in) :: a
|
||||
integer(psb_ipk_) :: nparts
|
||||
real(psb_dpk_), optional :: weights(:)
|
||||
real(psb_spk_), allocatable :: wgh_(:)
|
||||
|
||||
|
||||
select type (aa=>a%a)
|
||||
type is (psb_d_csr_sparse_mat)
|
||||
call build_mtpart(aa%get_nrows(),aa%get_fmt(),aa%ja,aa%irp,nparts)
|
||||
if (present(weights)) then
|
||||
if (size(weights)==nparts) then
|
||||
wgh_ = weights
|
||||
end if
|
||||
end if
|
||||
if (allocated(wgh_)) then
|
||||
call build_mtpart(aa%get_nrows(),aa%get_fmt(),aa%ja,aa%irp,nparts,wgh_)
|
||||
else
|
||||
call build_mtpart(aa%get_nrows(),aa%get_fmt(),aa%ja,aa%irp,nparts,wgh_)
|
||||
end if
|
||||
class default
|
||||
write(psb_err_unit,*) 'Sorry, right now we only take CSR input!'
|
||||
call psb_abort(ictxt)
|
||||
@@ -153,15 +164,44 @@ contains
|
||||
end subroutine d_mat_build_mtpart
|
||||
|
||||
|
||||
subroutine s_mat_build_mtpart(a,nparts)
|
||||
subroutine z_mat_build_mtpart(a,nparts,weights)
|
||||
use psb_base_mod
|
||||
type(psb_zspmat_type), intent(in) :: a
|
||||
integer(psb_ipk_) :: nparts
|
||||
real(psb_dpk_), optional :: weights(:)
|
||||
real(psb_spk_), allocatable :: wgh_(:)
|
||||
|
||||
|
||||
select type (aa=>a%a)
|
||||
type is (psb_z_csr_sparse_mat)
|
||||
if (present(weights)) then
|
||||
if (size(weights)==nparts) then
|
||||
wgh_ = weights
|
||||
end if
|
||||
end if
|
||||
if (allocated(wgh_)) then
|
||||
call build_mtpart(aa%get_nrows(),aa%get_fmt(),aa%ja,aa%irp,nparts,wgh_)
|
||||
else
|
||||
call build_mtpart(aa%get_nrows(),aa%get_fmt(),aa%ja,aa%irp,nparts,wgh_)
|
||||
end if
|
||||
class default
|
||||
write(psb_err_unit,*) 'Sorry, right now we only take CSR input!'
|
||||
call psb_abort(ictxt)
|
||||
end select
|
||||
|
||||
end subroutine z_mat_build_mtpart
|
||||
|
||||
|
||||
subroutine s_mat_build_mtpart(a,nparts,weights)
|
||||
use psb_base_mod
|
||||
type(psb_sspmat_type), intent(in) :: a
|
||||
integer(psb_ipk_) :: nparts
|
||||
real(psb_spk_), optional :: weights(:)
|
||||
|
||||
|
||||
select type (aa=>a%a)
|
||||
type is (psb_s_csr_sparse_mat)
|
||||
call build_mtpart(aa%get_nrows(),aa%get_fmt(),aa%ja,aa%irp,nparts)
|
||||
call build_mtpart(aa%get_nrows(),aa%get_fmt(),aa%ja,aa%irp,nparts,weights)
|
||||
class default
|
||||
write(psb_err_unit,*) 'Sorry, right now we only take CSR input!'
|
||||
call psb_abort(ictxt)
|
||||
@@ -170,32 +210,16 @@ contains
|
||||
end subroutine s_mat_build_mtpart
|
||||
|
||||
|
||||
subroutine z_mat_build_mtpart(a,nparts)
|
||||
use psb_base_mod
|
||||
type(psb_zspmat_type), intent(in) :: a
|
||||
integer(psb_ipk_) :: nparts
|
||||
|
||||
|
||||
select type (aa=>a%a)
|
||||
type is (psb_z_csr_sparse_mat)
|
||||
call build_mtpart(aa%get_nrows(),aa%get_fmt(),aa%ja,aa%irp,nparts)
|
||||
class default
|
||||
write(psb_err_unit,*) 'Sorry, right now we only take CSR input!'
|
||||
call psb_abort(ictxt)
|
||||
end select
|
||||
|
||||
end subroutine z_mat_build_mtpart
|
||||
|
||||
|
||||
subroutine c_mat_build_mtpart(a,nparts)
|
||||
subroutine c_mat_build_mtpart(a,nparts,weights)
|
||||
use psb_base_mod
|
||||
type(psb_cspmat_type), intent(in) :: a
|
||||
integer(psb_ipk_) :: nparts
|
||||
real(psb_spk_), optional :: weights(:)
|
||||
|
||||
|
||||
select type (aa=>a%a)
|
||||
type is (psb_c_csr_sparse_mat)
|
||||
call build_mtpart(aa%get_nrows(),aa%get_fmt(),aa%ja,aa%irp,nparts)
|
||||
call build_mtpart(aa%get_nrows(),aa%get_fmt(),aa%ja,aa%irp,nparts,weights)
|
||||
class default
|
||||
write(psb_err_unit,*) 'Sorry, right now we only take CSR input!'
|
||||
call psb_abort(ictxt)
|
||||
@@ -203,33 +227,52 @@ contains
|
||||
|
||||
end subroutine c_mat_build_mtpart
|
||||
|
||||
|
||||
subroutine build_mtpart(n,fida,ia1,ia2,nparts)
|
||||
subroutine build_mtpart(n,fida,ja,irp,nparts,weights)
|
||||
use psb_base_mod
|
||||
implicit none
|
||||
integer(psb_ipk_) :: nparts
|
||||
integer(psb_ipk_) :: ia1(:), ia2(:)
|
||||
integer(psb_ipk_) :: ja(:), irp(:)
|
||||
integer(psb_ipk_) :: n, i,numflag,nedc,wgflag
|
||||
character(len=5) :: fida
|
||||
integer(psb_ipk_), parameter :: nb=512
|
||||
real(psb_dpk_), parameter :: seed=12345.d0
|
||||
integer(psb_ipk_) :: iopt(10),idummy(2),jdummy(2)
|
||||
integer(psb_ipk_) :: iopt(10),idummy(2),jdummy(2), info
|
||||
real(psb_spk_),optional :: weights(:)
|
||||
integer(psb_ipk_) :: nl,nptl
|
||||
integer(psb_ipk_), allocatable :: irpl(:),jal(:),gvl(:)
|
||||
real(psb_spk_),allocatable :: wgh_(:)
|
||||
|
||||
#if defined(HAVE_METIS)
|
||||
interface
|
||||
subroutine METIS_PartGraphRecursive(n,ixadj,iadj,ivwg,iajw,&
|
||||
& wgflag,numflag,nparts,iopt,nedc,part)
|
||||
import :: psb_ipk_
|
||||
integer(psb_ipk_) :: n,wgflag,numflag,nparts,nedc
|
||||
integer(psb_ipk_) :: ixadj(*),iadj(*),ivwg(*),iajw(*),iopt(*),part(*)
|
||||
end subroutine METIS_PartGraphRecursive
|
||||
end interface
|
||||
|
||||
allocate(graph_vect(n),stat=info)
|
||||
|
||||
! subroutine METIS_PartGraphRecursive(n,ixadj,iadj,ivwg,iajw,&
|
||||
! & wgflag,numflag,nparts,weights,iopt,nedc,part) bind(c)
|
||||
! use iso_c_binding
|
||||
! integer(c_int) :: n,wgflag,numflag,nparts,nedc
|
||||
! integer(c_int) :: ixadj(*),iadj(*),ivwg(*),iajw(*),iopt(*),part(*)
|
||||
! real(c_float) :: weights(*)
|
||||
! !integer(psb_ipk_) :: n,wgflag,numflag,nparts,nedc
|
||||
! !integer(psb_ipk_) :: ixadj(*),iadj(*),ivwg(*),iajw(*),iopt(*),part(*)
|
||||
! end subroutine METIS_PartGraphRecursive
|
||||
|
||||
function METIS_PartGraphRecursive(n,ixadj,iadj,ivwg,iajw,&
|
||||
& nparts,weights,part) bind(c,name="metis_PartGraphRecursive_C") result(res)
|
||||
use iso_c_binding
|
||||
integer(c_int) :: res
|
||||
integer(c_int) :: n,nparts
|
||||
integer(c_int) :: ixadj(*),iadj(*),ivwg(*),iajw(*),part(*)
|
||||
real(c_float) :: weights(*)
|
||||
!integer(psb_ipk_) :: n,wgflag,numflag,nparts,nedc
|
||||
!integer(psb_ipk_) :: ixadj(*),iadj(*),ivwg(*),iajw(*),iopt(*),part(*)
|
||||
end function METIS_PartGraphRecursive
|
||||
end interface
|
||||
|
||||
call psb_realloc(n,graph_vect,info)
|
||||
if (info == psb_success_) allocate(gvl(n),wgh_(nparts),stat=info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
write(psb_err_unit,*) 'Fatal error in BUILD_MTPART: memory allocation ',&
|
||||
& ' failure.'
|
||||
return
|
||||
write(psb_err_unit,*) 'Fatal error in BUILD_MTPART: memory allocation ',&
|
||||
& ' failure.'
|
||||
return
|
||||
endif
|
||||
if (nparts > 1) then
|
||||
if (psb_toupper(fida) == 'CSR') then
|
||||
@@ -237,11 +280,35 @@ contains
|
||||
numflag = 1
|
||||
wgflag = 0
|
||||
|
||||
call METIS_PartGraphRecursive(n,ia2,ia1,idummy,jdummy,&
|
||||
& wgflag,numflag,nparts,iopt,nedc,graph_vect)
|
||||
write(*,*) 'Before allocation',nparts
|
||||
|
||||
irpl=irp
|
||||
jal = ja
|
||||
nl = n
|
||||
nptl = nparts
|
||||
wgh_ = -1.0
|
||||
if(present(weights)) then
|
||||
if (size(weights) == nptl) then
|
||||
write(*,*) 'weights present',weights
|
||||
! call METIS_PartGraphRecursive(n,irp,ja,idummy,jdummy,&
|
||||
! & wgflag,numflag,nparts,weights,iopt,nedc,graph_vect)
|
||||
info = METIS_PartGraphRecursive(nl,irpl,jal,idummy,jdummy,&
|
||||
& nptl,weights,gvl)
|
||||
|
||||
else
|
||||
write(*,*) 'weights absent',wgh_
|
||||
info = METIS_PartGraphRecursive(nl,irpl,jal,idummy,jdummy,&
|
||||
& nptl,wgh_,gvl)
|
||||
end if
|
||||
else
|
||||
write(*,*) 'weights absent',wgh_
|
||||
info = METIS_PartGraphRecursive(nl,irpl,jal,idummy,jdummy,&
|
||||
& nptl,wgh_,gvl)
|
||||
endif
|
||||
write(*,*) 'after allocation',info
|
||||
|
||||
do i=1, n
|
||||
graph_vect(i) = graph_vect(i) - 1
|
||||
graph_vect(i) = gvl(i) - 1
|
||||
enddo
|
||||
else
|
||||
write(psb_err_unit,*) 'Fatal error in BUILD_MTPART: matrix format ',&
|
||||
@@ -259,7 +326,7 @@ contains
|
||||
|
||||
return
|
||||
|
||||
end subroutine build_mtpart
|
||||
end subroutine build_mtpart
|
||||
|
||||
|
||||
subroutine free_part(info)
|
||||
|
||||
@@ -34,7 +34,7 @@
|
||||
! the rhs.
|
||||
!
|
||||
subroutine psb_s_gen_pde3d(ictxt,idim,a,bv,xv,desc_a,afmt,&
|
||||
& a1,a2,a3,b1,b2,b3,c,g,info,f,amold,vmold,nrl)
|
||||
& a1,a2,a3,b1,b2,b3,c,g,info,f,amold,vmold,imold,nrl)
|
||||
use psb_base_mod
|
||||
use psb_s_genpde_mod, psb_protect_name => psb_s_gen_pde3d
|
||||
!
|
||||
@@ -63,6 +63,7 @@ subroutine psb_s_gen_pde3d(ictxt,idim,a,bv,xv,desc_a,afmt,&
|
||||
procedure(s_func_3d), optional :: f
|
||||
class(psb_s_base_sparse_mat), optional :: amold
|
||||
class(psb_s_base_vect_type), optional :: vmold
|
||||
class(psb_i_base_vect_type), optional :: imold
|
||||
integer(psb_ipk_), optional :: nrl
|
||||
|
||||
! Local variables.
|
||||
@@ -285,7 +286,7 @@ subroutine psb_s_gen_pde3d(ictxt,idim,a,bv,xv,desc_a,afmt,&
|
||||
|
||||
call psb_barrier(ictxt)
|
||||
t1 = psb_wtime()
|
||||
call psb_cdasb(desc_a,info)
|
||||
call psb_cdasb(desc_a,info,mold=imold)
|
||||
tcdasb = psb_wtime()-t1
|
||||
call psb_barrier(ictxt)
|
||||
t1 = psb_wtime()
|
||||
@@ -349,7 +350,7 @@ end subroutine psb_s_gen_pde3d
|
||||
! the rhs.
|
||||
!
|
||||
subroutine psb_s_gen_pde2d(ictxt,idim,a,bv,xv,desc_a,afmt,&
|
||||
& a1,a2,b1,b2,c,g,info,f,amold,vmold,nrl)
|
||||
& a1,a2,b1,b2,c,g,info,f,amold,vmold,imold,nrl)
|
||||
use psb_base_mod
|
||||
use psb_s_genpde_mod, psb_protect_name => psb_s_gen_pde2d
|
||||
!
|
||||
@@ -378,6 +379,7 @@ subroutine psb_s_gen_pde2d(ictxt,idim,a,bv,xv,desc_a,afmt,&
|
||||
procedure(s_func_2d), optional :: f
|
||||
class(psb_s_base_sparse_mat), optional :: amold
|
||||
class(psb_s_base_vect_type), optional :: vmold
|
||||
class(psb_i_base_vect_type), optional :: imold
|
||||
integer(psb_ipk_), optional :: nrl
|
||||
|
||||
! Local variables.
|
||||
@@ -575,7 +577,7 @@ subroutine psb_s_gen_pde2d(ictxt,idim,a,bv,xv,desc_a,afmt,&
|
||||
|
||||
call psb_barrier(ictxt)
|
||||
t1 = psb_wtime()
|
||||
call psb_cdasb(desc_a,info)
|
||||
call psb_cdasb(desc_a,info,mold=imold)
|
||||
tcdasb = psb_wtime()-t1
|
||||
call psb_barrier(ictxt)
|
||||
t1 = psb_wtime()
|
||||
|
||||
@@ -33,7 +33,7 @@ module psb_s_genpde_mod
|
||||
|
||||
use psb_base_mod, only : psb_spk_, psb_ipk_, psb_desc_type,&
|
||||
& psb_sspmat_type, psb_s_vect_type, szero,&
|
||||
& psb_s_base_sparse_mat, psb_s_base_vect_type
|
||||
& psb_s_base_sparse_mat, psb_s_base_vect_type, psb_i_base_vect_type
|
||||
|
||||
interface
|
||||
function s_func_3d(x,y,z) result(val)
|
||||
@@ -45,7 +45,7 @@ module psb_s_genpde_mod
|
||||
|
||||
interface psb_gen_pde3d
|
||||
subroutine psb_s_gen_pde3d(ictxt,idim,a,bv,xv,desc_a,afmt,&
|
||||
& a1,a2,a3,b1,b2,b3,c,g,info,f,amold,vmold,nrl)
|
||||
& a1,a2,a3,b1,b2,b3,c,g,info,f,amold,vmold,imold,nrl)
|
||||
!
|
||||
! Discretizes the partial differential equation
|
||||
!
|
||||
@@ -62,7 +62,7 @@ module psb_s_genpde_mod
|
||||
! Note that if b1=b2=b3=c=0., the PDE is the Laplace equation.
|
||||
!
|
||||
import :: psb_ipk_, psb_desc_type, psb_sspmat_type, psb_s_vect_type, &
|
||||
& s_func_3d, psb_s_base_sparse_mat, psb_s_base_vect_type
|
||||
& s_func_3d, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_i_base_vect_type
|
||||
implicit none
|
||||
procedure(s_func_3d) :: a1,a2,a3,c,b1,b2,b3,g
|
||||
integer(psb_ipk_) :: idim
|
||||
@@ -74,6 +74,7 @@ module psb_s_genpde_mod
|
||||
procedure(s_func_3d), optional :: f
|
||||
class(psb_s_base_sparse_mat), optional :: amold
|
||||
class(psb_s_base_vect_type), optional :: vmold
|
||||
class(psb_i_base_vect_type), optional :: imold
|
||||
integer(psb_ipk_), optional :: nrl
|
||||
end subroutine psb_s_gen_pde3d
|
||||
end interface
|
||||
@@ -89,7 +90,7 @@ module psb_s_genpde_mod
|
||||
|
||||
interface psb_gen_pde2d
|
||||
subroutine psb_s_gen_pde2d(ictxt,idim,a,bv,xv,desc_a,afmt,&
|
||||
& a1,a2,b1,b2,c,g,info,f,amold,vmold,nrl)
|
||||
& a1,a2,b1,b2,c,g,info,f,amold,vmold,imold,nrl)
|
||||
!
|
||||
! Discretizes the partial differential equation
|
||||
!
|
||||
@@ -106,7 +107,7 @@ module psb_s_genpde_mod
|
||||
! Note that if b1=b2=c=0., the PDE is the Laplace equation.
|
||||
!
|
||||
import :: psb_ipk_, psb_desc_type, psb_sspmat_type, psb_s_vect_type,&
|
||||
& s_func_2d, psb_s_base_sparse_mat, psb_s_base_vect_type
|
||||
& s_func_2d, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_i_base_vect_type
|
||||
implicit none
|
||||
procedure(s_func_2d) :: a1,a2,c,b1,b2,g
|
||||
integer(psb_ipk_) :: idim
|
||||
@@ -118,6 +119,7 @@ module psb_s_genpde_mod
|
||||
procedure(s_func_2d), optional :: f
|
||||
class(psb_s_base_sparse_mat), optional :: amold
|
||||
class(psb_s_base_vect_type), optional :: vmold
|
||||
class(psb_i_base_vect_type), optional :: imold
|
||||
integer(psb_ipk_), optional :: nrl
|
||||
end subroutine psb_s_gen_pde2d
|
||||
end interface
|
||||
|
||||
Reference in New Issue
Block a user