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.
psblas-3.2.0
Salvatore Filippone 11 years ago
commit 00d3701493

@ -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_

@ -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,&

@ -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')

@ -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')

@ -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')

@ -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,&

@ -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

619
configure vendored

@ -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
# 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
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-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
ac_check_lib_save_LIBS=$LIBS
LIBS="-l"m" "$psblas_cv_metis" $LIBS"
# 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
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,90 @@ $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"
{ $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"
{ $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
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
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
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
@ -9557,31 +10094,27 @@ $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"
else
psblas_cv_have_metis=no
{ $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";
LIBS="$save_LIBS";
fi
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

@ -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)

@ -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

@ -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)))
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)
@ -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

@ -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,49 +164,62 @@ 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_sspmat_type), intent(in) :: a
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_s_csr_sparse_mat)
call build_mtpart(aa%get_nrows(),aa%get_fmt(),aa%ja,aa%irp,nparts)
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 s_mat_build_mtpart
end subroutine z_mat_build_mtpart
subroutine z_mat_build_mtpart(a,nparts)
subroutine s_mat_build_mtpart(a,nparts,weights)
use psb_base_mod
type(psb_zspmat_type), intent(in) :: a
type(psb_sspmat_type), intent(in) :: a
integer(psb_ipk_) :: nparts
real(psb_spk_), optional :: weights(:)
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)
type is (psb_s_csr_sparse_mat)
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)
end select
end subroutine z_mat_build_mtpart
end subroutine s_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

Loading…
Cancel
Save