fdurastante/amg4psblas
1
0
Fork 0
mirror of https://github.com/sfilippone/amg4psblas.git synced 2026-10-19 20:32:13 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'TF' into TestFerdous

Browse Source
This commit is contained in:
Salvatore Filippone
2021-09-24 15:23:21 -04:00
parent 52eaa06f9e 8cf193ec5b
commit c80d2d8b1d
9 changed files with 90 additions and 684 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Make.inc.in
+1 -1
View File
@@ -75,7 +75,7 @@ CDEFINES=$(AMGCDEFINES)
AMGFDEFINES=@AMGFDEFINES@ $(PSBFDEFINES)
FDEFINES=$(AMGFDEFINES)
CXXDEFINES=@AMGCXXDEFINES@
CXXDEFINES=@AMGCXXDEFINES@ $(PSBCXXDEFINES)
@COMPILERULES@
amgprec/amg_d_matchboxp_mod.f90
+26 -329
View File
@@ -68,7 +68,7 @@
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
module amg_dmatchboxp_mod
module amg_d_matchboxp_mod
use iso_c_binding
use psb_base_cbind_mod
@@ -95,33 +95,24 @@ module amg_dmatchboxp_mod
end interface MatchBoxPC
interface amg_i_aggr_assign
module procedure amg_i_daggr_assign
module procedure amg_i_d_aggr_assign
end interface amg_i_aggr_assign
interface amg_build_matching
module procedure amg_dbuild_matching
end interface amg_build_matching
interface amg_par_build_matching
module procedure amg_d_par_build_matching
end interface amg_par_build_matching
interface amg_build_ahat
module procedure amg_dbuild_ahat
end interface amg_build_ahat
interface amg_gtranspose
module procedure amg_dgtranspose
end interface amg_gtranspose
interface amg_htranspose
module procedure amg_dhtranspose
end interface amg_htranspose
interface amg_par_build_ahat
module procedure amg_d_par_build_ahat
end interface amg_par_build_ahat
interface amg_PMatchBox
module procedure amg_dPMatchBox
module procedure amg_d_PMatchBox
end interface amg_PMatchBox
logical, parameter, private :: print_statistics=.false.
contains
subroutine amg_dmatchboxp_build_prol(w,a,desc_a,ilaggr,nlaggr,prol,info,&
subroutine amg_d_matchboxp_build_prol(w,a,desc_a,ilaggr,nlaggr,prol,info,&
& symmetrize,reproducible,display_inp, display_out, print_out)
use psb_base_mod
use psb_util_mod
@@ -214,7 +205,7 @@ contains
end if
if (do_timings) call psb_toc(idx_phase1)
if (do_timings) call psb_tic(idx_bldmtc)
call amg_build_matching(w,a,desc_a,mate,info,display_inp=display_inp,symmetrize=symmetrize)
call amg_par_build_matching(w,a,desc_a,mate,info,display_inp=display_inp,symmetrize=symmetrize)
if (do_timings) call psb_toc(idx_bldmtc)
if (debug) write(0,*) iam,' buildprol from buildmatching:',&
& info
@@ -422,13 +413,11 @@ contains
nlpairs = v(3)
end block
if (print_statistics) then
if (iam == 0) then
write(0,*) 'Matching statistics: Unmatched nodes ',&
& nunmatched,' Singletons:',nlsingl,' Pairs:',nlpairs
end if
if (iam == 0) then
write(0,*) 'Matching statistics: Unmatched nodes ',&
& nunmatched,' Singletons:',nlsingl,' Pairs:',nlpairs
end if
if (display_out_) then
block
integer(psb_ipk_) :: idx
@@ -516,9 +505,9 @@ contains
write(0,*) iam,' : error from Matching: ',info
end if
end subroutine amg_dmatchboxp_build_prol
end subroutine amg_d_matchboxp_build_prol
function amg_i_daggr_assign(iam, iown, kg, idxg, wk, widx, nrmagg) &
function amg_i_d_aggr_assign(iam, iown, kg, idxg, wk, widx, nrmagg) &
& result(iproc)
!
! How to break ties? This
@@ -560,10 +549,10 @@ contains
iproc = iown
end if
end if
end function amg_i_daggr_assign
end function amg_i_d_aggr_assign
subroutine amg_dbuild_matching(w,a,desc_a,mate,info,display_inp, symmetrize)
subroutine amg_d_par_build_matching(w,a,desc_a,mate,info,display_inp, symmetrize)
use psb_base_mod
use psb_util_mod
use iso_c_binding
@@ -612,7 +601,7 @@ contains
if (iam == 0) write(0,*)' Into build_ahat:'
end if
if (do_timings) call psb_tic(idx_bldahat)
call amg_build_ahat(w,a,ahatnd,desc_a,info,symmetrize=symmetrize)
call amg_par_build_ahat(w,a,ahatnd,desc_a,info,symmetrize=symmetrize)
if (do_timings) call psb_toc(idx_bldahat)
if (info /= 0) then
write(0,*) 'Error from build_ahat ', info
@@ -767,9 +756,9 @@ contains
val(1:n) = tmp(1:n)
end subroutine fix_order
end subroutine amg_dbuild_matching
end subroutine amg_d_par_build_matching
subroutine amg_dbuild_ahat(w,a,ahat,desc_a,info,symmetrize)
subroutine amg_d_par_build_ahat(w,a,ahat,desc_a,info,symmetrize)
use psb_base_mod
implicit none
real(psb_dpk_), intent(in) :: w(:)
@@ -1005,301 +994,9 @@ contains
end block
end if
end subroutine amg_dbuild_ahat
end subroutine amg_d_par_build_ahat
subroutine amg_dgtranspose(ain,aout,desc_a,info)
use psb_base_mod
implicit none
type(psb_ldspmat_type), intent(in) :: ain
type(psb_ldspmat_type), intent(out) :: aout
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
!
! BEWARE: This routine works under the assumption
! that the same DESC_A works for both A and A^T, which
! essentially means that A has a symmetric pattern.
!
type(psb_ldspmat_type) :: atmp, ahalo, aglb
type(psb_ld_coo_sparse_mat) :: tmpcoo
type(psb_ld_csr_sparse_mat) :: tmpcsr
type(psb_ctxt_type) :: ictxt
integer(psb_ipk_) :: me, np
integer(psb_lpk_) :: i, j, k, nrow, ncol
integer(psb_lpk_), allocatable :: ilv(:)
character(len=80) :: aname
logical, parameter :: debug=.false., dump=.false., debug_sync=.false.
ictxt = desc_a%get_context()
call psb_info(ictxt,me,np)
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
if (debug_sync) then
call psb_barrier(ictxt)
if (me == 0) write(0,*) 'Start gtranspose '
end if
call ain%cscnv(tmpcsr,info)
if (debug) then
ilv = [(i,i=1,ncol)]
call desc_a%l2gip(ilv,info,owned=.false.)
write(aname,'(a,i3.3,a)') 'atmp-preh-',me,'.mtx'
call ain%print(fname=aname,head='atmp before haloTest ',iv=ilv)
end if
if (dump) then
call ain%cscnv(atmp,info)
call psb_gather(aglb,atmp,desc_a,info)
if (me==psb_root_) then
write(aname,'(a,i3.3,a)') 'aglob-prehalo.mtx'
call aglb%print(fname=aname,head='Test ')
end if
end if
!call psb_loc_to_glob(tmpcsr%ja,desc_a,info)
call atmp%mv_from(tmpcsr)
if (debug) then
write(aname,'(a,i3.3,a)') 'tmpcsr-',me,'.mtx'
call atmp%print(fname=aname,head='tmpcsr ',iv=ilv)
!call psb_set_debug_level(9999)
end if
! FIXME THIS NEEDS REWORKING
if (debug) write(0,*) me,' Gtranspose into sphalo :',atmp%get_nrows(),atmp%get_ncols()
call psb_sphalo(atmp,desc_a,ahalo,info,rowscale=.true.)
if (debug) write(0,*) me,' Gtranspose from sphalo :',ahalo%get_nrows(),ahalo%get_ncols()
if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=ahalo)
if (debug) then
write(aname,'(a,i3.3,a)') 'ahalo-',me,'.mtx'
call ahalo%print(fname=aname,head='ahalo after haloTest ',iv=ilv)
write(aname,'(a,i3.3,a)') 'atmp-h-',me,'.mtx'
call atmp%print(fname=aname,head='atmp after haloTest ',iv=ilv)
end if
if (info == psb_success_) call ahalo%free()
call atmp%cp_to(tmpcoo)
call tmpcoo%transp()
!call psb_glob_to_loc(tmpcoo%ia,desc_a,info,iact='I')
if (debug) write(0,*) 'Before cleanup:',tmpcoo%get_nzeros()
j = 0
do k=1, tmpcoo%get_nzeros()
if ((tmpcoo%ia(k) > 0).and.(tmpcoo%ja(k)>0)) then
j = j+1
tmpcoo%ia(j) = tmpcoo%ia(k)
tmpcoo%ja(j) = tmpcoo%ja(k)
tmpcoo%val(j) = tmpcoo%val(k)
end if
end do
call tmpcoo%set_nzeros(j)
if (debug) write(0,*) 'After cleanup:',tmpcoo%get_nzeros()
call ahalo%mv_from(tmpcoo)
if (dump) then
call psb_gather(aglb,ahalo,desc_a,info)
if (me==psb_root_) then
write(aname,'(a,i3.3,a)') 'atran-preclip.mtx'
call aglb%print(fname=aname,head='Test ')
end if
end if
call ahalo%csclip(aout,info,imax=nrow)
if (debug) write(0,*) 'After clip:',aout%get_nzeros()
if (debug_sync) then
call psb_barrier(ictxt)
if (me == 0) write(0,*) 'End gtranspose '
end if
!call aout%cscnv(info,type='csr')
if (dump) then
write(aname,'(a,i3.3,a)') 'atran-',me,'.mtx'
call aout%print(fname=aname,head='atrans ',iv=ilv)
call psb_gather(aglb,aout,desc_a,info)
if (me==psb_root_) then
write(aname,'(a,i3.3,a)') 'atran.mtx'
call aglb%print(fname=aname,head='Test ')
end if
end if
end subroutine amg_dgtranspose
subroutine amg_dhtranspose(ain,aout,desc_a,info)
use psb_base_mod
implicit none
type(psb_ldspmat_type), intent(in) :: ain
type(psb_ldspmat_type), intent(out) :: aout
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
!
! BEWARE: This routine works under the assumption
! that the same DESC_A works for both A and A^T, which
! essentially means that A has a symmetric pattern.
!
type(psb_ldspmat_type) :: atmp, ahalo, aglb
type(psb_ld_coo_sparse_mat) :: tmpcoo, tmpc1, tmpc2, tmpch
type(psb_ld_csr_sparse_mat) :: tmpcsr
integer(psb_ipk_) :: nz1, nz2, nzh, nz
type(psb_ctxt_type) :: ictxt
integer(psb_ipk_) :: me, np
integer(psb_lpk_) :: i, j, k, nrow, ncol, nlz
integer(psb_lpk_), allocatable :: ilv(:)
character(len=80) :: aname
logical, parameter :: debug=.false., dump=.false., debug_sync=.false.
ictxt = desc_a%get_context()
call psb_info(ictxt,me,np)
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
if (debug_sync) then
call psb_barrier(ictxt)
if (me == 0) write(0,*) 'Start htranspose '
end if
call ain%cscnv(tmpcsr,info)
if (debug) then
ilv = [(i,i=1,ncol)]
call desc_a%l2gip(ilv,info,owned=.false.)
write(aname,'(a,i3.3,a)') 'atmp-preh-',me,'.mtx'
call ain%print(fname=aname,head='atmp before haloTest ',iv=ilv)
end if
if (dump) then
call ain%cscnv(atmp,info)
call psb_gather(aglb,atmp,desc_a,info)
if (me==psb_root_) then
write(aname,'(a,i3.3,a)') 'aglob-prehalo.mtx'
call aglb%print(fname=aname,head='Test ')
end if
end if
!call psb_loc_to_glob(tmpcsr%ja,desc_a,info)
call atmp%mv_from(tmpcsr)
if (debug) then
write(aname,'(a,i3.3,a)') 'tmpcsr-',me,'.mtx'
call atmp%print(fname=aname,head='tmpcsr ',iv=ilv)
!call psb_set_debug_level(9999)
end if
! FIXME THIS NEEDS REWORKING
if (debug) write(0,*) me,' Htranspose into sphalo :',atmp%get_nrows(),atmp%get_ncols()
if (.true.) then
call psb_sphalo(atmp,desc_a,ahalo,info, outfmt='coo ')
call atmp%mv_to(tmpc1)
call ahalo%mv_to(tmpch)
nz1 = tmpc1%get_nzeros()
call psb_loc_to_glob(tmpc1%ia(1:nz1),desc_a,info,iact='I')
call psb_loc_to_glob(tmpc1%ja(1:nz1),desc_a,info,iact='I')
nzh = tmpch%get_nzeros()
call psb_loc_to_glob(tmpch%ia(1:nzh),desc_a,info,iact='I')
call psb_loc_to_glob(tmpch%ja(1:nzh),desc_a,info,iact='I')
nlz = nz1+nzh
call tmpcoo%allocate(ncol,ncol,nlz)
tmpcoo%ia(1:nz1) = tmpc1%ia(1:nz1)
tmpcoo%ja(1:nz1) = tmpc1%ja(1:nz1)
tmpcoo%val(1:nz1) = tmpc1%val(1:nz1)
tmpcoo%ia(nz1+1:nz1+nzh) = tmpch%ia(1:nzh)
tmpcoo%ja(nz1+1:nz1+nzh) = tmpch%ja(1:nzh)
tmpcoo%val(nz1+1:nz1+nzh) = tmpch%val(1:nzh)
call tmpcoo%set_nzeros(nlz)
call tmpcoo%transp()
nz = tmpcoo%get_nzeros()
call psb_glob_to_loc(tmpcoo%ia(1:nz),desc_a,info,iact='I')
call psb_glob_to_loc(tmpcoo%ja(1:nz),desc_a,info,iact='I')
if (.true.) then
call tmpcoo%clean_negidx(info)
else
j = 0
do k=1, tmpcoo%get_nzeros()
if ((tmpcoo%ia(k) > 0).and.(tmpcoo%ja(k)>0)) then
j = j+1
tmpcoo%ia(j) = tmpcoo%ia(k)
tmpcoo%ja(j) = tmpcoo%ja(k)
tmpcoo%val(j) = tmpcoo%val(k)
end if
end do
call tmpcoo%set_nzeros(j)
end if
call ahalo%mv_from(tmpcoo)
call ahalo%csclip(aout,info,imax=nrow)
else
call psb_sphalo(atmp,desc_a,ahalo,info, rowscale=.true.)
if (debug) write(0,*) me,' Htranspose from sphalo :',ahalo%get_nrows(),ahalo%get_ncols()
if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=ahalo)
if (debug) then
write(aname,'(a,i3.3,a)') 'ahalo-',me,'.mtx'
call ahalo%print(fname=aname,head='ahalo after haloTest ',iv=ilv)
write(aname,'(a,i3.3,a)') 'atmp-h-',me,'.mtx'
call atmp%print(fname=aname,head='atmp after haloTest ',iv=ilv)
end if
if (info == psb_success_) call ahalo%free()
call atmp%cp_to(tmpcoo)
call tmpcoo%transp()
if (debug) write(0,*) 'Before cleanup:',tmpcoo%get_nzeros()
if (.true.) then
call tmpcoo%clean_negidx(info)
else
j = 0
do k=1, tmpcoo%get_nzeros()
if ((tmpcoo%ia(k) > 0).and.(tmpcoo%ja(k)>0)) then
j = j+1
tmpcoo%ia(j) = tmpcoo%ia(k)
tmpcoo%ja(j) = tmpcoo%ja(k)
tmpcoo%val(j) = tmpcoo%val(k)
end if
end do
call tmpcoo%set_nzeros(j)
end if
if (debug) write(0,*) 'After cleanup:',tmpcoo%get_nzeros()
call ahalo%mv_from(tmpcoo)
if (dump) then
call psb_gather(aglb,ahalo,desc_a,info)
if (me==psb_root_) then
write(aname,'(a,i3.3,a)') 'atran-preclip.mtx'
call aglb%print(fname=aname,head='Test ')
end if
end if
call ahalo%csclip(aout,info,imax=nrow)
end if
if (debug) write(0,*) 'After clip:',aout%get_nzeros()
if (debug_sync) then
call psb_barrier(ictxt)
if (me == 0) write(0,*) 'End htranspose '
end if
!call aout%cscnv(info,type='csr')
if (dump) then
write(aname,'(a,i3.3,a)') 'atran-',me,'.mtx'
call aout%print(fname=aname,head='atrans ',iv=ilv)
call psb_gather(aglb,aout,desc_a,info)
if (me==psb_root_) then
write(aname,'(a,i3.3,a)') 'atran.mtx'
call aglb%print(fname=aname,head='Test ')
end if
end if
end subroutine amg_dhtranspose
subroutine amg_dPMatchBox(nlver,nledge,verlocptr,verlocind,edgelocweight,&
subroutine amg_d_PMatchBox(nlver,nledge,verlocptr,verlocind,edgelocweight,&
& verdistance, mate, myrank, numprocs, ictxt,&
& msgindsent,msgactualsent,msgpercent,&
& ph0_time, ph1_time, ph2_time, ph1_card, ph2_card,info,display_inp)
@@ -1434,6 +1131,6 @@ contains
end if
where(mate>=0) mate = mate + 1
end subroutine amg_dPMatchBox
end subroutine amg_d_PMatchBox
end module amg_dmatchboxp_mod
end module amg_d_matchboxp_mod
amgprec/amg_d_parmatch_aggregator_mod.F90
+1 -1
View File
@@ -118,7 +118,7 @@
module amg_d_parmatch_aggregator_mod
use amg_d_base_aggregator_mod
use amg_dmatchboxp_mod
use amg_d_matchboxp_mod
#if defined(SERIAL_MPI)
type, extends(amg_d_base_aggregator_type) :: amg_d_parmatch_aggregator_type
end type amg_d_parmatch_aggregator_type
amgprec/amg_s_matchboxp_mod.f90
+26 -329
View File
@@ -68,7 +68,7 @@
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
module amg_smatchboxp_mod
module amg_s_matchboxp_mod
use iso_c_binding
use psb_base_cbind_mod
@@ -95,33 +95,24 @@ module amg_smatchboxp_mod
end interface MatchBoxPC
interface amg_i_aggr_assign
module procedure amg_i_saggr_assign
module procedure amg_i_s_aggr_assign
end interface amg_i_aggr_assign
interface amg_build_matching
module procedure amg_sbuild_matching
end interface amg_build_matching
interface amg_par_build_matching
module procedure amg_s_par_build_matching
end interface amg_par_build_matching
interface amg_build_ahat
module procedure amg_sbuild_ahat
end interface amg_build_ahat
interface amg_gtranspose
module procedure amg_sgtranspose
end interface amg_gtranspose
interface amg_htranspose
module procedure amg_shtranspose
end interface amg_htranspose
interface amg_par_build_ahat
module procedure amg_s_par_build_ahat
end interface amg_par_build_ahat
interface amg_PMatchBox
module procedure amg_sPMatchBox
module procedure amg_s_PMatchBox
end interface amg_PMatchBox
logical, parameter, private :: print_statistics=.false.
contains
subroutine amg_smatchboxp_build_prol(w,a,desc_a,ilaggr,nlaggr,prol,info,&
subroutine amg_s_matchboxp_build_prol(w,a,desc_a,ilaggr,nlaggr,prol,info,&
& symmetrize,reproducible,display_inp, display_out, print_out)
use psb_base_mod
use psb_util_mod
@@ -214,7 +205,7 @@ contains
end if
if (do_timings) call psb_toc(idx_phase1)
if (do_timings) call psb_tic(idx_bldmtc)
call amg_build_matching(w,a,desc_a,mate,info,display_inp=display_inp,symmetrize=symmetrize)
call amg_par_build_matching(w,a,desc_a,mate,info,display_inp=display_inp,symmetrize=symmetrize)
if (do_timings) call psb_toc(idx_bldmtc)
if (debug) write(0,*) iam,' buildprol from buildmatching:',&
& info
@@ -422,13 +413,11 @@ contains
nlpairs = v(3)
end block
if (print_statistics) then
if (iam == 0) then
write(0,*) 'Matching statistics: Unmatched nodes ',&
& nunmatched,' Singletons:',nlsingl,' Pairs:',nlpairs
end if
if (iam == 0) then
write(0,*) 'Matching statistics: Unmatched nodes ',&
& nunmatched,' Singletons:',nlsingl,' Pairs:',nlpairs
end if
if (display_out_) then
block
integer(psb_ipk_) :: idx
@@ -516,9 +505,9 @@ contains
write(0,*) iam,' : error from Matching: ',info
end if
end subroutine amg_smatchboxp_build_prol
end subroutine amg_s_matchboxp_build_prol
function amg_i_saggr_assign(iam, iown, kg, idxg, wk, widx, nrmagg) &
function amg_i_s_aggr_assign(iam, iown, kg, idxg, wk, widx, nrmagg) &
& result(iproc)
!
! How to break ties? This
@@ -560,10 +549,10 @@ contains
iproc = iown
end if
end if
end function amg_i_saggr_assign
end function amg_i_s_aggr_assign
subroutine amg_sbuild_matching(w,a,desc_a,mate,info,display_inp, symmetrize)
subroutine amg_s_par_build_matching(w,a,desc_a,mate,info,display_inp, symmetrize)
use psb_base_mod
use psb_util_mod
use iso_c_binding
@@ -612,7 +601,7 @@ contains
if (iam == 0) write(0,*)' Into build_ahat:'
end if
if (do_timings) call psb_tic(idx_bldahat)
call amg_build_ahat(w,a,ahatnd,desc_a,info,symmetrize=symmetrize)
call amg_par_build_ahat(w,a,ahatnd,desc_a,info,symmetrize=symmetrize)
if (do_timings) call psb_toc(idx_bldahat)
if (info /= 0) then
write(0,*) 'Error from build_ahat ', info
@@ -767,9 +756,9 @@ contains
val(1:n) = tmp(1:n)
end subroutine fix_order
end subroutine amg_sbuild_matching
end subroutine amg_s_par_build_matching
subroutine amg_sbuild_ahat(w,a,ahat,desc_a,info,symmetrize)
subroutine amg_s_par_build_ahat(w,a,ahat,desc_a,info,symmetrize)
use psb_base_mod
implicit none
real(psb_spk_), intent(in) :: w(:)
@@ -1005,301 +994,9 @@ contains
end block
end if
end subroutine amg_sbuild_ahat
end subroutine amg_s_par_build_ahat
subroutine amg_sgtranspose(ain,aout,desc_a,info)
use psb_base_mod
implicit none
type(psb_lsspmat_type), intent(in) :: ain
type(psb_lsspmat_type), intent(out) :: aout
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
!
! BEWARE: This routine works under the assumption
! that the same DESC_A works for both A and A^T, which
! essentially means that A has a symmetric pattern.
!
type(psb_lsspmat_type) :: atmp, ahalo, aglb
type(psb_ls_coo_sparse_mat) :: tmpcoo
type(psb_ls_csr_sparse_mat) :: tmpcsr
type(psb_ctxt_type) :: ictxt
integer(psb_ipk_) :: me, np
integer(psb_lpk_) :: i, j, k, nrow, ncol
integer(psb_lpk_), allocatable :: ilv(:)
character(len=80) :: aname
logical, parameter :: debug=.false., dump=.false., debug_sync=.false.
ictxt = desc_a%get_context()
call psb_info(ictxt,me,np)
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
if (debug_sync) then
call psb_barrier(ictxt)
if (me == 0) write(0,*) 'Start gtranspose '
end if
call ain%cscnv(tmpcsr,info)
if (debug) then
ilv = [(i,i=1,ncol)]
call desc_a%l2gip(ilv,info,owned=.false.)
write(aname,'(a,i3.3,a)') 'atmp-preh-',me,'.mtx'
call ain%print(fname=aname,head='atmp before haloTest ',iv=ilv)
end if
if (dump) then
call ain%cscnv(atmp,info)
call psb_gather(aglb,atmp,desc_a,info)
if (me==psb_root_) then
write(aname,'(a,i3.3,a)') 'aglob-prehalo.mtx'
call aglb%print(fname=aname,head='Test ')
end if
end if
!call psb_loc_to_glob(tmpcsr%ja,desc_a,info)
call atmp%mv_from(tmpcsr)
if (debug) then
write(aname,'(a,i3.3,a)') 'tmpcsr-',me,'.mtx'
call atmp%print(fname=aname,head='tmpcsr ',iv=ilv)
!call psb_set_debug_level(9999)
end if
! FIXME THIS NEEDS REWORKING
if (debug) write(0,*) me,' Gtranspose into sphalo :',atmp%get_nrows(),atmp%get_ncols()
call psb_sphalo(atmp,desc_a,ahalo,info,rowscale=.true.)
if (debug) write(0,*) me,' Gtranspose from sphalo :',ahalo%get_nrows(),ahalo%get_ncols()
if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=ahalo)
if (debug) then
write(aname,'(a,i3.3,a)') 'ahalo-',me,'.mtx'
call ahalo%print(fname=aname,head='ahalo after haloTest ',iv=ilv)
write(aname,'(a,i3.3,a)') 'atmp-h-',me,'.mtx'
call atmp%print(fname=aname,head='atmp after haloTest ',iv=ilv)
end if
if (info == psb_success_) call ahalo%free()
call atmp%cp_to(tmpcoo)
call tmpcoo%transp()
!call psb_glob_to_loc(tmpcoo%ia,desc_a,info,iact='I')
if (debug) write(0,*) 'Before cleanup:',tmpcoo%get_nzeros()
j = 0
do k=1, tmpcoo%get_nzeros()
if ((tmpcoo%ia(k) > 0).and.(tmpcoo%ja(k)>0)) then
j = j+1
tmpcoo%ia(j) = tmpcoo%ia(k)
tmpcoo%ja(j) = tmpcoo%ja(k)
tmpcoo%val(j) = tmpcoo%val(k)
end if
end do
call tmpcoo%set_nzeros(j)
if (debug) write(0,*) 'After cleanup:',tmpcoo%get_nzeros()
call ahalo%mv_from(tmpcoo)
if (dump) then
call psb_gather(aglb,ahalo,desc_a,info)
if (me==psb_root_) then
write(aname,'(a,i3.3,a)') 'atran-preclip.mtx'
call aglb%print(fname=aname,head='Test ')
end if
end if
call ahalo%csclip(aout,info,imax=nrow)
if (debug) write(0,*) 'After clip:',aout%get_nzeros()
if (debug_sync) then
call psb_barrier(ictxt)
if (me == 0) write(0,*) 'End gtranspose '
end if
!call aout%cscnv(info,type='csr')
if (dump) then
write(aname,'(a,i3.3,a)') 'atran-',me,'.mtx'
call aout%print(fname=aname,head='atrans ',iv=ilv)
call psb_gather(aglb,aout,desc_a,info)
if (me==psb_root_) then
write(aname,'(a,i3.3,a)') 'atran.mtx'
call aglb%print(fname=aname,head='Test ')
end if
end if
end subroutine amg_sgtranspose
subroutine amg_shtranspose(ain,aout,desc_a,info)
use psb_base_mod
implicit none
type(psb_lsspmat_type), intent(in) :: ain
type(psb_lsspmat_type), intent(out) :: aout
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
!
! BEWARE: This routine works under the assumption
! that the same DESC_A works for both A and A^T, which
! essentially means that A has a symmetric pattern.
!
type(psb_lsspmat_type) :: atmp, ahalo, aglb
type(psb_ls_coo_sparse_mat) :: tmpcoo, tmpc1, tmpc2, tmpch
type(psb_ls_csr_sparse_mat) :: tmpcsr
integer(psb_ipk_) :: nz1, nz2, nzh, nz
type(psb_ctxt_type) :: ictxt
integer(psb_ipk_) :: me, np
integer(psb_lpk_) :: i, j, k, nrow, ncol, nlz
integer(psb_lpk_), allocatable :: ilv(:)
character(len=80) :: aname
logical, parameter :: debug=.false., dump=.false., debug_sync=.false.
ictxt = desc_a%get_context()
call psb_info(ictxt,me,np)
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
if (debug_sync) then
call psb_barrier(ictxt)
if (me == 0) write(0,*) 'Start htranspose '
end if
call ain%cscnv(tmpcsr,info)
if (debug) then
ilv = [(i,i=1,ncol)]
call desc_a%l2gip(ilv,info,owned=.false.)
write(aname,'(a,i3.3,a)') 'atmp-preh-',me,'.mtx'
call ain%print(fname=aname,head='atmp before haloTest ',iv=ilv)
end if
if (dump) then
call ain%cscnv(atmp,info)
call psb_gather(aglb,atmp,desc_a,info)
if (me==psb_root_) then
write(aname,'(a,i3.3,a)') 'aglob-prehalo.mtx'
call aglb%print(fname=aname,head='Test ')
end if
end if
!call psb_loc_to_glob(tmpcsr%ja,desc_a,info)
call atmp%mv_from(tmpcsr)
if (debug) then
write(aname,'(a,i3.3,a)') 'tmpcsr-',me,'.mtx'
call atmp%print(fname=aname,head='tmpcsr ',iv=ilv)
!call psb_set_debug_level(9999)
end if
! FIXME THIS NEEDS REWORKING
if (debug) write(0,*) me,' Htranspose into sphalo :',atmp%get_nrows(),atmp%get_ncols()
if (.true.) then
call psb_sphalo(atmp,desc_a,ahalo,info, outfmt='coo ')
call atmp%mv_to(tmpc1)
call ahalo%mv_to(tmpch)
nz1 = tmpc1%get_nzeros()
call psb_loc_to_glob(tmpc1%ia(1:nz1),desc_a,info,iact='I')
call psb_loc_to_glob(tmpc1%ja(1:nz1),desc_a,info,iact='I')
nzh = tmpch%get_nzeros()
call psb_loc_to_glob(tmpch%ia(1:nzh),desc_a,info,iact='I')
call psb_loc_to_glob(tmpch%ja(1:nzh),desc_a,info,iact='I')
nlz = nz1+nzh
call tmpcoo%allocate(ncol,ncol,nlz)
tmpcoo%ia(1:nz1) = tmpc1%ia(1:nz1)
tmpcoo%ja(1:nz1) = tmpc1%ja(1:nz1)
tmpcoo%val(1:nz1) = tmpc1%val(1:nz1)
tmpcoo%ia(nz1+1:nz1+nzh) = tmpch%ia(1:nzh)
tmpcoo%ja(nz1+1:nz1+nzh) = tmpch%ja(1:nzh)
tmpcoo%val(nz1+1:nz1+nzh) = tmpch%val(1:nzh)
call tmpcoo%set_nzeros(nlz)
call tmpcoo%transp()
nz = tmpcoo%get_nzeros()
call psb_glob_to_loc(tmpcoo%ia(1:nz),desc_a,info,iact='I')
call psb_glob_to_loc(tmpcoo%ja(1:nz),desc_a,info,iact='I')
if (.true.) then
call tmpcoo%clean_negidx(info)
else
j = 0
do k=1, tmpcoo%get_nzeros()
if ((tmpcoo%ia(k) > 0).and.(tmpcoo%ja(k)>0)) then
j = j+1
tmpcoo%ia(j) = tmpcoo%ia(k)
tmpcoo%ja(j) = tmpcoo%ja(k)
tmpcoo%val(j) = tmpcoo%val(k)
end if
end do
call tmpcoo%set_nzeros(j)
end if
call ahalo%mv_from(tmpcoo)
call ahalo%csclip(aout,info,imax=nrow)
else
call psb_sphalo(atmp,desc_a,ahalo,info, rowscale=.true.)
if (debug) write(0,*) me,' Htranspose from sphalo :',ahalo%get_nrows(),ahalo%get_ncols()
if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=ahalo)
if (debug) then
write(aname,'(a,i3.3,a)') 'ahalo-',me,'.mtx'
call ahalo%print(fname=aname,head='ahalo after haloTest ',iv=ilv)
write(aname,'(a,i3.3,a)') 'atmp-h-',me,'.mtx'
call atmp%print(fname=aname,head='atmp after haloTest ',iv=ilv)
end if
if (info == psb_success_) call ahalo%free()
call atmp%cp_to(tmpcoo)
call tmpcoo%transp()
if (debug) write(0,*) 'Before cleanup:',tmpcoo%get_nzeros()
if (.true.) then
call tmpcoo%clean_negidx(info)
else
j = 0
do k=1, tmpcoo%get_nzeros()
if ((tmpcoo%ia(k) > 0).and.(tmpcoo%ja(k)>0)) then
j = j+1
tmpcoo%ia(j) = tmpcoo%ia(k)
tmpcoo%ja(j) = tmpcoo%ja(k)
tmpcoo%val(j) = tmpcoo%val(k)
end if
end do
call tmpcoo%set_nzeros(j)
end if
if (debug) write(0,*) 'After cleanup:',tmpcoo%get_nzeros()
call ahalo%mv_from(tmpcoo)
if (dump) then
call psb_gather(aglb,ahalo,desc_a,info)
if (me==psb_root_) then
write(aname,'(a,i3.3,a)') 'atran-preclip.mtx'
call aglb%print(fname=aname,head='Test ')
end if
end if
call ahalo%csclip(aout,info,imax=nrow)
end if
if (debug) write(0,*) 'After clip:',aout%get_nzeros()
if (debug_sync) then
call psb_barrier(ictxt)
if (me == 0) write(0,*) 'End htranspose '
end if
!call aout%cscnv(info,type='csr')
if (dump) then
write(aname,'(a,i3.3,a)') 'atran-',me,'.mtx'
call aout%print(fname=aname,head='atrans ',iv=ilv)
call psb_gather(aglb,aout,desc_a,info)
if (me==psb_root_) then
write(aname,'(a,i3.3,a)') 'atran.mtx'
call aglb%print(fname=aname,head='Test ')
end if
end if
end subroutine amg_shtranspose
subroutine amg_sPMatchBox(nlver,nledge,verlocptr,verlocind,edgelocweight,&
subroutine amg_s_PMatchBox(nlver,nledge,verlocptr,verlocind,edgelocweight,&
& verdistance, mate, myrank, numprocs, ictxt,&
& msgindsent,msgactualsent,msgpercent,&
& ph0_time, ph1_time, ph2_time, ph1_card, ph2_card,info,display_inp)
@@ -1434,6 +1131,6 @@ contains
end if
where(mate>=0) mate = mate + 1
end subroutine amg_sPMatchBox
end subroutine amg_s_PMatchBox
end module amg_smatchboxp_mod
end module amg_s_matchboxp_mod
amgprec/amg_s_parmatch_aggregator_mod.F90
+1 -1
View File
@@ -118,7 +118,7 @@
module amg_s_parmatch_aggregator_mod
use amg_s_base_aggregator_mod
use amg_smatchboxp_mod
use amg_s_matchboxp_mod
#if defined(SERIAL_MPI)
type, extends(amg_s_base_aggregator_type) :: amg_s_parmatch_aggregator_type
end type amg_s_parmatch_aggregator_type
amgprec/impl/aggregator/Makefile
+3 -12
View File
@@ -5,7 +5,7 @@ MODDIR=../../../modules
HERE=../..
FINCLUDES=$(FMFLAG)$(HERE) $(FMFLAG)$(MODDIR) $(FMFLAG)$(INCDIR) $(PSBLAS_INCLUDES)
CXXINCLUDES=$(FMFLAG)$(HERE) $(FMFLAG)$(INCDIR) $(FMFLAG)/.
CXXINCLUDES=$(FIFLAG)$(HERE) $(FIFLAG)$(INCDIR) $(FIFLAG)/. -I../../../../../ParallelRomaF-main/include -I$(PSBLAS_INCDIR)
#CINCLUDES= -I${SUPERLU_INCDIR} -I${HSL_INCDIR} -I${SPRAL_INCDIR} -I/home/users/pasqua/Ambra/BootCMatch/include -lBCM -L/home/users/pasqua/Ambra/BootCMatch/lib -lm
@@ -68,15 +68,11 @@ amg_d_newmatch_map_to_tprol.o \
amg_d_newmatch_spmm_bld_inner.o \
amg_d_newmatch_spmm_bld_ov.o
MPCOBJS=
#MatchBoxPC.o \
#algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC.o
MPCXXOBJS=MatchBoxPC.o \
algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC.o \
newmatch_interface.o
CXXDEFINES=$(PSBCXXDEFINES)
CXXINCLUDES=-I../../../../ParallelRomaF-main/include -I$(PSBLAS_INCDIR)
OBJS = $(FOBJS) $(MPCOBJS) $(MPCXXOBJS)
OBJS = $(FOBJS) $(MPCOBJS) $(MPCXXOBJS)
LIBNAME=libamg_prec.a
@@ -84,11 +80,6 @@ lib: $(OBJS)
$(AR) $(HERE)/$(LIBNAME) $(OBJS)
$(RANLIB) $(HERE)/$(LIBNAME)
mpobjs:
(make $(MPFOBJS) F90="$(MPF90)" F90COPT="$(F90COPT)")
(make $(MPCOBJS) CC="$(MPCC)" CCOPT="$(CCOPT)")
(make $(MPCXXOBJS) CXX="$(MPCXX)" CXXOPT="$(CCOPT) $(CXXOPT)")
veryclean: clean
/bin/rm -f $(LIBNAME)
amgprec/impl/aggregator/amg_d_parmatch_aggregator_tprol.F90
+2 -2
View File
@@ -48,7 +48,7 @@ subroutine amg_d_parmatch_aggregator_build_tprol(ag,parms,ag_data,&
use amg_base_prec_type
use amg_d_inner_mod
#if defined(SERIAL_MPI)
use amg_d_parmatch_aggregator_mod
use amg_d_parmatch_aggregator_mod
#else
use amg_d_parmatch_aggregator_mod, amg_protect_name => amg_d_parmatch_aggregator_build_tprol
#endif
@@ -264,7 +264,7 @@ subroutine amg_d_parmatch_aggregator_build_tprol(ag,parms,ag_data,&
!
if (debug) write(0,*) me,' Into matchbox_build_prol ',info
if (do_timings) call psb_tic(idx_mboxp)
call amg_dmatchboxp_build_prol(tmpw,acv(i-1),desc_acv(i-1),ixaggr,nxaggr,tmp_prol,info,&
call amg_d_matchboxp_build_prol(tmpw,acv(i-1),desc_acv(i-1),ixaggr,nxaggr,tmp_prol,info,&
& symmetrize=ag%need_symmetrize,reproducible=ag%reproducible_matching)
if (do_timings) call psb_toc(idx_mboxp)
if (debug) write(0,*) me,' Out from matchbox_build_prol ',info
amgprec/impl/aggregator/amg_s_parmatch_aggregator_tprol.F90
+2 -2
View File
@@ -48,7 +48,7 @@ subroutine amg_s_parmatch_aggregator_build_tprol(ag,parms,ag_data,&
use amg_base_prec_type
use amg_s_inner_mod
#if defined(SERIAL_MPI)
use amg_s_parmatch_aggregator_mod
use amg_s_parmatch_aggregator_mod
#else
use amg_s_parmatch_aggregator_mod, amg_protect_name => amg_s_parmatch_aggregator_build_tprol
#endif
@@ -264,7 +264,7 @@ subroutine amg_s_parmatch_aggregator_build_tprol(ag,parms,ag_data,&
!
if (debug) write(0,*) me,' Into matchbox_build_prol ',info
if (do_timings) call psb_tic(idx_mboxp)
call amg_smatchboxp_build_prol(tmpw,acv(i-1),desc_acv(i-1),ixaggr,nxaggr,tmp_prol,info,&
call amg_s_matchboxp_build_prol(tmpw,acv(i-1),desc_acv(i-1),ixaggr,nxaggr,tmp_prol,info,&
& symmetrize=ag%need_symmetrize,reproducible=ag%reproducible_matching)
if (do_timings) call psb_toc(idx_mboxp)
if (debug) write(0,*) me,' Out from matchbox_build_prol ',info
amgprec/impl/aggregator/newmatch_interface.cpp
+28 -7
View File
@@ -1,5 +1,6 @@
#include <string.h>
#include <stdio.h>
#include <stdlib.h>
#include "psb_base_cbind.h"
#include "MatchingAlgorithms.h"
@@ -7,7 +8,8 @@
extern "C" {
#endif
psb_i_t dnew_Match_If(psb_i_t nr, psb_i_t irp[], psb_i_t ja[],
psb_i_t dnew_Match_If(psb_i_t ipar, psb_i_t matching, psb_d_t lambda,
psb_i_t nr, psb_i_t irp[], psb_i_t ja[],
psb_d_t val[], psb_d_t diag[],
psb_d_t w[], psb_i_t mate[]);
@@ -15,7 +17,8 @@ psb_i_t dnew_Match_If(psb_i_t nr, psb_i_t irp[], psb_i_t ja[],
}
#endif
psb_i_t dnew_Match_If(psb_i_t nr, psb_i_t irp[], psb_i_t ja[],
psb_i_t dnew_Match_If(psb_i_t ipar, psb_i_t matching, psb_d_t lambda,
psb_i_t nr, psb_i_t irp[], psb_i_t ja[],
psb_d_t val[], psb_d_t diag[], psb_d_t w[],
psb_i_t mate[])
{
@@ -31,16 +34,26 @@ psb_i_t dnew_Match_If(psb_i_t nr, psb_i_t irp[], psb_i_t ja[],
vector<NODE_T> mateNode;
NODE_T u,v;
VAL_T weight;
psb_i_t preprocess = 0; // 0 no greedy 1 greedy
psb_i_t romaInput = 1; // 1 sequential 2 parallel
VAL_T lambda = 0.8; // positive real value
psb_i_t preprocess = matching; // 0 no greedy 1 greedy
psb_i_t romaInput = ipar; // 1 sequential 2 parallel
// VAL_T lambda = 2; // positive real value
psb_d_t aii, ajj, aij, wii, wjj, tmp1, tmp2, minabs, edgnrm;
psb_i_t nt=1; // number of threads, got with 1 for testing purposes.
psb_i_t nt; // number of threads, got with 1 for testing purposes.
psb_d_t timeDiff;
MatchStat pstat;
double eps=1e-16;
double minweight,maxweight;
char *numthreadsenv;
numthreadsenv=getenv("OMP_NUM_THREADS");
if (numthreadsenv) {
sscanf(numthreadsenv,"%d",&nt);
} else {
nt = 1;
}
maxweight = eps;
minweight = 1e300;
// fprintf(stderr,"Sanity check: %d %d \n",nr,nc);
for (i=1; i<nr; i++) {
for (j=irp[i-1]; j<irp[i]; j++) {
@@ -62,10 +75,18 @@ psb_i_t dnew_Match_If(psb_i_t nr, psb_i_t irp[], psb_i_t ja[],
//
s.push_back(u);
t.push_back(v);
weights.push_back(weight);
weights.push_back(weight);
if (weight>maxweight) maxweight=weight;
if (weight<minweight) minweight=weight;
}
}
}
if (lambda<0.0) lambda=maxweight-2.0*minweight+eps;
if (lambda<0.0) lambda=eps;
fprintf(stderr,"Calling matching: pre %d nt %d lambda %g %g %g\n",
preprocess,nt,lambda,maxweight,minweight);
runRomaWrapper(s,t,weights, nr, mateNode,preprocess,romaInput,lambda ,nt, pstat, timeDiff);
/* loop here only makes sense when nr==nz */
for (i=0; i< nr; i++) {