fdurastante/amg4psblas
1
0
Fork 0
mirror of https://github.com/sfilippone/amg4psblas.git synced 2026-10-06 14:44:55 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'master' into maint-1.0

Browse Source
This commit is contained in:
Salvatore Filippone
2022-04-16 17:30:00 +02:00
parent 51a9d16975 e02df3725e
commit bbed340405
103 changed files with 3614 additions and 2579 deletions
Download Patch File Download Diff File Expand all files Collapse all files
amgprec/amg_base_prec_type.F90
+2 -2
View File
@@ -81,10 +81,10 @@ module amg_base_prec_type
!
! Version numbers
!
character(len=*), parameter :: amg_version_string_ = "1.0.0"
character(len=*), parameter :: amg_version_string_ = "1.0.1"
integer(psb_ipk_), parameter :: amg_version_major_ = 1
integer(psb_ipk_), parameter :: amg_version_minor_ = 0
integer(psb_ipk_), parameter :: amg_patchlevel_ = 0
integer(psb_ipk_), parameter :: amg_patchlevel_ = 1
type amg_ml_parms
integer(psb_ipk_) :: sweeps_pre, sweeps_post
amgprec/amg_c_base_aggregator_mod.f90
+2 -2
View File
@@ -126,7 +126,7 @@ module amg_c_base_aggregator_mod
& psb_c_coo_sparse_mat, amg_sml_parms, psb_spk_, psb_ipk_, psb_lpk_
implicit none
type(psb_c_csr_sparse_mat), intent(inout) :: a_csr
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: nlaggr(:)
type(amg_sml_parms), intent(inout) :: parms
type(psb_c_coo_sparse_mat), intent(inout) :: coo_prol, coo_restr
@@ -144,7 +144,7 @@ module amg_c_base_aggregator_mod
& psb_c_coo_sparse_mat, amg_sml_parms, psb_spk_, psb_ipk_, psb_lpk_
implicit none
type(psb_c_csr_sparse_mat), intent(inout) :: a_csr
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: nlaggr(:)
type(amg_sml_parms), intent(inout) :: parms
type(psb_c_coo_sparse_mat), intent(inout) :: coo_prol, coo_restr
amgprec/amg_d_base_aggregator_mod.f90
+2 -2
View File
@@ -126,7 +126,7 @@ module amg_d_base_aggregator_mod
& psb_d_coo_sparse_mat, amg_dml_parms, psb_dpk_, psb_ipk_, psb_lpk_
implicit none
type(psb_d_csr_sparse_mat), intent(inout) :: a_csr
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: nlaggr(:)
type(amg_dml_parms), intent(inout) :: parms
type(psb_d_coo_sparse_mat), intent(inout) :: coo_prol, coo_restr
@@ -144,7 +144,7 @@ module amg_d_base_aggregator_mod
& psb_d_coo_sparse_mat, amg_dml_parms, psb_dpk_, psb_ipk_, psb_lpk_
implicit none
type(psb_d_csr_sparse_mat), intent(inout) :: a_csr
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: nlaggr(:)
type(amg_dml_parms), intent(inout) :: parms
type(psb_d_coo_sparse_mat), intent(inout) :: coo_prol, coo_restr
amgprec/amg_d_matchboxp_mod.f90
+31 -334
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 dmatchboxp_mod
module amg_d_matchboxp_mod
use iso_c_binding
use psb_base_cbind_mod
@@ -94,34 +94,25 @@ module dmatchboxp_mod
end subroutine dMatchBoxPC
end interface MatchBoxPC
interface i_aggr_assign
module procedure i_daggr_assign
end interface i_aggr_assign
interface amg_i_aggr_assign
module procedure amg_i_d_aggr_assign
end interface amg_i_aggr_assign
interface build_matching
module procedure dbuild_matching
end interface build_matching
interface amg_par_build_matching
module procedure amg_d_par_build_matching
end interface amg_par_build_matching
interface build_ahat
module procedure dbuild_ahat
end interface build_ahat
interface amg_par_build_ahat
module procedure amg_d_par_build_ahat
end interface amg_par_build_ahat
interface psb_gtranspose
module procedure psb_dgtranspose
end interface psb_gtranspose
interface amg_PMatchBox
module procedure amg_d_PMatchBox
end interface amg_PMatchBox
interface psb_htranspose
module procedure psb_dhtranspose
end interface psb_htranspose
interface PMatchBox
module procedure dPMatchBox
end interface PMatchBox
logical, parameter, private :: print_statistics=.false.
contains
subroutine 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 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
@@ -312,7 +303,7 @@ contains
! Should be a symmetric function.
!
call desc_a%indxmap%qry_halo_owner(idx,iown,info)
ip = i_aggr_assign(iam, iown, kg, idxg, wk, widx, nrmagg)
ip = amg_i_aggr_assign(iam, iown, kg, idxg, wk, widx, nrmagg)
if (iam == ip) then
nlaggr(iam) = nlaggr(iam) + 1
ilaggr(k) = nlaggr(iam)
@@ -422,11 +413,9 @@ 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
@@ -516,9 +505,9 @@ contains
write(0,*) iam,' : error from Matching: ',info
end if
end subroutine dmatchboxp_build_prol
end subroutine amg_d_matchboxp_build_prol
function 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 i_daggr_assign
end function amg_i_d_aggr_assign
subroutine 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 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
@@ -703,7 +692,7 @@ contains
!
if (debug) write(0,*) iam,' buildmatching into PMatchBox:'
if (do_timings) call psb_tic(idx_cmboxp)
call PMatchBox(nr,nz,vlptr,vlind,ewght,&
call amg_PMatchBox(nr,nz,vlptr,vlind,ewght,&
& vnl, mate, iam, np,ictxt,&
& msgis,msgas,msgprc,ph0t,ph1t,ph2t,ph1crd,ph2crd,info,display_inp)
if (do_timings) call psb_toc(idx_cmboxp)
@@ -767,9 +756,9 @@ contains
val(1:n) = tmp(1:n)
end subroutine fix_order
end subroutine dbuild_matching
end subroutine amg_d_par_build_matching
subroutine 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 dbuild_ahat
end subroutine amg_d_par_build_ahat
subroutine psb_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 psb_dgtranspose
subroutine psb_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 psb_dhtranspose
subroutine 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 dPMatchBox
end subroutine amg_d_PMatchBox
end module dmatchboxp_mod
end module amg_d_matchboxp_mod
amgprec/amg_d_parmatch_aggregator_mod.F90
+51 -57
View File
@@ -118,7 +118,7 @@
module amg_d_parmatch_aggregator_mod
use amg_d_base_aggregator_mod
use 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
@@ -132,8 +132,6 @@ module amg_d_parmatch_aggregator_mod
type(psb_dspmat_type), allocatable :: prol, restr
type(psb_dspmat_type), allocatable :: ac, base_a, rwa
type(psb_desc_type), allocatable :: desc_ac, desc_ax, base_desc, rwdesc
integer(psb_ipk_) :: max_csize
integer(psb_ipk_) :: max_nlevels
logical :: reproducible_matching = .false.
logical :: need_symmetrize = .false.
logical :: unsmoothed_hierarchy = .true.
@@ -143,18 +141,18 @@ module amg_d_parmatch_aggregator_mod
procedure, pass(ag) :: mat_asb => amg_d_parmatch_aggregator_mat_asb
procedure, pass(ag) :: inner_mat_asb => amg_d_parmatch_aggregator_inner_mat_asb
procedure, pass(ag) :: bld_map => amg_d_parmatch_aggregator_bld_map
procedure, pass(ag) :: csetc => d_parmatch_aggr_csetc
procedure, pass(ag) :: cseti => d_parmatch_aggr_cseti
procedure, pass(ag) :: default => d_parmatch_aggr_set_default
procedure, pass(ag) :: sizeof => d_parmatch_aggregator_sizeof
procedure, pass(ag) :: update_next => d_parmatch_aggregator_update_next
procedure, pass(ag) :: bld_wnxt => d_parmatch_bld_wnxt
procedure, pass(ag) :: bld_default_w => d_bld_default_w
procedure, pass(ag) :: set_c_default_w => d_set_prm_c_default_w
procedure, pass(ag) :: descr => d_parmatch_aggregator_descr
procedure, pass(ag) :: clone => d_parmatch_aggregator_clone
procedure, pass(ag) :: free => d_parmatch_aggregator_free
procedure, nopass :: fmt => d_parmatch_aggregator_fmt
procedure, pass(ag) :: csetc => amg_d_parmatch_aggr_csetc
procedure, pass(ag) :: cseti => amg_d_parmatch_aggr_cseti
procedure, pass(ag) :: default => amg_d_parmatch_aggr_set_default
procedure, pass(ag) :: sizeof => amg_d_parmatch_aggregator_sizeof
procedure, pass(ag) :: update_next => amg_d_parmatch_aggregator_update_next
procedure, pass(ag) :: bld_wnxt => amg_d_parmatch_bld_wnxt
procedure, pass(ag) :: bld_default_w => amg_d_bld_default_w
procedure, pass(ag) :: set_c_default_w => amg_d_set_prm_c_default_w
procedure, pass(ag) :: descr => amg_d_parmatch_aggregator_descr
procedure, pass(ag) :: clone => amg_d_parmatch_aggregator_clone
procedure, pass(ag) :: free => amg_d_parmatch_aggregator_free
procedure, nopass :: fmt => amg_d_parmatch_aggregator_fmt
procedure, nopass :: xt_desc => amg_d_parmatch_aggregator_xt_desc
end type amg_d_parmatch_aggregator_type
@@ -168,7 +166,7 @@ module amg_d_parmatch_aggregator_mod
type(amg_dml_parms), intent(inout) :: parms
type(amg_daggr_data), intent(in) :: ag_data
type(psb_dspmat_type), intent(inout) :: a
type(psb_desc_type), intent(inout) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_ldspmat_type), intent(out) :: t_prol
integer(psb_ipk_), intent(out) :: info
@@ -235,7 +233,7 @@ module amg_d_parmatch_aggregator_mod
& psb_ldspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_dml_parms, amg_daggr_data
implicit none
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_dml_parms), intent(inout) :: parms
type(psb_ldspmat_type), intent(inout) :: t_prol
@@ -257,7 +255,7 @@ module amg_d_parmatch_aggregator_mod
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_dml_parms), intent(inout) :: parms
type(psb_ldspmat_type), intent(inout) :: t_prol
type(psb_dspmat_type), intent(out) :: op_prol,ac, op_restr
type(psb_dspmat_type), intent(inout) :: op_prol,ac, op_restr
type(psb_desc_type), intent(inout) :: desc_ac
integer(psb_ipk_), intent(out) :: info
end subroutine amg_d_parmatch_unsmth_bld
@@ -275,7 +273,7 @@ module amg_d_parmatch_aggregator_mod
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_dml_parms), intent(inout) :: parms
type(psb_ldspmat_type), intent(inout) :: t_prol
type(psb_dspmat_type), intent(out) :: op_prol,ac, op_restr
type(psb_dspmat_type), intent(inout) :: op_prol,ac, op_restr
type(psb_desc_type), intent(inout) :: desc_ac
integer(psb_ipk_), intent(out) :: info
end subroutine amg_d_parmatch_smth_bld
@@ -288,11 +286,11 @@ module amg_d_parmatch_aggregator_mod
& psb_ldspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_dml_parms, amg_daggr_data
implicit none
type(psb_dspmat_type), intent(inout) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_dml_parms), intent(inout) :: parms
type(psb_ldspmat_type), intent(inout) :: t_prol
type(psb_dspmat_type), intent(out) :: op_prol,ac, op_restr
type(psb_dspmat_type), intent(inout) :: op_prol,ac, op_restr
type(psb_desc_type), intent(out) :: desc_ac
integer(psb_ipk_), intent(out) :: info
end subroutine amg_d_parmatch_spmm_bld_ov
@@ -306,11 +304,11 @@ module amg_d_parmatch_aggregator_mod
& psb_d_csr_sparse_mat, psb_ld_csr_sparse_mat
implicit none
type(psb_d_csr_sparse_mat), intent(inout) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_dml_parms), intent(inout) :: parms
type(psb_ldspmat_type), intent(inout) :: t_prol
type(psb_dspmat_type), intent(out) :: op_prol,ac, op_restr
type(psb_dspmat_type), intent(inout) :: op_prol,ac, op_restr
type(psb_desc_type), intent(out) :: desc_ac
integer(psb_ipk_), intent(out) :: info
end subroutine amg_d_parmatch_spmm_bld_inner
@@ -320,7 +318,7 @@ module amg_d_parmatch_aggregator_mod
contains
subroutine d_bld_default_w(ag,nr)
subroutine amg_d_bld_default_w(ag,nr)
use psb_realloc_mod
implicit none
class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag
@@ -330,9 +328,9 @@ contains
if (info /= psb_success_) return
ag%w = done
!call ag%set_c_default_w()
end subroutine d_bld_default_w
end subroutine amg_d_bld_default_w
subroutine d_set_prm_c_default_w(ag)
subroutine amg_d_set_prm_c_default_w(ag)
use psb_realloc_mod
use iso_c_binding
implicit none
@@ -342,9 +340,9 @@ contains
!write(0,*) 'prm_c_deafult_w '
call psb_safe_ab_cpy(ag%w,ag%w_nxt,info)
end subroutine d_set_prm_c_default_w
end subroutine amg_d_set_prm_c_default_w
subroutine d_parmatch_bld_wnxt(ag,ilaggr,valaggr,nx)
subroutine amg_d_parmatch_bld_wnxt(ag,ilaggr,valaggr,nx)
use psb_realloc_mod
implicit none
class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag
@@ -358,14 +356,14 @@ contains
!write(0,*) 'Executing bld_wnxt ',nx
call psb_realloc(nx,ag%w_nxt,info)
end subroutine d_parmatch_bld_wnxt
end subroutine amg_d_parmatch_bld_wnxt
function d_parmatch_aggregator_fmt() result(val)
function amg_d_parmatch_aggregator_fmt() result(val)
implicit none
character(len=32) :: val
val = "Parallel Matching aggregation"
end function d_parmatch_aggregator_fmt
end function amg_d_parmatch_aggregator_fmt
function amg_d_parmatch_aggregator_xt_desc() result(val)
implicit none
@@ -374,7 +372,7 @@ contains
val = .true.
end function amg_d_parmatch_aggregator_xt_desc
function d_parmatch_aggregator_sizeof(ag) result(val)
function amg_d_parmatch_aggregator_sizeof(ag) result(val)
use psb_realloc_mod
implicit none
class(amg_d_parmatch_aggregator_type), intent(in) :: ag
@@ -390,9 +388,9 @@ contains
if (allocated(ag%base_desc)) val = val + ag%base_desc%sizeof()
if (allocated(ag%desc_ax)) val = val + ag%desc_ax%sizeof()
end function d_parmatch_aggregator_sizeof
end function amg_d_parmatch_aggregator_sizeof
subroutine d_parmatch_aggregator_descr(ag,parms,iout,info)
subroutine amg_d_parmatch_aggregator_descr(ag,parms,iout,info)
implicit none
class(amg_d_parmatch_aggregator_type), intent(in) :: ag
type(amg_dml_parms), intent(in) :: parms
@@ -406,7 +404,7 @@ contains
call parms%mldescr(iout,info)
return
end subroutine d_parmatch_aggregator_descr
end subroutine amg_d_parmatch_aggregator_descr
function is_legal_malg(alg) result(val)
logical :: val
@@ -437,7 +435,7 @@ contains
end function is_legal_nlevels
subroutine d_parmatch_aggregator_update_next(ag,agnext,info)
subroutine amg_d_parmatch_aggregator_update_next(ag,agnext,info)
use psb_realloc_mod
implicit none
class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag
@@ -452,10 +450,10 @@ contains
& agnext%matching_alg = ag%matching_alg
if (.not.is_legal_nsweeps(agnext%n_sweeps))&
& agnext%n_sweeps = ag%n_sweeps
if (.not.is_legal_csize(agnext%max_csize))&
& agnext%max_csize = ag%max_csize
if (.not.is_legal_nlevels(agnext%max_nlevels))&
& agnext%max_nlevels = ag%max_nlevels
!!$ if (.not.is_legal_csize(agnext%max_csize))&
!!$ & agnext%max_csize = ag%max_csize
!!$ if (.not.is_legal_nlevels(agnext%max_nlevels))&
!!$ & agnext%max_nlevels = ag%max_nlevels
! Is this going to generate shallow copies/memory leaks/double frees?
! To be investigated further.
call psb_safe_ab_cpy(ag%w_nxt,agnext%w,info)
@@ -470,9 +468,9 @@ contains
! What should we do here?
end select
info = 0
end subroutine d_parmatch_aggregator_update_next
end subroutine amg_d_parmatch_aggregator_update_next
subroutine d_parmatch_aggr_csetc(ag,what,val,info,idx)
subroutine amg_d_parmatch_aggr_csetc(ag,what,val,info,idx)
Implicit None
@@ -514,9 +512,9 @@ contains
! Do nothing
end select
return
end subroutine d_parmatch_aggr_csetc
end subroutine amg_d_parmatch_aggr_csetc
subroutine d_parmatch_aggr_cseti(ag,what,val,info,idx)
subroutine amg_d_parmatch_aggr_cseti(ag,what,val,info,idx)
Implicit None
@@ -540,10 +538,6 @@ contains
case('AGGR_SIZE')
ag%orig_aggr_size = val
ag%n_sweeps=max(1,ceiling(log(val*1.0)/log(2.0)))
case('PRMC_MAX_CSIZE')
ag%max_csize=val
case('PRMC_MAX_NLEVELS')
ag%max_nlevels=val
case('PRMC_W_SIZE')
call ag%bld_default_w(val)
case('PRMC_REPRODUCIBLE_MATCHING')
@@ -556,9 +550,9 @@ contains
! Do nothing
end select
return
end subroutine d_parmatch_aggr_cseti
end subroutine amg_d_parmatch_aggr_cseti
subroutine d_parmatch_aggr_set_default(ag)
subroutine amg_d_parmatch_aggr_set_default(ag)
Implicit None
@@ -569,8 +563,8 @@ contains
ag%matching_alg = 0
ag%n_sweeps = 1
ag%jacobi_sweeps = 0
ag%max_nlevels = 36
ag%max_csize = -1
!!$ ag%max_nlevels = 36
!!$ ag%max_csize = -1
!
! Apparently BootCMatch works better
! by keeping all entries
@@ -579,9 +573,9 @@ contains
return
end subroutine d_parmatch_aggr_set_default
end subroutine amg_d_parmatch_aggr_set_default
subroutine d_parmatch_aggregator_free(ag,info)
subroutine amg_d_parmatch_aggregator_free(ag,info)
use iso_c_binding
implicit none
class(amg_d_parmatch_aggregator_type), intent(inout) :: ag
@@ -618,9 +612,9 @@ contains
call ag%rwdesc%free(info); deallocate(ag%rwdesc,stat=info)
end if
end subroutine d_parmatch_aggregator_free
end subroutine amg_d_parmatch_aggregator_free
subroutine d_parmatch_aggregator_clone(ag,agnext,info)
subroutine amg_d_parmatch_aggregator_clone(ag,agnext,info)
implicit none
class(amg_d_parmatch_aggregator_type), intent(inout) :: ag
class(amg_d_base_aggregator_type), allocatable, intent(inout) :: agnext
@@ -640,7 +634,7 @@ contains
! Should never ever get here
info = -1
end select
end subroutine d_parmatch_aggregator_clone
end subroutine amg_d_parmatch_aggregator_clone
subroutine amg_d_parmatch_aggregator_bld_map(ag,desc_a,desc_ac,ilaggr,nlaggr,&
& op_restr,op_prol,map,info)
amgprec/amg_d_sludist_solver.F90
+31 -12
View File
@@ -52,7 +52,7 @@ module amg_d_sludist_solver
use iso_c_binding
use amg_d_base_solver_mod
#if defined(LPK8)
#if (!defined(HAVE_SLUDIST_)) || defined(IPK8)
type, extends(amg_d_base_solver_type) :: amg_d_sludist_solver_type
@@ -270,11 +270,13 @@ contains
! Local variables
type(psb_dspmat_type) :: atmp
type(psb_d_csr_sparse_mat) :: acsr
integer :: n_row,n_col, nrow_a, nztota, nglob, nzt, npr, npc
integer :: ifrst, ibcheck
integer(psb_lpk_), allocatable :: gia(:), gja(:)
type(psb_ctxt_type) :: ctxt
integer :: np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='d_sludist_solver_bld', ch_err
integer(psb_lpk_) :: lfrst
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nglob, nzt, npr, npc
integer(psb_ipk_) :: ifrst, ibcheck
integer(psb_ipk_) :: np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='d_sludist_solver_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)
@@ -293,19 +295,37 @@ contains
n_col = desc_a%get_local_cols()
nglob = desc_a%get_global_rows()
call a%cscnv(atmp,info,type='coo')
!
! Strategy here is as follows: because a call to SLUDIST
! as a gobal solver is mostly done at the coarsest level,
! even if we start from a problem requiring 8 bytes, chances
! are that the global size will be suitable for 4 bytes
! anyway, so we hope for the best, and throw an error
! if something goes wrong.
!
if (nglob > huge(1_psb_ipk_)) then
write(0,*) me,' ',trim(name),': Error: overflow of local indices '
info=psb_err_internal_error_
call psb_errpush(info,name)
goto 9999
end if
call a%cscnv(atmp,info,type='csr')
! This in case we are dealing with AS
call psb_rwextd(n_row,atmp,info,b=b)
call atmp%cscnv(info,type='csr',dupl=psb_dupl_add_)
call atmp%mv_to(acsr)
nrow_a = acsr%get_nrows()
nztota = acsr%get_nzeros()
call psb_loc_to_glob(ione,lfrst,desc_a,info)
! Fix the entries to call C-base SuperLU
call psb_loc_to_glob(1,ifrst,desc_a,info)
call psb_loc_to_glob(nrow_a,ibcheck,desc_a,info)
call psb_loc_to_glob(acsr%ja(1:nztota),desc_a,info,iact='I')
call psb_realloc(nztota,gja,info)
call psb_loc_to_glob(acsr%ja(1:nztota),gja(1:nztota), desc_a, info, iact='I')
acsr%ja(1:nztota) = gja(1:nztota)
acsr%ja(:) = acsr%ja(:) - 1
acsr%irp(:) = acsr%irp(:) - 1
ifrst = ifrst - 1
ifrst = lfrst - 1
info = amg_dsludist_fact(nglob,nrow_a,nztota,ifrst,&
& acsr%val,acsr%irp,acsr%ja,sv%lufactors,&
& npr,npc)
@@ -318,7 +338,6 @@ contains
end if
call acsr%free()
call atmp%free()
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' end'
amgprec/amg_s_base_aggregator_mod.f90
+2 -2
View File
@@ -126,7 +126,7 @@ module amg_s_base_aggregator_mod
& psb_s_coo_sparse_mat, amg_sml_parms, psb_spk_, psb_ipk_, psb_lpk_
implicit none
type(psb_s_csr_sparse_mat), intent(inout) :: a_csr
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: nlaggr(:)
type(amg_sml_parms), intent(inout) :: parms
type(psb_s_coo_sparse_mat), intent(inout) :: coo_prol, coo_restr
@@ -144,7 +144,7 @@ module amg_s_base_aggregator_mod
& psb_s_coo_sparse_mat, amg_sml_parms, psb_spk_, psb_ipk_, psb_lpk_
implicit none
type(psb_s_csr_sparse_mat), intent(inout) :: a_csr
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: nlaggr(:)
type(amg_sml_parms), intent(inout) :: parms
type(psb_s_coo_sparse_mat), intent(inout) :: coo_prol, coo_restr
amgprec/amg_s_matchboxp_mod.f90
+31 -334
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 smatchboxp_mod
module amg_s_matchboxp_mod
use iso_c_binding
use psb_base_cbind_mod
@@ -94,34 +94,25 @@ module smatchboxp_mod
end subroutine sMatchBoxPC
end interface MatchBoxPC
interface i_aggr_assign
module procedure i_saggr_assign
end interface i_aggr_assign
interface amg_i_aggr_assign
module procedure amg_i_s_aggr_assign
end interface amg_i_aggr_assign
interface build_matching
module procedure sbuild_matching
end interface build_matching
interface amg_par_build_matching
module procedure amg_s_par_build_matching
end interface amg_par_build_matching
interface build_ahat
module procedure sbuild_ahat
end interface build_ahat
interface amg_par_build_ahat
module procedure amg_s_par_build_ahat
end interface amg_par_build_ahat
interface psb_gtranspose
module procedure psb_sgtranspose
end interface psb_gtranspose
interface amg_PMatchBox
module procedure amg_s_PMatchBox
end interface amg_PMatchBox
interface psb_htranspose
module procedure psb_shtranspose
end interface psb_htranspose
interface PMatchBox
module procedure sPMatchBox
end interface PMatchBox
logical, parameter, private :: print_statistics=.false.
contains
subroutine 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 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
@@ -312,7 +303,7 @@ contains
! Should be a symmetric function.
!
call desc_a%indxmap%qry_halo_owner(idx,iown,info)
ip = i_aggr_assign(iam, iown, kg, idxg, wk, widx, nrmagg)
ip = amg_i_aggr_assign(iam, iown, kg, idxg, wk, widx, nrmagg)
if (iam == ip) then
nlaggr(iam) = nlaggr(iam) + 1
ilaggr(k) = nlaggr(iam)
@@ -422,11 +413,9 @@ 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
@@ -516,9 +505,9 @@ contains
write(0,*) iam,' : error from Matching: ',info
end if
end subroutine smatchboxp_build_prol
end subroutine amg_s_matchboxp_build_prol
function 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 i_saggr_assign
end function amg_i_s_aggr_assign
subroutine 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 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
@@ -703,7 +692,7 @@ contains
!
if (debug) write(0,*) iam,' buildmatching into PMatchBox:'
if (do_timings) call psb_tic(idx_cmboxp)
call PMatchBox(nr,nz,vlptr,vlind,ewght,&
call amg_PMatchBox(nr,nz,vlptr,vlind,ewght,&
& vnl, mate, iam, np,ictxt,&
& msgis,msgas,msgprc,ph0t,ph1t,ph2t,ph1crd,ph2crd,info,display_inp)
if (do_timings) call psb_toc(idx_cmboxp)
@@ -767,9 +756,9 @@ contains
val(1:n) = tmp(1:n)
end subroutine fix_order
end subroutine sbuild_matching
end subroutine amg_s_par_build_matching
subroutine 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 sbuild_ahat
end subroutine amg_s_par_build_ahat
subroutine psb_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 psb_sgtranspose
subroutine psb_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 psb_shtranspose
subroutine 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 sPMatchBox
end subroutine amg_s_PMatchBox
end module smatchboxp_mod
end module amg_s_matchboxp_mod
amgprec/amg_s_parmatch_aggregator_mod.F90
+51 -57
View File
@@ -118,7 +118,7 @@
module amg_s_parmatch_aggregator_mod
use amg_s_base_aggregator_mod
use 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
@@ -132,8 +132,6 @@ module amg_s_parmatch_aggregator_mod
type(psb_sspmat_type), allocatable :: prol, restr
type(psb_sspmat_type), allocatable :: ac, base_a, rwa
type(psb_desc_type), allocatable :: desc_ac, desc_ax, base_desc, rwdesc
integer(psb_ipk_) :: max_csize
integer(psb_ipk_) :: max_nlevels
logical :: reproducible_matching = .false.
logical :: need_symmetrize = .false.
logical :: unsmoothed_hierarchy = .true.
@@ -143,18 +141,18 @@ module amg_s_parmatch_aggregator_mod
procedure, pass(ag) :: mat_asb => amg_s_parmatch_aggregator_mat_asb
procedure, pass(ag) :: inner_mat_asb => amg_s_parmatch_aggregator_inner_mat_asb
procedure, pass(ag) :: bld_map => amg_s_parmatch_aggregator_bld_map
procedure, pass(ag) :: csetc => s_parmatch_aggr_csetc
procedure, pass(ag) :: cseti => s_parmatch_aggr_cseti
procedure, pass(ag) :: default => s_parmatch_aggr_set_default
procedure, pass(ag) :: sizeof => s_parmatch_aggregator_sizeof
procedure, pass(ag) :: update_next => s_parmatch_aggregator_update_next
procedure, pass(ag) :: bld_wnxt => s_parmatch_bld_wnxt
procedure, pass(ag) :: bld_default_w => s_bld_default_w
procedure, pass(ag) :: set_c_default_w => s_set_prm_c_default_w
procedure, pass(ag) :: descr => s_parmatch_aggregator_descr
procedure, pass(ag) :: clone => s_parmatch_aggregator_clone
procedure, pass(ag) :: free => s_parmatch_aggregator_free
procedure, nopass :: fmt => s_parmatch_aggregator_fmt
procedure, pass(ag) :: csetc => amg_s_parmatch_aggr_csetc
procedure, pass(ag) :: cseti => amg_s_parmatch_aggr_cseti
procedure, pass(ag) :: default => amg_s_parmatch_aggr_set_default
procedure, pass(ag) :: sizeof => amg_s_parmatch_aggregator_sizeof
procedure, pass(ag) :: update_next => amg_s_parmatch_aggregator_update_next
procedure, pass(ag) :: bld_wnxt => amg_s_parmatch_bld_wnxt
procedure, pass(ag) :: bld_default_w => amg_s_bld_default_w
procedure, pass(ag) :: set_c_default_w => amg_s_set_prm_c_default_w
procedure, pass(ag) :: descr => amg_s_parmatch_aggregator_descr
procedure, pass(ag) :: clone => amg_s_parmatch_aggregator_clone
procedure, pass(ag) :: free => amg_s_parmatch_aggregator_free
procedure, nopass :: fmt => amg_s_parmatch_aggregator_fmt
procedure, nopass :: xt_desc => amg_s_parmatch_aggregator_xt_desc
end type amg_s_parmatch_aggregator_type
@@ -168,7 +166,7 @@ module amg_s_parmatch_aggregator_mod
type(amg_sml_parms), intent(inout) :: parms
type(amg_saggr_data), intent(in) :: ag_data
type(psb_sspmat_type), intent(inout) :: a
type(psb_desc_type), intent(inout) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_lsspmat_type), intent(out) :: t_prol
integer(psb_ipk_), intent(out) :: info
@@ -235,7 +233,7 @@ module amg_s_parmatch_aggregator_mod
& psb_lsspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_sml_parms, amg_saggr_data
implicit none
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_sml_parms), intent(inout) :: parms
type(psb_lsspmat_type), intent(inout) :: t_prol
@@ -257,7 +255,7 @@ module amg_s_parmatch_aggregator_mod
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_sml_parms), intent(inout) :: parms
type(psb_lsspmat_type), intent(inout) :: t_prol
type(psb_sspmat_type), intent(out) :: op_prol,ac, op_restr
type(psb_sspmat_type), intent(inout) :: op_prol,ac, op_restr
type(psb_desc_type), intent(inout) :: desc_ac
integer(psb_ipk_), intent(out) :: info
end subroutine amg_s_parmatch_unsmth_bld
@@ -275,7 +273,7 @@ module amg_s_parmatch_aggregator_mod
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_sml_parms), intent(inout) :: parms
type(psb_lsspmat_type), intent(inout) :: t_prol
type(psb_sspmat_type), intent(out) :: op_prol,ac, op_restr
type(psb_sspmat_type), intent(inout) :: op_prol,ac, op_restr
type(psb_desc_type), intent(inout) :: desc_ac
integer(psb_ipk_), intent(out) :: info
end subroutine amg_s_parmatch_smth_bld
@@ -288,11 +286,11 @@ module amg_s_parmatch_aggregator_mod
& psb_lsspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_sml_parms, amg_saggr_data
implicit none
type(psb_sspmat_type), intent(inout) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_sml_parms), intent(inout) :: parms
type(psb_lsspmat_type), intent(inout) :: t_prol
type(psb_sspmat_type), intent(out) :: op_prol,ac, op_restr
type(psb_sspmat_type), intent(inout) :: op_prol,ac, op_restr
type(psb_desc_type), intent(out) :: desc_ac
integer(psb_ipk_), intent(out) :: info
end subroutine amg_s_parmatch_spmm_bld_ov
@@ -306,11 +304,11 @@ module amg_s_parmatch_aggregator_mod
& psb_s_csr_sparse_mat, psb_ls_csr_sparse_mat
implicit none
type(psb_s_csr_sparse_mat), intent(inout) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_sml_parms), intent(inout) :: parms
type(psb_lsspmat_type), intent(inout) :: t_prol
type(psb_sspmat_type), intent(out) :: op_prol,ac, op_restr
type(psb_sspmat_type), intent(inout) :: op_prol,ac, op_restr
type(psb_desc_type), intent(out) :: desc_ac
integer(psb_ipk_), intent(out) :: info
end subroutine amg_s_parmatch_spmm_bld_inner
@@ -320,7 +318,7 @@ module amg_s_parmatch_aggregator_mod
contains
subroutine s_bld_default_w(ag,nr)
subroutine amg_s_bld_default_w(ag,nr)
use psb_realloc_mod
implicit none
class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag
@@ -330,9 +328,9 @@ contains
if (info /= psb_success_) return
ag%w = done
!call ag%set_c_default_w()
end subroutine s_bld_default_w
end subroutine amg_s_bld_default_w
subroutine s_set_prm_c_default_w(ag)
subroutine amg_s_set_prm_c_default_w(ag)
use psb_realloc_mod
use iso_c_binding
implicit none
@@ -342,9 +340,9 @@ contains
!write(0,*) 'prm_c_deafult_w '
call psb_safe_ab_cpy(ag%w,ag%w_nxt,info)
end subroutine s_set_prm_c_default_w
end subroutine amg_s_set_prm_c_default_w
subroutine s_parmatch_bld_wnxt(ag,ilaggr,valaggr,nx)
subroutine amg_s_parmatch_bld_wnxt(ag,ilaggr,valaggr,nx)
use psb_realloc_mod
implicit none
class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag
@@ -358,14 +356,14 @@ contains
!write(0,*) 'Executing bld_wnxt ',nx
call psb_realloc(nx,ag%w_nxt,info)
end subroutine s_parmatch_bld_wnxt
end subroutine amg_s_parmatch_bld_wnxt
function s_parmatch_aggregator_fmt() result(val)
function amg_s_parmatch_aggregator_fmt() result(val)
implicit none
character(len=32) :: val
val = "Parallel Matching aggregation"
end function s_parmatch_aggregator_fmt
end function amg_s_parmatch_aggregator_fmt
function amg_s_parmatch_aggregator_xt_desc() result(val)
implicit none
@@ -374,7 +372,7 @@ contains
val = .true.
end function amg_s_parmatch_aggregator_xt_desc
function s_parmatch_aggregator_sizeof(ag) result(val)
function amg_s_parmatch_aggregator_sizeof(ag) result(val)
use psb_realloc_mod
implicit none
class(amg_s_parmatch_aggregator_type), intent(in) :: ag
@@ -390,9 +388,9 @@ contains
if (allocated(ag%base_desc)) val = val + ag%base_desc%sizeof()
if (allocated(ag%desc_ax)) val = val + ag%desc_ax%sizeof()
end function s_parmatch_aggregator_sizeof
end function amg_s_parmatch_aggregator_sizeof
subroutine s_parmatch_aggregator_descr(ag,parms,iout,info)
subroutine amg_s_parmatch_aggregator_descr(ag,parms,iout,info)
implicit none
class(amg_s_parmatch_aggregator_type), intent(in) :: ag
type(amg_sml_parms), intent(in) :: parms
@@ -406,7 +404,7 @@ contains
call parms%mldescr(iout,info)
return
end subroutine s_parmatch_aggregator_descr
end subroutine amg_s_parmatch_aggregator_descr
function is_legal_malg(alg) result(val)
logical :: val
@@ -437,7 +435,7 @@ contains
end function is_legal_nlevels
subroutine s_parmatch_aggregator_update_next(ag,agnext,info)
subroutine amg_s_parmatch_aggregator_update_next(ag,agnext,info)
use psb_realloc_mod
implicit none
class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag
@@ -452,10 +450,10 @@ contains
& agnext%matching_alg = ag%matching_alg
if (.not.is_legal_nsweeps(agnext%n_sweeps))&
& agnext%n_sweeps = ag%n_sweeps
if (.not.is_legal_csize(agnext%max_csize))&
& agnext%max_csize = ag%max_csize
if (.not.is_legal_nlevels(agnext%max_nlevels))&
& agnext%max_nlevels = ag%max_nlevels
!!$ if (.not.is_legal_csize(agnext%max_csize))&
!!$ & agnext%max_csize = ag%max_csize
!!$ if (.not.is_legal_nlevels(agnext%max_nlevels))&
!!$ & agnext%max_nlevels = ag%max_nlevels
! Is this going to generate shallow copies/memory leaks/double frees?
! To be investigated further.
call psb_safe_ab_cpy(ag%w_nxt,agnext%w,info)
@@ -470,9 +468,9 @@ contains
! What should we do here?
end select
info = 0
end subroutine s_parmatch_aggregator_update_next
end subroutine amg_s_parmatch_aggregator_update_next
subroutine s_parmatch_aggr_csetc(ag,what,val,info,idx)
subroutine amg_s_parmatch_aggr_csetc(ag,what,val,info,idx)
Implicit None
@@ -514,9 +512,9 @@ contains
! Do nothing
end select
return
end subroutine s_parmatch_aggr_csetc
end subroutine amg_s_parmatch_aggr_csetc
subroutine s_parmatch_aggr_cseti(ag,what,val,info,idx)
subroutine amg_s_parmatch_aggr_cseti(ag,what,val,info,idx)
Implicit None
@@ -540,10 +538,6 @@ contains
case('AGGR_SIZE')
ag%orig_aggr_size = val
ag%n_sweeps=max(1,ceiling(log(val*1.0)/log(2.0)))
case('PRMC_MAX_CSIZE')
ag%max_csize=val
case('PRMC_MAX_NLEVELS')
ag%max_nlevels=val
case('PRMC_W_SIZE')
call ag%bld_default_w(val)
case('PRMC_REPRODUCIBLE_MATCHING')
@@ -556,9 +550,9 @@ contains
! Do nothing
end select
return
end subroutine s_parmatch_aggr_cseti
end subroutine amg_s_parmatch_aggr_cseti
subroutine s_parmatch_aggr_set_default(ag)
subroutine amg_s_parmatch_aggr_set_default(ag)
Implicit None
@@ -569,8 +563,8 @@ contains
ag%matching_alg = 0
ag%n_sweeps = 1
ag%jacobi_sweeps = 0
ag%max_nlevels = 36
ag%max_csize = -1
!!$ ag%max_nlevels = 36
!!$ ag%max_csize = -1
!
! Apparently BootCMatch works better
! by keeping all entries
@@ -579,9 +573,9 @@ contains
return
end subroutine s_parmatch_aggr_set_default
end subroutine amg_s_parmatch_aggr_set_default
subroutine s_parmatch_aggregator_free(ag,info)
subroutine amg_s_parmatch_aggregator_free(ag,info)
use iso_c_binding
implicit none
class(amg_s_parmatch_aggregator_type), intent(inout) :: ag
@@ -618,9 +612,9 @@ contains
call ag%rwdesc%free(info); deallocate(ag%rwdesc,stat=info)
end if
end subroutine s_parmatch_aggregator_free
end subroutine amg_s_parmatch_aggregator_free
subroutine s_parmatch_aggregator_clone(ag,agnext,info)
subroutine amg_s_parmatch_aggregator_clone(ag,agnext,info)
implicit none
class(amg_s_parmatch_aggregator_type), intent(inout) :: ag
class(amg_s_base_aggregator_type), allocatable, intent(inout) :: agnext
@@ -640,7 +634,7 @@ contains
! Should never ever get here
info = -1
end select
end subroutine s_parmatch_aggregator_clone
end subroutine amg_s_parmatch_aggregator_clone
subroutine amg_s_parmatch_aggregator_bld_map(ag,desc_a,desc_ac,ilaggr,nlaggr,&
& op_restr,op_prol,map,info)
amgprec/amg_z_base_aggregator_mod.f90
+2 -2
View File
@@ -126,7 +126,7 @@ module amg_z_base_aggregator_mod
& psb_z_coo_sparse_mat, amg_dml_parms, psb_dpk_, psb_ipk_, psb_lpk_
implicit none
type(psb_z_csr_sparse_mat), intent(inout) :: a_csr
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: nlaggr(:)
type(amg_dml_parms), intent(inout) :: parms
type(psb_z_coo_sparse_mat), intent(inout) :: coo_prol, coo_restr
@@ -144,7 +144,7 @@ module amg_z_base_aggregator_mod
& psb_z_coo_sparse_mat, amg_dml_parms, psb_dpk_, psb_ipk_, psb_lpk_
implicit none
type(psb_z_csr_sparse_mat), intent(inout) :: a_csr
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: nlaggr(:)
type(amg_dml_parms), intent(inout) :: parms
type(psb_z_coo_sparse_mat), intent(inout) :: coo_prol, coo_restr
amgprec/amg_z_sludist_solver.F90
+30 -12
View File
@@ -52,7 +52,7 @@ module amg_z_sludist_solver
use iso_c_binding
use amg_z_base_solver_mod
#if defined(LPK8)
#if (!defined(HAVE_SLUDIST_)) || defined(IPK8)
type, extends(amg_z_base_solver_type) :: amg_z_sludist_solver_type
@@ -270,11 +270,13 @@ contains
! Local variables
type(psb_zspmat_type) :: atmp
type(psb_z_csr_sparse_mat) :: acsr
integer :: n_row,n_col, nrow_a, nztota, nglob, nzt, npr, npc
integer :: ifrst, ibcheck
integer(psb_lpk_), allocatable :: gia(:), gja(:)
type(psb_ctxt_type) :: ctxt
integer :: np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='z_sludist_solver_bld', ch_err
integer(psb_lpk_) :: lfrst
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nglob, nzt, npr, npc
integer(psb_ipk_) :: ifrst, ibcheck
integer(psb_ipk_) :: np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='z_sludist_solver_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)
@@ -293,19 +295,36 @@ contains
n_col = desc_a%get_local_cols()
nglob = desc_a%get_global_rows()
call a%cscnv(atmp,info,type='coo')
!
! Strategy here is as follows: because a call to SLUDIST
! as a gobal solver is mostly done at the coarsest level,
! even if we start from a problem requiring 8 bytes, chances
! are that the global size will be suitable for 4 bytes
! anyway, so we hope for the best, and throw an error
! if something goes wrong.
!
if (nglob > huge(1_psb_ipk_)) then
write(0,*) me,' ',trim(name),': Error: overflow of local indices '
info=psb_err_internal_error_
call psb_errpush(info,name)
goto 9999
end if
call a%cscnv(atmp,info,type='csr')
! This in case we are dealing with AS
call psb_rwextd(n_row,atmp,info,b=b)
call atmp%cscnv(info,type='csr',dupl=psb_dupl_add_)
call atmp%mv_to(acsr)
nrow_a = acsr%get_nrows()
nztota = acsr%get_nzeros()
call psb_loc_to_glob(ione,lfrst,desc_a,info)
! Fix the entries to call C-base SuperLU
call psb_loc_to_glob(1,ifrst,desc_a,info)
call psb_loc_to_glob(nrow_a,ibcheck,desc_a,info)
call psb_loc_to_glob(acsr%ja(1:nztota),desc_a,info,iact='I')
call psb_realloc(nztota,gja,info)
call psb_loc_to_glob(acsr%ja(1:nztota),gja(1:nztota), desc_a, info, iact='I')
acsr%ja(1:nztota) = gja(1:nztota)
acsr%ja(:) = acsr%ja(:) - 1
acsr%irp(:) = acsr%irp(:) - 1
ifrst = ifrst - 1
ifrst = lfrst - 1
info = amg_zsludist_fact(nglob,nrow_a,nztota,ifrst,&
& acsr%val,acsr%irp,acsr%ja,sv%lufactors,&
& npr,npc)
@@ -318,7 +337,6 @@ contains
end if
call acsr%free()
call atmp%free()
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' end'
amgprec/impl/aggregator/amg_c_dec_aggregator_tprol.f90
+2 -2
View File
@@ -83,8 +83,8 @@ subroutine amg_c_dec_aggregator_build_tprol(ag,parms,ag_data,&
class(amg_c_dec_aggregator_type), target, intent(inout) :: ag
type(amg_sml_parms), intent(inout) :: parms
type(amg_saggr_data), intent(in) :: ag_data
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_cspmat_type), intent(inout) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_lcspmat_type), intent(out) :: t_prol
integer(psb_ipk_), intent(out) :: info
amgprec/impl/aggregator/amg_c_symdec_aggregator_tprol.f90
+2 -2
View File
@@ -86,8 +86,8 @@ subroutine amg_c_symdec_aggregator_build_tprol(ag,parms,ag_data,&
class(amg_c_symdec_aggregator_type), target, intent(inout) :: ag
type(amg_sml_parms), intent(inout) :: parms
type(amg_saggr_data), intent(in) :: ag_data
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_cspmat_type), intent(inout) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_lcspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info
amgprec/impl/aggregator/amg_caggrmat_minnrg_bld.f90
+360 -358
View File
@@ -105,7 +105,7 @@
!
!
subroutine amg_caggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
& ac,desc_ac,op_prol,op_restr,info)
& ac,desc_ac,op_prol,op_restr,t_prol,info)
use psb_base_mod
use amg_base_prec_type
use amg_c_inner_mod, amg_protect_name => amg_caggrmat_minnrg_bld
@@ -117,8 +117,8 @@ subroutine amg_caggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_sml_parms), intent(inout) :: parms
type(psb_lcspmat_type), intent(inout) :: op_prol
type(psb_lcspmat_type), intent(out) :: ac,op_restr
type(psb_lcspmat_type), intent(inout) :: t_prol
type(psb_cspmat_type), intent(inout) :: op_prol, ac,op_restr
type(psb_desc_type), intent(inout) :: desc_ac
integer(psb_ipk_), intent(out) :: info
@@ -171,6 +171,8 @@ subroutine amg_caggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
filter_mat = (parms%aggr_filter == amg_filter_mat_)
!NEEDS TO BE REWORKED !!
! naggr: number of local aggregates
! nrow: local rows.
!
@@ -183,361 +185,361 @@ subroutine amg_caggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
goto 9999
end if
! Get the diagonal D
adiag = a%get_diag(info)
if (info == psb_success_) &
& call psb_realloc(ncol,adiag,info)
if (info == psb_success_) &
& call psb_halo(adiag,desc_a,info)
if (info == psb_success_) call a%cp_to_l(la)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
goto 9999
end if
do i=1,size(adiag)
if (adiag(i) /= czero) then
adinv(i) = cone / adiag(i)
else
adinv(i) = cone
end if
end do
! 1. Allocate Ptilde in sparse matrix form
call op_prol%mv_to(tmpcoo)
call ptilde%mv_from(tmpcoo)
call ptilde%cscnv(info,type='csr')
if (info == psb_success_) call la%cscnv(am3,info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call la%cscnv(da,info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Initial copies done.'
call da%scal(adinv,info)
call psb_spspmm(da,ptilde,dap,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
goto 9999
end if
call dap%clone(atmp,info)
call psb_sphalo(atmp,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.,outfmt='CSR ')
if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=am4)
if (info == psb_success_) call am4%free()
call psb_spspmm(da,atmp,dadap,info)
call atmp%free()
! !$ write(0,*) 'Columns of AP',psb_sp_get_ncols(ap)
! !$ write(0,*) 'Columns of ADAP',psb_sp_get_ncols(adap)
call dap%mv_to(csc_dap)
call dadap%mv_to(csc_dadap)
call csc_mat_col_prod(csc_dap,csc_dadap,omp,info)
call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info)
call psb_sum(ctxt,omp)
call psb_sum(ctxt,oden)
! !$ write(0,*) trim(name),' OMP :',omp
! !$ write(0,*) trim(name),' ODEN:',oden
omp = omp/oden
! !$ write(0,*) 'Check on output prolongator ',omp(1:min(size(omp),10))
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
call am3%mv_to(acsr3)
! Compute omega_int
ommx = czero
do i=1, ncol
if (ilaggr(i) >0) then
omi(i) = omp(ilaggr(i))
else
omi(i) = czero
end if
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
end do
! Compute omega_fine
do i=1, nrow
omf(i) = ommx
do j=acsr3%irp(i),acsr3%irp(i+1)-1
if(abs(omi(acsr3%ja(j))) .lt. abs(omf(i))) omf(i)=omi(acsr3%ja(j))
end do
!!$ if(min(real(omf(i)),aimag(omf(i))) < szero) omf(i) = czero
if(psb_minreal(omf(i)) < szero) omf(i) = czero
end do
omf(1:nrow) = omf(1:nrow) * adinv(1:nrow)
if (filter_mat) then
!
! Build the filtered matrix Af from A
!
call la%cscnv(acsrf,info,dupl=psb_dupl_add_)
do i=1,nrow
tmp = czero
jd = -1
do j=acsrf%irp(i),acsrf%irp(i+1)-1
if (acsrf%ja(j) == i) jd = j
if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then
tmp=tmp+acsrf%val(j)
acsrf%val(j)=czero
endif
enddo
if (jd == -1) then
write(0,*) 'Wrong input: we need the diagonal!!!!', i
else
acsrf%val(jd)=acsrf%val(jd)-tmp
end if
enddo
! Take out zeroed terms
call acsrf%clean_zeros(info)
!
! Build the smoothed prolongator using the filtered matrix
!
do i=1,acsrf%get_nrows()
do j=acsrf%irp(i),acsrf%irp(i+1)-1
if (acsrf%ja(j) == i) then
acsrf%val(j) = cone - omf(i)*acsrf%val(j)
else
acsrf%val(j) = - omf(i)*acsrf%val(j)
end if
end do
end do
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done gather, going for SYMBMM 1'
call af%mv_from(acsrf)
!
! op_prol = (I-w*D*Af)Ptilde
! Doing it this way means to consider diag(Af_i)
!
!
call psb_spspmm(af,ptilde,op_prol,info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done SPSPMM 1'
else
!
! Build the smoothed prolongator using the original matrix
!
do i=1,acsr3%get_nrows()
do j=acsr3%irp(i),acsr3%irp(i+1)-1
if (acsr3%ja(j) == i) then
acsr3%val(j) = cone - omf(i)*acsr3%val(j)
else
acsr3%val(j) = - omf(i)*acsr3%val(j)
end if
end do
end do
call am3%mv_from(acsr3)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done gather, going for SYMBMM 1'
!
!
! op_prol = (I-w*D*A)Ptilde
!
!
call psb_spspmm(am3,ptilde,op_prol,info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
end if
!
! Ok, let's start over with the restrictor
!
call ptilde%transc(rtilde)
call la%cscnv(atmp,info,type='csr')
call psb_sphalo(atmp,desc_a,am4,info,&
& colcnv=.true.,rowscale=.true.)
nrt = am4%get_nrows()
call am4%csclip(atmp2,info,lone,nrt,lone,ncol)
call atmp2%cscnv(info,type='CSR')
if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2)
call am4%free()
call atmp2%free()
! This is to compute the transpose. It ONLY works if the
! original A has a symmetric pattern.
call atmp%transc(atmp2)
call atmp2%csclip(dat,info,lone,nrow,lone,ncol)
call dat%cscnv(info,type='csr')
call dat%scal(adinv,info)
! Now for the product.
call psb_spspmm(dat,ptilde,datp,info)
call datp%clone(atmp2,info)
call psb_sphalo(atmp2,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.,outfmt='CSR ')
if (info == psb_success_) call psb_rwextd(ncol,atmp2,info,b=am4)
if (info == psb_success_) call am4%free()
call psb_symbmm(dat,atmp2,datdatp,info)
call psb_numbmm(dat,atmp2,datdatp)
call atmp2%free()
call datp%mv_to(csc_datp)
call datdatp%mv_to(csc_datdatp)
call csc_mat_col_prod(csc_datp,csc_datdatp,omp,info)
call csc_mat_col_prod(csc_datdatp,csc_datdatp,oden,info)
call psb_sum(ctxt,omp)
call psb_sum(ctxt,oden)
! !$ write(debug_unit,*) trim(name),' OMP_R :',omp
! ! $ write(debug_unit,*) trim(name),' ODEN_R:',oden
omp = omp/oden
! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10))
! Compute omega_int
ommx = czero
do i=1, ncol
if (ilaggr(i) >0) then
omi(i) = omp(ilaggr(i))
else
omi(i) = czero
end if
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
end do
! Compute omega_fine
! Going over the columns of atmp means going over the rows
! of A^T. Hopefully ;-)
call atmp%cp_to(acsc)
do i=1, nrow
omf(i) = ommx
do j= acsc%icp(i),acsc%icp(i+1)-1
if(abs(omi(acsc%ia(j))) .lt. abs(omf(i))) omf(i)=omi(acsc%ia(j))
end do
!!$ if(min(real(omf(i)),aimag(omf(i))) < szero) omf(i) = czero
if(psb_minreal(omf(i)) < szero) omf(i) = czero
end do
omf(1:nrow) = omf(1:nrow)*adinv(1:nrow)
call psb_halo(omf,desc_a,info)
call acsc%free()
call atmp%mv_to(acsr1)
do i=1,acsr1%get_nrows()
do j=acsr1%irp(i),acsr1%irp(i+1)-1
if (acsr1%ja(j) == i) then
acsr1%val(j) = cone - acsr1%val(j)*omf(acsr1%ja(j))
else
acsr1%val(j) = - acsr1%val(j)*omf(acsr1%ja(j))
end if
end do
end do
call atmp%mv_from(acsr1)
call rtilde%mv_to(tmpcoo)
nzl = tmpcoo%get_nzeros()
i=0
do k=1, nzl
if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then
i = i+1
tmpcoo%val(i) = tmpcoo%val(k)
tmpcoo%ia(i) = tmpcoo%ia(k)
tmpcoo%ja(i) = tmpcoo%ja(k)
end if
end do
call tmpcoo%set_nzeros(i)
call rtilde%mv_from(tmpcoo)
call rtilde%cscnv(info,type='csr')
call psb_spspmm(rtilde,atmp,op_restr,info)
!
! Now we have to gather the halo of op_prol, and add it to itself
! to multiply it by A,
!
call op_prol%clone(tmp_prol,info)
if (info == psb_success_) call psb_sphalo(tmp_prol,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.)
if (info == psb_success_) call psb_rwextd(ncol,tmp_prol,info,b=am4)
if (info == psb_success_) call am4%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol')
goto 9999
end if
!
! Now we have to fix this. The only rows of B that are correct
! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
!
call op_restr%mv_to(tmpcoo)
nzl = tmpcoo%get_nzeros()
i=0
do k=1, nzl
if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then
i = i+1
tmpcoo%val(i) = tmpcoo%val(k)
tmpcoo%ia(i) = tmpcoo%ia(k)
tmpcoo%ja(i) = tmpcoo%ja(k)
end if
end do
call tmpcoo%set_nzeros(i)
call op_restr%mv_from(tmpcoo)
call op_restr%cscnv(info,type='csr')
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd'
call psb_spspmm(la,tmp_prol,am3,info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done SPSPMM 2'
call psb_sphalo(am3,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.)
if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4)
if (info == psb_success_) call am4%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Extend am3')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done sphalo/ rwxtd'
call psb_spspmm(op_restr,am3,ac,info)
if (info == psb_success_) call am3%free()
if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
&a_err='Build ac = op_restr x am3')
goto 9999
end if
!!$ ! Get the diagonal D
!!$ adiag = a%get_diag(info)
!!$ if (info == psb_success_) &
!!$ & call psb_realloc(ncol,adiag,info)
!!$ if (info == psb_success_) &
!!$ & call psb_halo(adiag,desc_a,info)
!!$ if (info == psb_success_) call a%cp_to_l(la)
!!$ if (info /= psb_success_) then
!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
!!$ goto 9999
!!$ end if
!!$
!!$ do i=1,size(adiag)
!!$ if (adiag(i) /= czero) then
!!$ adinv(i) = cone / adiag(i)
!!$ else
!!$ adinv(i) = cone
!!$ end if
!!$ end do
!!$
!!$
!!$
!!$ ! 1. Allocate Ptilde in sparse matrix form
!!$ call op_prol%mv_to(tmpcoo)
!!$ call ptilde%mv_from(tmpcoo)
!!$ call ptilde%cscnv(info,type='csr')
!!$
!!$ if (info == psb_success_) call la%cscnv(am3,info,type='csr',dupl=psb_dupl_add_)
!!$ if (info == psb_success_) call la%cscnv(da,info,type='csr',dupl=psb_dupl_add_)
!!$ if (info /= psb_success_) then
!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
!!$ goto 9999
!!$ end if
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' Initial copies done.'
!!$
!!$ call da%scal(adinv,info)
!!$
!!$ call psb_spspmm(da,ptilde,dap,info)
!!$
!!$ if(info /= psb_success_) then
!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
!!$ goto 9999
!!$ end if
!!$
!!$ call dap%clone(atmp,info)
!!$
!!$ call psb_sphalo(atmp,desc_a,am4,info,&
!!$ & colcnv=.false.,rowscale=.true.,outfmt='CSR ')
!!$ if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=am4)
!!$ if (info == psb_success_) call am4%free()
!!$
!!$ call psb_spspmm(da,atmp,dadap,info)
!!$ call atmp%free()
!!$
!!$ ! !$ write(0,*) 'Columns of AP',psb_sp_get_ncols(ap)
!!$ ! !$ write(0,*) 'Columns of ADAP',psb_sp_get_ncols(adap)
!!$ call dap%mv_to(csc_dap)
!!$ call dadap%mv_to(csc_dadap)
!!$
!!$ call csc_mat_col_prod(csc_dap,csc_dadap,omp,info)
!!$ call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info)
!!$ call psb_sum(ctxt,omp)
!!$ call psb_sum(ctxt,oden)
!!$ ! !$ write(0,*) trim(name),' OMP :',omp
!!$ ! !$ write(0,*) trim(name),' ODEN:',oden
!!$
!!$ omp = omp/oden
!!$
!!$ ! !$ write(0,*) 'Check on output prolongator ',omp(1:min(size(omp),10))
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done NUMBMM 1'
!!$
!!$ call am3%mv_to(acsr3)
!!$ ! Compute omega_int
!!$ ommx = czero
!!$ do i=1, ncol
!!$ if (ilaggr(i) >0) then
!!$ omi(i) = omp(ilaggr(i))
!!$ else
!!$ omi(i) = czero
!!$ end if
!!$ if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
!!$ end do
!!$ ! Compute omega_fine
!!$ do i=1, nrow
!!$ omf(i) = ommx
!!$ do j=acsr3%irp(i),acsr3%irp(i+1)-1
!!$ if(abs(omi(acsr3%ja(j))) .lt. abs(omf(i))) omf(i)=omi(acsr3%ja(j))
!!$ end do
!!$ ! ! if(min(real(omf(i)),aimag(omf(i))) < szero) omf(i) = czero
!!$ if(psb_minreal(omf(i)) < szero) omf(i) = czero
!!$ end do
!!$
!!$ omf(1:nrow) = omf(1:nrow) * adinv(1:nrow)
!!$
!!$ if (filter_mat) then
!!$ !
!!$ ! Build the filtered matrix Af from A
!!$ !
!!$ call la%cscnv(acsrf,info,dupl=psb_dupl_add_)
!!$
!!$ do i=1,nrow
!!$ tmp = czero
!!$ jd = -1
!!$ do j=acsrf%irp(i),acsrf%irp(i+1)-1
!!$ if (acsrf%ja(j) == i) jd = j
!!$ if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then
!!$ tmp=tmp+acsrf%val(j)
!!$ acsrf%val(j)=czero
!!$ endif
!!$ enddo
!!$ if (jd == -1) then
!!$ write(0,*) 'Wrong input: we need the diagonal!!!!', i
!!$ else
!!$ acsrf%val(jd)=acsrf%val(jd)-tmp
!!$ end if
!!$ enddo
!!$ ! Take out zeroed terms
!!$ call acsrf%clean_zeros(info)
!!$
!!$ !
!!$ ! Build the smoothed prolongator using the filtered matrix
!!$ !
!!$ do i=1,acsrf%get_nrows()
!!$ do j=acsrf%irp(i),acsrf%irp(i+1)-1
!!$ if (acsrf%ja(j) == i) then
!!$ acsrf%val(j) = cone - omf(i)*acsrf%val(j)
!!$ else
!!$ acsrf%val(j) = - omf(i)*acsrf%val(j)
!!$ end if
!!$ end do
!!$ end do
!!$
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done gather, going for SYMBMM 1'
!!$
!!$ call af%mv_from(acsrf)
!!$ !
!!$ ! op_prol = (I-w*D*Af)Ptilde
!!$ ! Doing it this way means to consider diag(Af_i)
!!$ !
!!$ !
!!$ call psb_spspmm(af,ptilde,op_prol,info)
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done SPSPMM 1'
!!$ else
!!$ !
!!$ ! Build the smoothed prolongator using the original matrix
!!$ !
!!$ do i=1,acsr3%get_nrows()
!!$ do j=acsr3%irp(i),acsr3%irp(i+1)-1
!!$ if (acsr3%ja(j) == i) then
!!$ acsr3%val(j) = cone - omf(i)*acsr3%val(j)
!!$ else
!!$ acsr3%val(j) = - omf(i)*acsr3%val(j)
!!$ end if
!!$ end do
!!$ end do
!!$
!!$ call am3%mv_from(acsr3)
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done gather, going for SYMBMM 1'
!!$ !
!!$ !
!!$ ! op_prol = (I-w*D*A)Ptilde
!!$ !
!!$ !
!!$ call psb_spspmm(am3,ptilde,op_prol,info)
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done NUMBMM 1'
!!$
!!$ end if
!!$
!!$
!!$ !
!!$ ! Ok, let's start over with the restrictor
!!$ !
!!$ call ptilde%transc(rtilde)
!!$ call la%cscnv(atmp,info,type='csr')
!!$ call psb_sphalo(atmp,desc_a,am4,info,&
!!$ & colcnv=.true.,rowscale=.true.)
!!$ nrt = am4%get_nrows()
!!$ call am4%csclip(atmp2,info,lone,nrt,lone,ncol)
!!$ call atmp2%cscnv(info,type='CSR')
!!$ if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2)
!!$ call am4%free()
!!$ call atmp2%free()
!!$
!!$ ! This is to compute the transpose. It ONLY works if the
!!$ ! original A has a symmetric pattern.
!!$ call atmp%transc(atmp2)
!!$ call atmp2%csclip(dat,info,lone,nrow,lone,ncol)
!!$ call dat%cscnv(info,type='csr')
!!$ call dat%scal(adinv,info)
!!$
!!$ ! Now for the product.
!!$ call psb_spspmm(dat,ptilde,datp,info)
!!$
!!$ call datp%clone(atmp2,info)
!!$ call psb_sphalo(atmp2,desc_a,am4,info,&
!!$ & colcnv=.false.,rowscale=.true.,outfmt='CSR ')
!!$ if (info == psb_success_) call psb_rwextd(ncol,atmp2,info,b=am4)
!!$ if (info == psb_success_) call am4%free()
!!$
!!$
!!$ call psb_symbmm(dat,atmp2,datdatp,info)
!!$ call psb_numbmm(dat,atmp2,datdatp)
!!$ call atmp2%free()
!!$
!!$ call datp%mv_to(csc_datp)
!!$ call datdatp%mv_to(csc_datdatp)
!!$
!!$ call csc_mat_col_prod(csc_datp,csc_datdatp,omp,info)
!!$ call csc_mat_col_prod(csc_datdatp,csc_datdatp,oden,info)
!!$ call psb_sum(ctxt,omp)
!!$ call psb_sum(ctxt,oden)
!!$
!!$
!!$ ! !$ write(debug_unit,*) trim(name),' OMP_R :',omp
!!$ ! ! $ write(debug_unit,*) trim(name),' ODEN_R:',oden
!!$ omp = omp/oden
!!$ ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10))
!!$ ! Compute omega_int
!!$ ommx = czero
!!$ do i=1, ncol
!!$ if (ilaggr(i) >0) then
!!$ omi(i) = omp(ilaggr(i))
!!$ else
!!$ omi(i) = czero
!!$ end if
!!$ if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
!!$ end do
!!$ ! Compute omega_fine
!!$ ! Going over the columns of atmp means going over the rows
!!$ ! of A^T. Hopefully ;-)
!!$ call atmp%cp_to(acsc)
!!$
!!$ do i=1, nrow
!!$ omf(i) = ommx
!!$ do j= acsc%icp(i),acsc%icp(i+1)-1
!!$ if(abs(omi(acsc%ia(j))) .lt. abs(omf(i))) omf(i)=omi(acsc%ia(j))
!!$ end do
!!$ ! ! if(min(real(omf(i)),aimag(omf(i))) < szero) omf(i) = czero
!!$ if(psb_minreal(omf(i)) < szero) omf(i) = czero
!!$ end do
!!$ omf(1:nrow) = omf(1:nrow)*adinv(1:nrow)
!!$ call psb_halo(omf,desc_a,info)
!!$ call acsc%free()
!!$
!!$
!!$ call atmp%mv_to(acsr1)
!!$
!!$ do i=1,acsr1%get_nrows()
!!$ do j=acsr1%irp(i),acsr1%irp(i+1)-1
!!$ if (acsr1%ja(j) == i) then
!!$ acsr1%val(j) = cone - acsr1%val(j)*omf(acsr1%ja(j))
!!$ else
!!$ acsr1%val(j) = - acsr1%val(j)*omf(acsr1%ja(j))
!!$ end if
!!$ end do
!!$ end do
!!$ call atmp%mv_from(acsr1)
!!$
!!$ call rtilde%mv_to(tmpcoo)
!!$ nzl = tmpcoo%get_nzeros()
!!$ i=0
!!$ do k=1, nzl
!!$ if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then
!!$ i = i+1
!!$ tmpcoo%val(i) = tmpcoo%val(k)
!!$ tmpcoo%ia(i) = tmpcoo%ia(k)
!!$ tmpcoo%ja(i) = tmpcoo%ja(k)
!!$ end if
!!$ end do
!!$ call tmpcoo%set_nzeros(i)
!!$ call rtilde%mv_from(tmpcoo)
!!$ call rtilde%cscnv(info,type='csr')
!!$
!!$ call psb_spspmm(rtilde,atmp,op_restr,info)
!!$
!!$ !
!!$ ! Now we have to gather the halo of op_prol, and add it to itself
!!$ ! to multiply it by A,
!!$ !
!!$ call op_prol%clone(tmp_prol,info)
!!$ if (info == psb_success_) call psb_sphalo(tmp_prol,desc_a,am4,info,&
!!$ & colcnv=.false.,rowscale=.true.)
!!$ if (info == psb_success_) call psb_rwextd(ncol,tmp_prol,info,b=am4)
!!$ if (info == psb_success_) call am4%free()
!!$
!!$ if(info /= psb_success_) then
!!$ call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol')
!!$ goto 9999
!!$ end if
!!$
!!$ !
!!$ ! Now we have to fix this. The only rows of B that are correct
!!$ ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
!!$ !
!!$ call op_restr%mv_to(tmpcoo)
!!$
!!$ nzl = tmpcoo%get_nzeros()
!!$ i=0
!!$ do k=1, nzl
!!$ if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then
!!$ i = i+1
!!$ tmpcoo%val(i) = tmpcoo%val(k)
!!$ tmpcoo%ia(i) = tmpcoo%ia(k)
!!$ tmpcoo%ja(i) = tmpcoo%ja(k)
!!$ end if
!!$ end do
!!$ call tmpcoo%set_nzeros(i)
!!$ call op_restr%mv_from(tmpcoo)
!!$ call op_restr%cscnv(info,type='csr')
!!$
!!$
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'starting sphalo/ rwxtd'
!!$
!!$ call psb_spspmm(la,tmp_prol,am3,info)
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done SPSPMM 2'
!!$
!!$ call psb_sphalo(am3,desc_a,am4,info,&
!!$ & colcnv=.false.,rowscale=.true.)
!!$ if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4)
!!$ if (info == psb_success_) call am4%free()
!!$
!!$ if(info /= psb_success_) then
!!$ call psb_errpush(psb_err_internal_error_,name,&
!!$ & a_err='Extend am3')
!!$ goto 9999
!!$ end if
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done sphalo/ rwxtd'
!!$
!!$ call psb_spspmm(op_restr,am3,ac,info)
!!$ if (info == psb_success_) call am3%free()
!!$ if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
!!$
!!$ if (info /= psb_success_) then
!!$ call psb_errpush(psb_err_internal_error_,name,&
!!$ &a_err='Build ac = op_restr x am3')
!!$ goto 9999
!!$ end if
amgprec/impl/aggregator/amg_caggrmat_smth_bld.f90
+1 -1
View File
@@ -116,7 +116,7 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_sml_parms), intent(inout) :: parms
type(psb_cspmat_type), intent(out) :: op_prol,ac,op_restr
type(psb_cspmat_type), intent(inout) :: op_prol,ac,op_restr
type(psb_lcspmat_type), intent(inout) :: t_prol
type(psb_desc_type), intent(inout) :: desc_ac
integer(psb_ipk_), intent(out) :: info
amgprec/impl/aggregator/amg_d_dec_aggregator_tprol.f90
+2 -2
View File
@@ -83,8 +83,8 @@ subroutine amg_d_dec_aggregator_build_tprol(ag,parms,ag_data,&
class(amg_d_dec_aggregator_type), target, intent(inout) :: ag
type(amg_dml_parms), intent(inout) :: parms
type(amg_daggr_data), intent(in) :: ag_data
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_dspmat_type), intent(inout) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_ldspmat_type), intent(out) :: t_prol
integer(psb_ipk_), intent(out) :: info
amgprec/impl/aggregator/amg_d_parmatch_aggregator_tprol.F90
+17 -21
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
@@ -58,7 +58,7 @@ subroutine amg_d_parmatch_aggregator_build_tprol(ag,parms,ag_data,&
type(amg_dml_parms), intent(inout) :: parms
type(amg_daggr_data), intent(in) :: ag_data
type(psb_dspmat_type), intent(inout) :: a
type(psb_desc_type), intent(inout) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_ldspmat_type), intent(out) :: t_prol
integer(psb_ipk_), intent(out) :: info
@@ -68,7 +68,8 @@ subroutine amg_d_parmatch_aggregator_build_tprol(ag,parms,ag_data,&
real(psb_dpk_), allocatable :: tmpw(:), tmpwnxt(:)
integer(psb_lpk_), allocatable :: ixaggr(:), nxaggr(:), tlaggr(:), ivr(:)
type(psb_dspmat_type) :: a_tmp
integer(c_int) :: match_algorithm, n_sweeps, max_csize, max_nlevels
integer(psb_ipk_) :: match_algorithm, n_sweeps
integer(psb_lpk_) :: target_csize
character(len=40) :: name, ch_err
character(len=80) :: fname, prefix_
type(psb_ctxt_type) :: ictxt
@@ -128,27 +129,22 @@ subroutine amg_d_parmatch_aggregator_build_tprol(ag,parms,ag_data,&
write(debug_unit, *) 'Warning: AGGR_SIZE reset to value ',2**n_sweeps
end if
end if
if (ag%max_csize > 0) then
max_csize = ag%max_csize
if (ag_data%target_coarse_size > 0) then
target_csize = ag_data%target_coarse_size
else
max_csize = ag_data%min_coarse_size
end if
if (ag%max_nlevels > 0) then
max_nlevels = ag%max_nlevels
else
max_nlevels = ag_data%max_levs
target_csize = ag_data%min_coarse_size
end if
if (.true.) then
block
integer(psb_ipk_) :: ipv(2)
ipv(1) = max_csize
ipv(1) = target_csize
ipv(2) = n_sweeps
call psb_bcast(ictxt,ipv)
max_csize = ipv(1)
target_csize = ipv(1)
n_sweeps = ipv(2)
end block
else
call psb_bcast(ictxt,max_csize)
call psb_bcast(ictxt,target_csize)
call psb_bcast(ictxt,n_sweeps)
end if
if (n_sweeps /= ag%n_sweeps) then
@@ -156,7 +152,7 @@ subroutine amg_d_parmatch_aggregator_build_tprol(ag,parms,ag_data,&
end if
!!$ if (me==0) write(0,*) 'Matching sweeps: ',n_sweeps
n_sweeps = max(1,n_sweeps)
if (debug) write(0,*) me,' Copies, with n_sweeps: ',n_sweeps,max_csize
if (debug) write(0,*) me,' Copies, with n_sweeps: ',n_sweeps,target_csize
if (ag%unsmoothed_hierarchy.and.allocated(ag%base_a)) then
call ag%base_a%cp_to(acsr)
if (ag%do_clean_zeros) call acsr%clean_zeros(info)
@@ -242,7 +238,7 @@ subroutine amg_d_parmatch_aggregator_build_tprol(ag,parms,ag_data,&
if (debug) then
call psb_barrier(ictxt)
if (me == 0) write(0,*) 'N_sweeps ',n_sweeps,nr,desc_acv(0)%is_ok(),max_csize
if (me == 0) write(0,*) 'N_sweeps ',n_sweeps,nr,desc_acv(0)%is_ok(),target_csize
end if
!
@@ -264,7 +260,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 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
@@ -300,11 +296,11 @@ subroutine amg_d_parmatch_aggregator_build_tprol(ag,parms,ag_data,&
if (debug) then
call psb_barrier(ictxt)
if (me==0) write(0,*) me,trim(name),' Done mat_asb:',i,sum(nxaggr),max_csize,info
if (me==0) write(0,*) me,trim(name),' Done mat_asb:',i,sum(nxaggr),target_csize,info
csz = sum(nxaggr)
call psb_bcast(ictxt,csz)
if (csz /= sum(nxaggr)) write(0,*) me,trim(name),' Mismatch matasb',&
& csz,sum(nxaggr),max_csize
& csz,sum(nxaggr),target_csize
end if
if (psb_errstatus_fatal()) write(0,*)me,trim(name),'Error fatal on entry to tmpwnxt 2'
@@ -342,10 +338,10 @@ subroutine amg_d_parmatch_aggregator_build_tprol(ag,parms,ag_data,&
call move_alloc(tmpwnxt,tmpw)
if (debug) then
if (csz /= sum(nlaggr)) write(0,*) me,trim(name),' Mismatch 2 matasb',&
& csz,sum(nlaggr),max_csize, info
& csz,sum(nlaggr),target_csize, info
end if
call acv(i-1)%free()
if ((sum(nlaggr) <= max_csize).or.(any(nlaggr==0))) then
if ((sum(nlaggr) <= target_csize).or.(any(nlaggr==0))) then
x_sweeps = i
exit sweeps_loop
end if
amgprec/impl/aggregator/amg_d_parmatch_smth_bld.F90
+1 -1
View File
@@ -122,7 +122,7 @@ subroutine amg_d_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_dml_parms), intent(inout) :: parms
type(psb_ldspmat_type), intent(inout) :: t_prol
type(psb_dspmat_type), intent(out) :: op_prol,ac,op_restr
type(psb_dspmat_type), intent(inout) :: op_prol,ac,op_restr
type(psb_desc_type), intent(inout) :: desc_ac
integer(psb_ipk_), intent(out) :: info
amgprec/impl/aggregator/amg_d_parmatch_spmm_bld.F90
+1 -1
View File
@@ -108,7 +108,7 @@ subroutine amg_d_parmatch_spmm_bld(a,desc_a,ilaggr,nlaggr,parms,&
! Arguments
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_dml_parms), intent(inout) :: parms
type(psb_ldspmat_type), intent(inout) :: t_prol
amgprec/impl/aggregator/amg_d_parmatch_spmm_bld_inner.F90
+2 -2
View File
@@ -108,11 +108,11 @@ subroutine amg_d_parmatch_spmm_bld_inner(a_csr,desc_a,ilaggr,nlaggr,parms,&
! Arguments
type(psb_d_csr_sparse_mat), intent(inout) :: a_csr
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_dml_parms), intent(inout) :: parms
type(psb_ldspmat_type), intent(inout) :: t_prol
type(psb_dspmat_type), intent(out) :: ac, op_prol, op_restr
type(psb_dspmat_type), intent(inout) :: ac, op_prol, op_restr
type(psb_desc_type), intent(out) :: desc_ac
integer(psb_ipk_), intent(out) :: info
amgprec/impl/aggregator/amg_d_parmatch_spmm_bld_ov.F90
+1 -1
View File
@@ -108,7 +108,7 @@ subroutine amg_d_parmatch_spmm_bld_ov(a,desc_a,ilaggr,nlaggr,parms,&
! Arguments
type(psb_dspmat_type), intent(inout) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_dml_parms), intent(inout) :: parms
type(psb_ldspmat_type), intent(inout) :: t_prol
amgprec/impl/aggregator/amg_d_symdec_aggregator_tprol.f90
+2 -2
View File
@@ -86,8 +86,8 @@ subroutine amg_d_symdec_aggregator_build_tprol(ag,parms,ag_data,&
class(amg_d_symdec_aggregator_type), target, intent(inout) :: ag
type(amg_dml_parms), intent(inout) :: parms
type(amg_daggr_data), intent(in) :: ag_data
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_dspmat_type), intent(inout) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_ldspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info
amgprec/impl/aggregator/amg_daggrmat_minnrg_bld.f90
+360 -358
View File
@@ -105,7 +105,7 @@
!
!
subroutine amg_daggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
& ac,desc_ac,op_prol,op_restr,info)
& ac,desc_ac,op_prol,op_restr,t_prol,info)
use psb_base_mod
use amg_base_prec_type
use amg_d_inner_mod, amg_protect_name => amg_daggrmat_minnrg_bld
@@ -117,8 +117,8 @@ subroutine amg_daggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_dml_parms), intent(inout) :: parms
type(psb_ldspmat_type), intent(inout) :: op_prol
type(psb_ldspmat_type), intent(out) :: ac,op_restr
type(psb_ldspmat_type), intent(inout) :: t_prol
type(psb_dspmat_type), intent(inout) :: op_prol, ac,op_restr
type(psb_desc_type), intent(inout) :: desc_ac
integer(psb_ipk_), intent(out) :: info
@@ -171,6 +171,8 @@ subroutine amg_daggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
filter_mat = (parms%aggr_filter == amg_filter_mat_)
!NEEDS TO BE REWORKED !!
! naggr: number of local aggregates
! nrow: local rows.
!
@@ -183,361 +185,361 @@ subroutine amg_daggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
goto 9999
end if
! Get the diagonal D
adiag = a%get_diag(info)
if (info == psb_success_) &
& call psb_realloc(ncol,adiag,info)
if (info == psb_success_) &
& call psb_halo(adiag,desc_a,info)
if (info == psb_success_) call a%cp_to_l(la)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
goto 9999
end if
do i=1,size(adiag)
if (adiag(i) /= dzero) then
adinv(i) = done / adiag(i)
else
adinv(i) = done
end if
end do
! 1. Allocate Ptilde in sparse matrix form
call op_prol%mv_to(tmpcoo)
call ptilde%mv_from(tmpcoo)
call ptilde%cscnv(info,type='csr')
if (info == psb_success_) call la%cscnv(am3,info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call la%cscnv(da,info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Initial copies done.'
call da%scal(adinv,info)
call psb_spspmm(da,ptilde,dap,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
goto 9999
end if
call dap%clone(atmp,info)
call psb_sphalo(atmp,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.,outfmt='CSR ')
if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=am4)
if (info == psb_success_) call am4%free()
call psb_spspmm(da,atmp,dadap,info)
call atmp%free()
! !$ write(0,*) 'Columns of AP',psb_sp_get_ncols(ap)
! !$ write(0,*) 'Columns of ADAP',psb_sp_get_ncols(adap)
call dap%mv_to(csc_dap)
call dadap%mv_to(csc_dadap)
call csc_mat_col_prod(csc_dap,csc_dadap,omp,info)
call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info)
call psb_sum(ctxt,omp)
call psb_sum(ctxt,oden)
! !$ write(0,*) trim(name),' OMP :',omp
! !$ write(0,*) trim(name),' ODEN:',oden
omp = omp/oden
! !$ write(0,*) 'Check on output prolongator ',omp(1:min(size(omp),10))
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
call am3%mv_to(acsr3)
! Compute omega_int
ommx = dzero
do i=1, ncol
if (ilaggr(i) >0) then
omi(i) = omp(ilaggr(i))
else
omi(i) = dzero
end if
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
end do
! Compute omega_fine
do i=1, nrow
omf(i) = ommx
do j=acsr3%irp(i),acsr3%irp(i+1)-1
if(abs(omi(acsr3%ja(j))) .lt. abs(omf(i))) omf(i)=omi(acsr3%ja(j))
end do
!!$ if(min(real(omf(i)),aimag(omf(i))) < dzero) omf(i) = dzero
if(psb_minreal(omf(i)) < dzero) omf(i) = dzero
end do
omf(1:nrow) = omf(1:nrow) * adinv(1:nrow)
if (filter_mat) then
!
! Build the filtered matrix Af from A
!
call la%cscnv(acsrf,info,dupl=psb_dupl_add_)
do i=1,nrow
tmp = dzero
jd = -1
do j=acsrf%irp(i),acsrf%irp(i+1)-1
if (acsrf%ja(j) == i) jd = j
if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then
tmp=tmp+acsrf%val(j)
acsrf%val(j)=dzero
endif
enddo
if (jd == -1) then
write(0,*) 'Wrong input: we need the diagonal!!!!', i
else
acsrf%val(jd)=acsrf%val(jd)-tmp
end if
enddo
! Take out zeroed terms
call acsrf%clean_zeros(info)
!
! Build the smoothed prolongator using the filtered matrix
!
do i=1,acsrf%get_nrows()
do j=acsrf%irp(i),acsrf%irp(i+1)-1
if (acsrf%ja(j) == i) then
acsrf%val(j) = done - omf(i)*acsrf%val(j)
else
acsrf%val(j) = - omf(i)*acsrf%val(j)
end if
end do
end do
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done gather, going for SYMBMM 1'
call af%mv_from(acsrf)
!
! op_prol = (I-w*D*Af)Ptilde
! Doing it this way means to consider diag(Af_i)
!
!
call psb_spspmm(af,ptilde,op_prol,info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done SPSPMM 1'
else
!
! Build the smoothed prolongator using the original matrix
!
do i=1,acsr3%get_nrows()
do j=acsr3%irp(i),acsr3%irp(i+1)-1
if (acsr3%ja(j) == i) then
acsr3%val(j) = done - omf(i)*acsr3%val(j)
else
acsr3%val(j) = - omf(i)*acsr3%val(j)
end if
end do
end do
call am3%mv_from(acsr3)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done gather, going for SYMBMM 1'
!
!
! op_prol = (I-w*D*A)Ptilde
!
!
call psb_spspmm(am3,ptilde,op_prol,info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
end if
!
! Ok, let's start over with the restrictor
!
call ptilde%transc(rtilde)
call la%cscnv(atmp,info,type='csr')
call psb_sphalo(atmp,desc_a,am4,info,&
& colcnv=.true.,rowscale=.true.)
nrt = am4%get_nrows()
call am4%csclip(atmp2,info,lone,nrt,lone,ncol)
call atmp2%cscnv(info,type='CSR')
if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2)
call am4%free()
call atmp2%free()
! This is to compute the transpose. It ONLY works if the
! original A has a symmetric pattern.
call atmp%transc(atmp2)
call atmp2%csclip(dat,info,lone,nrow,lone,ncol)
call dat%cscnv(info,type='csr')
call dat%scal(adinv,info)
! Now for the product.
call psb_spspmm(dat,ptilde,datp,info)
call datp%clone(atmp2,info)
call psb_sphalo(atmp2,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.,outfmt='CSR ')
if (info == psb_success_) call psb_rwextd(ncol,atmp2,info,b=am4)
if (info == psb_success_) call am4%free()
call psb_symbmm(dat,atmp2,datdatp,info)
call psb_numbmm(dat,atmp2,datdatp)
call atmp2%free()
call datp%mv_to(csc_datp)
call datdatp%mv_to(csc_datdatp)
call csc_mat_col_prod(csc_datp,csc_datdatp,omp,info)
call csc_mat_col_prod(csc_datdatp,csc_datdatp,oden,info)
call psb_sum(ctxt,omp)
call psb_sum(ctxt,oden)
! !$ write(debug_unit,*) trim(name),' OMP_R :',omp
! ! $ write(debug_unit,*) trim(name),' ODEN_R:',oden
omp = omp/oden
! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10))
! Compute omega_int
ommx = dzero
do i=1, ncol
if (ilaggr(i) >0) then
omi(i) = omp(ilaggr(i))
else
omi(i) = dzero
end if
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
end do
! Compute omega_fine
! Going over the columns of atmp means going over the rows
! of A^T. Hopefully ;-)
call atmp%cp_to(acsc)
do i=1, nrow
omf(i) = ommx
do j= acsc%icp(i),acsc%icp(i+1)-1
if(abs(omi(acsc%ia(j))) .lt. abs(omf(i))) omf(i)=omi(acsc%ia(j))
end do
!!$ if(min(real(omf(i)),aimag(omf(i))) < dzero) omf(i) = dzero
if(psb_minreal(omf(i)) < dzero) omf(i) = dzero
end do
omf(1:nrow) = omf(1:nrow)*adinv(1:nrow)
call psb_halo(omf,desc_a,info)
call acsc%free()
call atmp%mv_to(acsr1)
do i=1,acsr1%get_nrows()
do j=acsr1%irp(i),acsr1%irp(i+1)-1
if (acsr1%ja(j) == i) then
acsr1%val(j) = done - acsr1%val(j)*omf(acsr1%ja(j))
else
acsr1%val(j) = - acsr1%val(j)*omf(acsr1%ja(j))
end if
end do
end do
call atmp%mv_from(acsr1)
call rtilde%mv_to(tmpcoo)
nzl = tmpcoo%get_nzeros()
i=0
do k=1, nzl
if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then
i = i+1
tmpcoo%val(i) = tmpcoo%val(k)
tmpcoo%ia(i) = tmpcoo%ia(k)
tmpcoo%ja(i) = tmpcoo%ja(k)
end if
end do
call tmpcoo%set_nzeros(i)
call rtilde%mv_from(tmpcoo)
call rtilde%cscnv(info,type='csr')
call psb_spspmm(rtilde,atmp,op_restr,info)
!
! Now we have to gather the halo of op_prol, and add it to itself
! to multiply it by A,
!
call op_prol%clone(tmp_prol,info)
if (info == psb_success_) call psb_sphalo(tmp_prol,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.)
if (info == psb_success_) call psb_rwextd(ncol,tmp_prol,info,b=am4)
if (info == psb_success_) call am4%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol')
goto 9999
end if
!
! Now we have to fix this. The only rows of B that are correct
! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
!
call op_restr%mv_to(tmpcoo)
nzl = tmpcoo%get_nzeros()
i=0
do k=1, nzl
if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then
i = i+1
tmpcoo%val(i) = tmpcoo%val(k)
tmpcoo%ia(i) = tmpcoo%ia(k)
tmpcoo%ja(i) = tmpcoo%ja(k)
end if
end do
call tmpcoo%set_nzeros(i)
call op_restr%mv_from(tmpcoo)
call op_restr%cscnv(info,type='csr')
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd'
call psb_spspmm(la,tmp_prol,am3,info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done SPSPMM 2'
call psb_sphalo(am3,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.)
if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4)
if (info == psb_success_) call am4%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Extend am3')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done sphalo/ rwxtd'
call psb_spspmm(op_restr,am3,ac,info)
if (info == psb_success_) call am3%free()
if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
&a_err='Build ac = op_restr x am3')
goto 9999
end if
!!$ ! Get the diagonal D
!!$ adiag = a%get_diag(info)
!!$ if (info == psb_success_) &
!!$ & call psb_realloc(ncol,adiag,info)
!!$ if (info == psb_success_) &
!!$ & call psb_halo(adiag,desc_a,info)
!!$ if (info == psb_success_) call a%cp_to_l(la)
!!$ if (info /= psb_success_) then
!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
!!$ goto 9999
!!$ end if
!!$
!!$ do i=1,size(adiag)
!!$ if (adiag(i) /= dzero) then
!!$ adinv(i) = done / adiag(i)
!!$ else
!!$ adinv(i) = done
!!$ end if
!!$ end do
!!$
!!$
!!$
!!$ ! 1. Allocate Ptilde in sparse matrix form
!!$ call op_prol%mv_to(tmpcoo)
!!$ call ptilde%mv_from(tmpcoo)
!!$ call ptilde%cscnv(info,type='csr')
!!$
!!$ if (info == psb_success_) call la%cscnv(am3,info,type='csr',dupl=psb_dupl_add_)
!!$ if (info == psb_success_) call la%cscnv(da,info,type='csr',dupl=psb_dupl_add_)
!!$ if (info /= psb_success_) then
!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
!!$ goto 9999
!!$ end if
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' Initial copies done.'
!!$
!!$ call da%scal(adinv,info)
!!$
!!$ call psb_spspmm(da,ptilde,dap,info)
!!$
!!$ if(info /= psb_success_) then
!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
!!$ goto 9999
!!$ end if
!!$
!!$ call dap%clone(atmp,info)
!!$
!!$ call psb_sphalo(atmp,desc_a,am4,info,&
!!$ & colcnv=.false.,rowscale=.true.,outfmt='CSR ')
!!$ if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=am4)
!!$ if (info == psb_success_) call am4%free()
!!$
!!$ call psb_spspmm(da,atmp,dadap,info)
!!$ call atmp%free()
!!$
!!$ ! !$ write(0,*) 'Columns of AP',psb_sp_get_ncols(ap)
!!$ ! !$ write(0,*) 'Columns of ADAP',psb_sp_get_ncols(adap)
!!$ call dap%mv_to(csc_dap)
!!$ call dadap%mv_to(csc_dadap)
!!$
!!$ call csc_mat_col_prod(csc_dap,csc_dadap,omp,info)
!!$ call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info)
!!$ call psb_sum(ctxt,omp)
!!$ call psb_sum(ctxt,oden)
!!$ ! !$ write(0,*) trim(name),' OMP :',omp
!!$ ! !$ write(0,*) trim(name),' ODEN:',oden
!!$
!!$ omp = omp/oden
!!$
!!$ ! !$ write(0,*) 'Check on output prolongator ',omp(1:min(size(omp),10))
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done NUMBMM 1'
!!$
!!$ call am3%mv_to(acsr3)
!!$ ! Compute omega_int
!!$ ommx = dzero
!!$ do i=1, ncol
!!$ if (ilaggr(i) >0) then
!!$ omi(i) = omp(ilaggr(i))
!!$ else
!!$ omi(i) = dzero
!!$ end if
!!$ if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
!!$ end do
!!$ ! Compute omega_fine
!!$ do i=1, nrow
!!$ omf(i) = ommx
!!$ do j=acsr3%irp(i),acsr3%irp(i+1)-1
!!$ if(abs(omi(acsr3%ja(j))) .lt. abs(omf(i))) omf(i)=omi(acsr3%ja(j))
!!$ end do
!!$ ! ! if(min(real(omf(i)),aimag(omf(i))) < dzero) omf(i) = dzero
!!$ if(psb_minreal(omf(i)) < dzero) omf(i) = dzero
!!$ end do
!!$
!!$ omf(1:nrow) = omf(1:nrow) * adinv(1:nrow)
!!$
!!$ if (filter_mat) then
!!$ !
!!$ ! Build the filtered matrix Af from A
!!$ !
!!$ call la%cscnv(acsrf,info,dupl=psb_dupl_add_)
!!$
!!$ do i=1,nrow
!!$ tmp = dzero
!!$ jd = -1
!!$ do j=acsrf%irp(i),acsrf%irp(i+1)-1
!!$ if (acsrf%ja(j) == i) jd = j
!!$ if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then
!!$ tmp=tmp+acsrf%val(j)
!!$ acsrf%val(j)=dzero
!!$ endif
!!$ enddo
!!$ if (jd == -1) then
!!$ write(0,*) 'Wrong input: we need the diagonal!!!!', i
!!$ else
!!$ acsrf%val(jd)=acsrf%val(jd)-tmp
!!$ end if
!!$ enddo
!!$ ! Take out zeroed terms
!!$ call acsrf%clean_zeros(info)
!!$
!!$ !
!!$ ! Build the smoothed prolongator using the filtered matrix
!!$ !
!!$ do i=1,acsrf%get_nrows()
!!$ do j=acsrf%irp(i),acsrf%irp(i+1)-1
!!$ if (acsrf%ja(j) == i) then
!!$ acsrf%val(j) = done - omf(i)*acsrf%val(j)
!!$ else
!!$ acsrf%val(j) = - omf(i)*acsrf%val(j)
!!$ end if
!!$ end do
!!$ end do
!!$
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done gather, going for SYMBMM 1'
!!$
!!$ call af%mv_from(acsrf)
!!$ !
!!$ ! op_prol = (I-w*D*Af)Ptilde
!!$ ! Doing it this way means to consider diag(Af_i)
!!$ !
!!$ !
!!$ call psb_spspmm(af,ptilde,op_prol,info)
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done SPSPMM 1'
!!$ else
!!$ !
!!$ ! Build the smoothed prolongator using the original matrix
!!$ !
!!$ do i=1,acsr3%get_nrows()
!!$ do j=acsr3%irp(i),acsr3%irp(i+1)-1
!!$ if (acsr3%ja(j) == i) then
!!$ acsr3%val(j) = done - omf(i)*acsr3%val(j)
!!$ else
!!$ acsr3%val(j) = - omf(i)*acsr3%val(j)
!!$ end if
!!$ end do
!!$ end do
!!$
!!$ call am3%mv_from(acsr3)
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done gather, going for SYMBMM 1'
!!$ !
!!$ !
!!$ ! op_prol = (I-w*D*A)Ptilde
!!$ !
!!$ !
!!$ call psb_spspmm(am3,ptilde,op_prol,info)
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done NUMBMM 1'
!!$
!!$ end if
!!$
!!$
!!$ !
!!$ ! Ok, let's start over with the restrictor
!!$ !
!!$ call ptilde%transc(rtilde)
!!$ call la%cscnv(atmp,info,type='csr')
!!$ call psb_sphalo(atmp,desc_a,am4,info,&
!!$ & colcnv=.true.,rowscale=.true.)
!!$ nrt = am4%get_nrows()
!!$ call am4%csclip(atmp2,info,lone,nrt,lone,ncol)
!!$ call atmp2%cscnv(info,type='CSR')
!!$ if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2)
!!$ call am4%free()
!!$ call atmp2%free()
!!$
!!$ ! This is to compute the transpose. It ONLY works if the
!!$ ! original A has a symmetric pattern.
!!$ call atmp%transc(atmp2)
!!$ call atmp2%csclip(dat,info,lone,nrow,lone,ncol)
!!$ call dat%cscnv(info,type='csr')
!!$ call dat%scal(adinv,info)
!!$
!!$ ! Now for the product.
!!$ call psb_spspmm(dat,ptilde,datp,info)
!!$
!!$ call datp%clone(atmp2,info)
!!$ call psb_sphalo(atmp2,desc_a,am4,info,&
!!$ & colcnv=.false.,rowscale=.true.,outfmt='CSR ')
!!$ if (info == psb_success_) call psb_rwextd(ncol,atmp2,info,b=am4)
!!$ if (info == psb_success_) call am4%free()
!!$
!!$
!!$ call psb_symbmm(dat,atmp2,datdatp,info)
!!$ call psb_numbmm(dat,atmp2,datdatp)
!!$ call atmp2%free()
!!$
!!$ call datp%mv_to(csc_datp)
!!$ call datdatp%mv_to(csc_datdatp)
!!$
!!$ call csc_mat_col_prod(csc_datp,csc_datdatp,omp,info)
!!$ call csc_mat_col_prod(csc_datdatp,csc_datdatp,oden,info)
!!$ call psb_sum(ctxt,omp)
!!$ call psb_sum(ctxt,oden)
!!$
!!$
!!$ ! !$ write(debug_unit,*) trim(name),' OMP_R :',omp
!!$ ! ! $ write(debug_unit,*) trim(name),' ODEN_R:',oden
!!$ omp = omp/oden
!!$ ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10))
!!$ ! Compute omega_int
!!$ ommx = dzero
!!$ do i=1, ncol
!!$ if (ilaggr(i) >0) then
!!$ omi(i) = omp(ilaggr(i))
!!$ else
!!$ omi(i) = dzero
!!$ end if
!!$ if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
!!$ end do
!!$ ! Compute omega_fine
!!$ ! Going over the columns of atmp means going over the rows
!!$ ! of A^T. Hopefully ;-)
!!$ call atmp%cp_to(acsc)
!!$
!!$ do i=1, nrow
!!$ omf(i) = ommx
!!$ do j= acsc%icp(i),acsc%icp(i+1)-1
!!$ if(abs(omi(acsc%ia(j))) .lt. abs(omf(i))) omf(i)=omi(acsc%ia(j))
!!$ end do
!!$ ! ! if(min(real(omf(i)),aimag(omf(i))) < dzero) omf(i) = dzero
!!$ if(psb_minreal(omf(i)) < dzero) omf(i) = dzero
!!$ end do
!!$ omf(1:nrow) = omf(1:nrow)*adinv(1:nrow)
!!$ call psb_halo(omf,desc_a,info)
!!$ call acsc%free()
!!$
!!$
!!$ call atmp%mv_to(acsr1)
!!$
!!$ do i=1,acsr1%get_nrows()
!!$ do j=acsr1%irp(i),acsr1%irp(i+1)-1
!!$ if (acsr1%ja(j) == i) then
!!$ acsr1%val(j) = done - acsr1%val(j)*omf(acsr1%ja(j))
!!$ else
!!$ acsr1%val(j) = - acsr1%val(j)*omf(acsr1%ja(j))
!!$ end if
!!$ end do
!!$ end do
!!$ call atmp%mv_from(acsr1)
!!$
!!$ call rtilde%mv_to(tmpcoo)
!!$ nzl = tmpcoo%get_nzeros()
!!$ i=0
!!$ do k=1, nzl
!!$ if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then
!!$ i = i+1
!!$ tmpcoo%val(i) = tmpcoo%val(k)
!!$ tmpcoo%ia(i) = tmpcoo%ia(k)
!!$ tmpcoo%ja(i) = tmpcoo%ja(k)
!!$ end if
!!$ end do
!!$ call tmpcoo%set_nzeros(i)
!!$ call rtilde%mv_from(tmpcoo)
!!$ call rtilde%cscnv(info,type='csr')
!!$
!!$ call psb_spspmm(rtilde,atmp,op_restr,info)
!!$
!!$ !
!!$ ! Now we have to gather the halo of op_prol, and add it to itself
!!$ ! to multiply it by A,
!!$ !
!!$ call op_prol%clone(tmp_prol,info)
!!$ if (info == psb_success_) call psb_sphalo(tmp_prol,desc_a,am4,info,&
!!$ & colcnv=.false.,rowscale=.true.)
!!$ if (info == psb_success_) call psb_rwextd(ncol,tmp_prol,info,b=am4)
!!$ if (info == psb_success_) call am4%free()
!!$
!!$ if(info /= psb_success_) then
!!$ call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol')
!!$ goto 9999
!!$ end if
!!$
!!$ !
!!$ ! Now we have to fix this. The only rows of B that are correct
!!$ ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
!!$ !
!!$ call op_restr%mv_to(tmpcoo)
!!$
!!$ nzl = tmpcoo%get_nzeros()
!!$ i=0
!!$ do k=1, nzl
!!$ if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then
!!$ i = i+1
!!$ tmpcoo%val(i) = tmpcoo%val(k)
!!$ tmpcoo%ia(i) = tmpcoo%ia(k)
!!$ tmpcoo%ja(i) = tmpcoo%ja(k)
!!$ end if
!!$ end do
!!$ call tmpcoo%set_nzeros(i)
!!$ call op_restr%mv_from(tmpcoo)
!!$ call op_restr%cscnv(info,type='csr')
!!$
!!$
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'starting sphalo/ rwxtd'
!!$
!!$ call psb_spspmm(la,tmp_prol,am3,info)
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done SPSPMM 2'
!!$
!!$ call psb_sphalo(am3,desc_a,am4,info,&
!!$ & colcnv=.false.,rowscale=.true.)
!!$ if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4)
!!$ if (info == psb_success_) call am4%free()
!!$
!!$ if(info /= psb_success_) then
!!$ call psb_errpush(psb_err_internal_error_,name,&
!!$ & a_err='Extend am3')
!!$ goto 9999
!!$ end if
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done sphalo/ rwxtd'
!!$
!!$ call psb_spspmm(op_restr,am3,ac,info)
!!$ if (info == psb_success_) call am3%free()
!!$ if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
!!$
!!$ if (info /= psb_success_) then
!!$ call psb_errpush(psb_err_internal_error_,name,&
!!$ &a_err='Build ac = op_restr x am3')
!!$ goto 9999
!!$ end if
amgprec/impl/aggregator/amg_daggrmat_smth_bld.f90
+1 -1
View File
@@ -116,7 +116,7 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_dml_parms), intent(inout) :: parms
type(psb_dspmat_type), intent(out) :: op_prol,ac,op_restr
type(psb_dspmat_type), intent(inout) :: op_prol,ac,op_restr
type(psb_ldspmat_type), intent(inout) :: t_prol
type(psb_desc_type), intent(inout) :: desc_ac
integer(psb_ipk_), intent(out) :: info
amgprec/impl/aggregator/amg_s_dec_aggregator_tprol.f90
+2 -2
View File
@@ -83,8 +83,8 @@ subroutine amg_s_dec_aggregator_build_tprol(ag,parms,ag_data,&
class(amg_s_dec_aggregator_type), target, intent(inout) :: ag
type(amg_sml_parms), intent(inout) :: parms
type(amg_saggr_data), intent(in) :: ag_data
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_sspmat_type), intent(inout) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_lsspmat_type), intent(out) :: t_prol
integer(psb_ipk_), intent(out) :: info
amgprec/impl/aggregator/amg_s_parmatch_aggregator_tprol.F90
+17 -21
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
@@ -58,7 +58,7 @@ subroutine amg_s_parmatch_aggregator_build_tprol(ag,parms,ag_data,&
type(amg_sml_parms), intent(inout) :: parms
type(amg_saggr_data), intent(in) :: ag_data
type(psb_sspmat_type), intent(inout) :: a
type(psb_desc_type), intent(inout) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_lsspmat_type), intent(out) :: t_prol
integer(psb_ipk_), intent(out) :: info
@@ -68,7 +68,8 @@ subroutine amg_s_parmatch_aggregator_build_tprol(ag,parms,ag_data,&
real(psb_spk_), allocatable :: tmpw(:), tmpwnxt(:)
integer(psb_lpk_), allocatable :: ixaggr(:), nxaggr(:), tlaggr(:), ivr(:)
type(psb_sspmat_type) :: a_tmp
integer(c_int) :: match_algorithm, n_sweeps, max_csize, max_nlevels
integer(psb_ipk_) :: match_algorithm, n_sweeps
integer(psb_lpk_) :: target_csize
character(len=40) :: name, ch_err
character(len=80) :: fname, prefix_
type(psb_ctxt_type) :: ictxt
@@ -128,27 +129,22 @@ subroutine amg_s_parmatch_aggregator_build_tprol(ag,parms,ag_data,&
write(debug_unit, *) 'Warning: AGGR_SIZE reset to value ',2**n_sweeps
end if
end if
if (ag%max_csize > 0) then
max_csize = ag%max_csize
if (ag_data%target_coarse_size > 0) then
target_csize = ag_data%target_coarse_size
else
max_csize = ag_data%min_coarse_size
end if
if (ag%max_nlevels > 0) then
max_nlevels = ag%max_nlevels
else
max_nlevels = ag_data%max_levs
target_csize = ag_data%min_coarse_size
end if
if (.true.) then
block
integer(psb_ipk_) :: ipv(2)
ipv(1) = max_csize
ipv(1) = target_csize
ipv(2) = n_sweeps
call psb_bcast(ictxt,ipv)
max_csize = ipv(1)
target_csize = ipv(1)
n_sweeps = ipv(2)
end block
else
call psb_bcast(ictxt,max_csize)
call psb_bcast(ictxt,target_csize)
call psb_bcast(ictxt,n_sweeps)
end if
if (n_sweeps /= ag%n_sweeps) then
@@ -156,7 +152,7 @@ subroutine amg_s_parmatch_aggregator_build_tprol(ag,parms,ag_data,&
end if
!!$ if (me==0) write(0,*) 'Matching sweeps: ',n_sweeps
n_sweeps = max(1,n_sweeps)
if (debug) write(0,*) me,' Copies, with n_sweeps: ',n_sweeps,max_csize
if (debug) write(0,*) me,' Copies, with n_sweeps: ',n_sweeps,target_csize
if (ag%unsmoothed_hierarchy.and.allocated(ag%base_a)) then
call ag%base_a%cp_to(acsr)
if (ag%do_clean_zeros) call acsr%clean_zeros(info)
@@ -242,7 +238,7 @@ subroutine amg_s_parmatch_aggregator_build_tprol(ag,parms,ag_data,&
if (debug) then
call psb_barrier(ictxt)
if (me == 0) write(0,*) 'N_sweeps ',n_sweeps,nr,desc_acv(0)%is_ok(),max_csize
if (me == 0) write(0,*) 'N_sweeps ',n_sweeps,nr,desc_acv(0)%is_ok(),target_csize
end if
!
@@ -264,7 +260,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 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
@@ -300,11 +296,11 @@ subroutine amg_s_parmatch_aggregator_build_tprol(ag,parms,ag_data,&
if (debug) then
call psb_barrier(ictxt)
if (me==0) write(0,*) me,trim(name),' Done mat_asb:',i,sum(nxaggr),max_csize,info
if (me==0) write(0,*) me,trim(name),' Done mat_asb:',i,sum(nxaggr),target_csize,info
csz = sum(nxaggr)
call psb_bcast(ictxt,csz)
if (csz /= sum(nxaggr)) write(0,*) me,trim(name),' Mismatch matasb',&
& csz,sum(nxaggr),max_csize
& csz,sum(nxaggr),target_csize
end if
if (psb_errstatus_fatal()) write(0,*)me,trim(name),'Error fatal on entry to tmpwnxt 2'
@@ -342,10 +338,10 @@ subroutine amg_s_parmatch_aggregator_build_tprol(ag,parms,ag_data,&
call move_alloc(tmpwnxt,tmpw)
if (debug) then
if (csz /= sum(nlaggr)) write(0,*) me,trim(name),' Mismatch 2 matasb',&
& csz,sum(nlaggr),max_csize, info
& csz,sum(nlaggr),target_csize, info
end if
call acv(i-1)%free()
if ((sum(nlaggr) <= max_csize).or.(any(nlaggr==0))) then
if ((sum(nlaggr) <= target_csize).or.(any(nlaggr==0))) then
x_sweeps = i
exit sweeps_loop
end if
amgprec/impl/aggregator/amg_s_parmatch_smth_bld.F90
+1 -1
View File
@@ -122,7 +122,7 @@ subroutine amg_s_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_sml_parms), intent(inout) :: parms
type(psb_lsspmat_type), intent(inout) :: t_prol
type(psb_sspmat_type), intent(out) :: op_prol,ac,op_restr
type(psb_sspmat_type), intent(inout) :: op_prol,ac,op_restr
type(psb_desc_type), intent(inout) :: desc_ac
integer(psb_ipk_), intent(out) :: info
amgprec/impl/aggregator/amg_s_parmatch_spmm_bld.F90
+1 -1
View File
@@ -108,7 +108,7 @@ subroutine amg_s_parmatch_spmm_bld(a,desc_a,ilaggr,nlaggr,parms,&
! Arguments
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_sml_parms), intent(inout) :: parms
type(psb_lsspmat_type), intent(inout) :: t_prol
amgprec/impl/aggregator/amg_s_parmatch_spmm_bld_inner.F90
+2 -2
View File
@@ -108,11 +108,11 @@ subroutine amg_s_parmatch_spmm_bld_inner(a_csr,desc_a,ilaggr,nlaggr,parms,&
! Arguments
type(psb_s_csr_sparse_mat), intent(inout) :: a_csr
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_sml_parms), intent(inout) :: parms
type(psb_lsspmat_type), intent(inout) :: t_prol
type(psb_sspmat_type), intent(out) :: ac, op_prol, op_restr
type(psb_sspmat_type), intent(inout) :: ac, op_prol, op_restr
type(psb_desc_type), intent(out) :: desc_ac
integer(psb_ipk_), intent(out) :: info
amgprec/impl/aggregator/amg_s_parmatch_spmm_bld_ov.F90
+1 -1
View File
@@ -108,7 +108,7 @@ subroutine amg_s_parmatch_spmm_bld_ov(a,desc_a,ilaggr,nlaggr,parms,&
! Arguments
type(psb_sspmat_type), intent(inout) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_sml_parms), intent(inout) :: parms
type(psb_lsspmat_type), intent(inout) :: t_prol
amgprec/impl/aggregator/amg_s_symdec_aggregator_tprol.f90
+2 -2
View File
@@ -86,8 +86,8 @@ subroutine amg_s_symdec_aggregator_build_tprol(ag,parms,ag_data,&
class(amg_s_symdec_aggregator_type), target, intent(inout) :: ag
type(amg_sml_parms), intent(inout) :: parms
type(amg_saggr_data), intent(in) :: ag_data
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_sspmat_type), intent(inout) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_lsspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info
amgprec/impl/aggregator/amg_saggrmat_minnrg_bld.f90
+360 -358
View File
@@ -105,7 +105,7 @@
!
!
subroutine amg_saggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
& ac,desc_ac,op_prol,op_restr,info)
& ac,desc_ac,op_prol,op_restr,t_prol,info)
use psb_base_mod
use amg_base_prec_type
use amg_s_inner_mod, amg_protect_name => amg_saggrmat_minnrg_bld
@@ -117,8 +117,8 @@ subroutine amg_saggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_sml_parms), intent(inout) :: parms
type(psb_lsspmat_type), intent(inout) :: op_prol
type(psb_lsspmat_type), intent(out) :: ac,op_restr
type(psb_lsspmat_type), intent(inout) :: t_prol
type(psb_sspmat_type), intent(inout) :: op_prol, ac,op_restr
type(psb_desc_type), intent(inout) :: desc_ac
integer(psb_ipk_), intent(out) :: info
@@ -171,6 +171,8 @@ subroutine amg_saggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
filter_mat = (parms%aggr_filter == amg_filter_mat_)
!NEEDS TO BE REWORKED !!
! naggr: number of local aggregates
! nrow: local rows.
!
@@ -183,361 +185,361 @@ subroutine amg_saggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
goto 9999
end if
! Get the diagonal D
adiag = a%get_diag(info)
if (info == psb_success_) &
& call psb_realloc(ncol,adiag,info)
if (info == psb_success_) &
& call psb_halo(adiag,desc_a,info)
if (info == psb_success_) call a%cp_to_l(la)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
goto 9999
end if
do i=1,size(adiag)
if (adiag(i) /= szero) then
adinv(i) = sone / adiag(i)
else
adinv(i) = sone
end if
end do
! 1. Allocate Ptilde in sparse matrix form
call op_prol%mv_to(tmpcoo)
call ptilde%mv_from(tmpcoo)
call ptilde%cscnv(info,type='csr')
if (info == psb_success_) call la%cscnv(am3,info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call la%cscnv(da,info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Initial copies done.'
call da%scal(adinv,info)
call psb_spspmm(da,ptilde,dap,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
goto 9999
end if
call dap%clone(atmp,info)
call psb_sphalo(atmp,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.,outfmt='CSR ')
if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=am4)
if (info == psb_success_) call am4%free()
call psb_spspmm(da,atmp,dadap,info)
call atmp%free()
! !$ write(0,*) 'Columns of AP',psb_sp_get_ncols(ap)
! !$ write(0,*) 'Columns of ADAP',psb_sp_get_ncols(adap)
call dap%mv_to(csc_dap)
call dadap%mv_to(csc_dadap)
call csc_mat_col_prod(csc_dap,csc_dadap,omp,info)
call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info)
call psb_sum(ctxt,omp)
call psb_sum(ctxt,oden)
! !$ write(0,*) trim(name),' OMP :',omp
! !$ write(0,*) trim(name),' ODEN:',oden
omp = omp/oden
! !$ write(0,*) 'Check on output prolongator ',omp(1:min(size(omp),10))
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
call am3%mv_to(acsr3)
! Compute omega_int
ommx = szero
do i=1, ncol
if (ilaggr(i) >0) then
omi(i) = omp(ilaggr(i))
else
omi(i) = szero
end if
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
end do
! Compute omega_fine
do i=1, nrow
omf(i) = ommx
do j=acsr3%irp(i),acsr3%irp(i+1)-1
if(abs(omi(acsr3%ja(j))) .lt. abs(omf(i))) omf(i)=omi(acsr3%ja(j))
end do
!!$ if(min(real(omf(i)),aimag(omf(i))) < szero) omf(i) = szero
if(psb_minreal(omf(i)) < szero) omf(i) = szero
end do
omf(1:nrow) = omf(1:nrow) * adinv(1:nrow)
if (filter_mat) then
!
! Build the filtered matrix Af from A
!
call la%cscnv(acsrf,info,dupl=psb_dupl_add_)
do i=1,nrow
tmp = szero
jd = -1
do j=acsrf%irp(i),acsrf%irp(i+1)-1
if (acsrf%ja(j) == i) jd = j
if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then
tmp=tmp+acsrf%val(j)
acsrf%val(j)=szero
endif
enddo
if (jd == -1) then
write(0,*) 'Wrong input: we need the diagonal!!!!', i
else
acsrf%val(jd)=acsrf%val(jd)-tmp
end if
enddo
! Take out zeroed terms
call acsrf%clean_zeros(info)
!
! Build the smoothed prolongator using the filtered matrix
!
do i=1,acsrf%get_nrows()
do j=acsrf%irp(i),acsrf%irp(i+1)-1
if (acsrf%ja(j) == i) then
acsrf%val(j) = sone - omf(i)*acsrf%val(j)
else
acsrf%val(j) = - omf(i)*acsrf%val(j)
end if
end do
end do
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done gather, going for SYMBMM 1'
call af%mv_from(acsrf)
!
! op_prol = (I-w*D*Af)Ptilde
! Doing it this way means to consider diag(Af_i)
!
!
call psb_spspmm(af,ptilde,op_prol,info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done SPSPMM 1'
else
!
! Build the smoothed prolongator using the original matrix
!
do i=1,acsr3%get_nrows()
do j=acsr3%irp(i),acsr3%irp(i+1)-1
if (acsr3%ja(j) == i) then
acsr3%val(j) = sone - omf(i)*acsr3%val(j)
else
acsr3%val(j) = - omf(i)*acsr3%val(j)
end if
end do
end do
call am3%mv_from(acsr3)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done gather, going for SYMBMM 1'
!
!
! op_prol = (I-w*D*A)Ptilde
!
!
call psb_spspmm(am3,ptilde,op_prol,info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
end if
!
! Ok, let's start over with the restrictor
!
call ptilde%transc(rtilde)
call la%cscnv(atmp,info,type='csr')
call psb_sphalo(atmp,desc_a,am4,info,&
& colcnv=.true.,rowscale=.true.)
nrt = am4%get_nrows()
call am4%csclip(atmp2,info,lone,nrt,lone,ncol)
call atmp2%cscnv(info,type='CSR')
if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2)
call am4%free()
call atmp2%free()
! This is to compute the transpose. It ONLY works if the
! original A has a symmetric pattern.
call atmp%transc(atmp2)
call atmp2%csclip(dat,info,lone,nrow,lone,ncol)
call dat%cscnv(info,type='csr')
call dat%scal(adinv,info)
! Now for the product.
call psb_spspmm(dat,ptilde,datp,info)
call datp%clone(atmp2,info)
call psb_sphalo(atmp2,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.,outfmt='CSR ')
if (info == psb_success_) call psb_rwextd(ncol,atmp2,info,b=am4)
if (info == psb_success_) call am4%free()
call psb_symbmm(dat,atmp2,datdatp,info)
call psb_numbmm(dat,atmp2,datdatp)
call atmp2%free()
call datp%mv_to(csc_datp)
call datdatp%mv_to(csc_datdatp)
call csc_mat_col_prod(csc_datp,csc_datdatp,omp,info)
call csc_mat_col_prod(csc_datdatp,csc_datdatp,oden,info)
call psb_sum(ctxt,omp)
call psb_sum(ctxt,oden)
! !$ write(debug_unit,*) trim(name),' OMP_R :',omp
! ! $ write(debug_unit,*) trim(name),' ODEN_R:',oden
omp = omp/oden
! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10))
! Compute omega_int
ommx = szero
do i=1, ncol
if (ilaggr(i) >0) then
omi(i) = omp(ilaggr(i))
else
omi(i) = szero
end if
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
end do
! Compute omega_fine
! Going over the columns of atmp means going over the rows
! of A^T. Hopefully ;-)
call atmp%cp_to(acsc)
do i=1, nrow
omf(i) = ommx
do j= acsc%icp(i),acsc%icp(i+1)-1
if(abs(omi(acsc%ia(j))) .lt. abs(omf(i))) omf(i)=omi(acsc%ia(j))
end do
!!$ if(min(real(omf(i)),aimag(omf(i))) < szero) omf(i) = szero
if(psb_minreal(omf(i)) < szero) omf(i) = szero
end do
omf(1:nrow) = omf(1:nrow)*adinv(1:nrow)
call psb_halo(omf,desc_a,info)
call acsc%free()
call atmp%mv_to(acsr1)
do i=1,acsr1%get_nrows()
do j=acsr1%irp(i),acsr1%irp(i+1)-1
if (acsr1%ja(j) == i) then
acsr1%val(j) = sone - acsr1%val(j)*omf(acsr1%ja(j))
else
acsr1%val(j) = - acsr1%val(j)*omf(acsr1%ja(j))
end if
end do
end do
call atmp%mv_from(acsr1)
call rtilde%mv_to(tmpcoo)
nzl = tmpcoo%get_nzeros()
i=0
do k=1, nzl
if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then
i = i+1
tmpcoo%val(i) = tmpcoo%val(k)
tmpcoo%ia(i) = tmpcoo%ia(k)
tmpcoo%ja(i) = tmpcoo%ja(k)
end if
end do
call tmpcoo%set_nzeros(i)
call rtilde%mv_from(tmpcoo)
call rtilde%cscnv(info,type='csr')
call psb_spspmm(rtilde,atmp,op_restr,info)
!
! Now we have to gather the halo of op_prol, and add it to itself
! to multiply it by A,
!
call op_prol%clone(tmp_prol,info)
if (info == psb_success_) call psb_sphalo(tmp_prol,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.)
if (info == psb_success_) call psb_rwextd(ncol,tmp_prol,info,b=am4)
if (info == psb_success_) call am4%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol')
goto 9999
end if
!
! Now we have to fix this. The only rows of B that are correct
! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
!
call op_restr%mv_to(tmpcoo)
nzl = tmpcoo%get_nzeros()
i=0
do k=1, nzl
if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then
i = i+1
tmpcoo%val(i) = tmpcoo%val(k)
tmpcoo%ia(i) = tmpcoo%ia(k)
tmpcoo%ja(i) = tmpcoo%ja(k)
end if
end do
call tmpcoo%set_nzeros(i)
call op_restr%mv_from(tmpcoo)
call op_restr%cscnv(info,type='csr')
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd'
call psb_spspmm(la,tmp_prol,am3,info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done SPSPMM 2'
call psb_sphalo(am3,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.)
if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4)
if (info == psb_success_) call am4%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Extend am3')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done sphalo/ rwxtd'
call psb_spspmm(op_restr,am3,ac,info)
if (info == psb_success_) call am3%free()
if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
&a_err='Build ac = op_restr x am3')
goto 9999
end if
!!$ ! Get the diagonal D
!!$ adiag = a%get_diag(info)
!!$ if (info == psb_success_) &
!!$ & call psb_realloc(ncol,adiag,info)
!!$ if (info == psb_success_) &
!!$ & call psb_halo(adiag,desc_a,info)
!!$ if (info == psb_success_) call a%cp_to_l(la)
!!$ if (info /= psb_success_) then
!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
!!$ goto 9999
!!$ end if
!!$
!!$ do i=1,size(adiag)
!!$ if (adiag(i) /= szero) then
!!$ adinv(i) = sone / adiag(i)
!!$ else
!!$ adinv(i) = sone
!!$ end if
!!$ end do
!!$
!!$
!!$
!!$ ! 1. Allocate Ptilde in sparse matrix form
!!$ call op_prol%mv_to(tmpcoo)
!!$ call ptilde%mv_from(tmpcoo)
!!$ call ptilde%cscnv(info,type='csr')
!!$
!!$ if (info == psb_success_) call la%cscnv(am3,info,type='csr',dupl=psb_dupl_add_)
!!$ if (info == psb_success_) call la%cscnv(da,info,type='csr',dupl=psb_dupl_add_)
!!$ if (info /= psb_success_) then
!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
!!$ goto 9999
!!$ end if
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' Initial copies done.'
!!$
!!$ call da%scal(adinv,info)
!!$
!!$ call psb_spspmm(da,ptilde,dap,info)
!!$
!!$ if(info /= psb_success_) then
!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
!!$ goto 9999
!!$ end if
!!$
!!$ call dap%clone(atmp,info)
!!$
!!$ call psb_sphalo(atmp,desc_a,am4,info,&
!!$ & colcnv=.false.,rowscale=.true.,outfmt='CSR ')
!!$ if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=am4)
!!$ if (info == psb_success_) call am4%free()
!!$
!!$ call psb_spspmm(da,atmp,dadap,info)
!!$ call atmp%free()
!!$
!!$ ! !$ write(0,*) 'Columns of AP',psb_sp_get_ncols(ap)
!!$ ! !$ write(0,*) 'Columns of ADAP',psb_sp_get_ncols(adap)
!!$ call dap%mv_to(csc_dap)
!!$ call dadap%mv_to(csc_dadap)
!!$
!!$ call csc_mat_col_prod(csc_dap,csc_dadap,omp,info)
!!$ call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info)
!!$ call psb_sum(ctxt,omp)
!!$ call psb_sum(ctxt,oden)
!!$ ! !$ write(0,*) trim(name),' OMP :',omp
!!$ ! !$ write(0,*) trim(name),' ODEN:',oden
!!$
!!$ omp = omp/oden
!!$
!!$ ! !$ write(0,*) 'Check on output prolongator ',omp(1:min(size(omp),10))
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done NUMBMM 1'
!!$
!!$ call am3%mv_to(acsr3)
!!$ ! Compute omega_int
!!$ ommx = szero
!!$ do i=1, ncol
!!$ if (ilaggr(i) >0) then
!!$ omi(i) = omp(ilaggr(i))
!!$ else
!!$ omi(i) = szero
!!$ end if
!!$ if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
!!$ end do
!!$ ! Compute omega_fine
!!$ do i=1, nrow
!!$ omf(i) = ommx
!!$ do j=acsr3%irp(i),acsr3%irp(i+1)-1
!!$ if(abs(omi(acsr3%ja(j))) .lt. abs(omf(i))) omf(i)=omi(acsr3%ja(j))
!!$ end do
!!$ ! ! if(min(real(omf(i)),aimag(omf(i))) < szero) omf(i) = szero
!!$ if(psb_minreal(omf(i)) < szero) omf(i) = szero
!!$ end do
!!$
!!$ omf(1:nrow) = omf(1:nrow) * adinv(1:nrow)
!!$
!!$ if (filter_mat) then
!!$ !
!!$ ! Build the filtered matrix Af from A
!!$ !
!!$ call la%cscnv(acsrf,info,dupl=psb_dupl_add_)
!!$
!!$ do i=1,nrow
!!$ tmp = szero
!!$ jd = -1
!!$ do j=acsrf%irp(i),acsrf%irp(i+1)-1
!!$ if (acsrf%ja(j) == i) jd = j
!!$ if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then
!!$ tmp=tmp+acsrf%val(j)
!!$ acsrf%val(j)=szero
!!$ endif
!!$ enddo
!!$ if (jd == -1) then
!!$ write(0,*) 'Wrong input: we need the diagonal!!!!', i
!!$ else
!!$ acsrf%val(jd)=acsrf%val(jd)-tmp
!!$ end if
!!$ enddo
!!$ ! Take out zeroed terms
!!$ call acsrf%clean_zeros(info)
!!$
!!$ !
!!$ ! Build the smoothed prolongator using the filtered matrix
!!$ !
!!$ do i=1,acsrf%get_nrows()
!!$ do j=acsrf%irp(i),acsrf%irp(i+1)-1
!!$ if (acsrf%ja(j) == i) then
!!$ acsrf%val(j) = sone - omf(i)*acsrf%val(j)
!!$ else
!!$ acsrf%val(j) = - omf(i)*acsrf%val(j)
!!$ end if
!!$ end do
!!$ end do
!!$
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done gather, going for SYMBMM 1'
!!$
!!$ call af%mv_from(acsrf)
!!$ !
!!$ ! op_prol = (I-w*D*Af)Ptilde
!!$ ! Doing it this way means to consider diag(Af_i)
!!$ !
!!$ !
!!$ call psb_spspmm(af,ptilde,op_prol,info)
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done SPSPMM 1'
!!$ else
!!$ !
!!$ ! Build the smoothed prolongator using the original matrix
!!$ !
!!$ do i=1,acsr3%get_nrows()
!!$ do j=acsr3%irp(i),acsr3%irp(i+1)-1
!!$ if (acsr3%ja(j) == i) then
!!$ acsr3%val(j) = sone - omf(i)*acsr3%val(j)
!!$ else
!!$ acsr3%val(j) = - omf(i)*acsr3%val(j)
!!$ end if
!!$ end do
!!$ end do
!!$
!!$ call am3%mv_from(acsr3)
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done gather, going for SYMBMM 1'
!!$ !
!!$ !
!!$ ! op_prol = (I-w*D*A)Ptilde
!!$ !
!!$ !
!!$ call psb_spspmm(am3,ptilde,op_prol,info)
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done NUMBMM 1'
!!$
!!$ end if
!!$
!!$
!!$ !
!!$ ! Ok, let's start over with the restrictor
!!$ !
!!$ call ptilde%transc(rtilde)
!!$ call la%cscnv(atmp,info,type='csr')
!!$ call psb_sphalo(atmp,desc_a,am4,info,&
!!$ & colcnv=.true.,rowscale=.true.)
!!$ nrt = am4%get_nrows()
!!$ call am4%csclip(atmp2,info,lone,nrt,lone,ncol)
!!$ call atmp2%cscnv(info,type='CSR')
!!$ if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2)
!!$ call am4%free()
!!$ call atmp2%free()
!!$
!!$ ! This is to compute the transpose. It ONLY works if the
!!$ ! original A has a symmetric pattern.
!!$ call atmp%transc(atmp2)
!!$ call atmp2%csclip(dat,info,lone,nrow,lone,ncol)
!!$ call dat%cscnv(info,type='csr')
!!$ call dat%scal(adinv,info)
!!$
!!$ ! Now for the product.
!!$ call psb_spspmm(dat,ptilde,datp,info)
!!$
!!$ call datp%clone(atmp2,info)
!!$ call psb_sphalo(atmp2,desc_a,am4,info,&
!!$ & colcnv=.false.,rowscale=.true.,outfmt='CSR ')
!!$ if (info == psb_success_) call psb_rwextd(ncol,atmp2,info,b=am4)
!!$ if (info == psb_success_) call am4%free()
!!$
!!$
!!$ call psb_symbmm(dat,atmp2,datdatp,info)
!!$ call psb_numbmm(dat,atmp2,datdatp)
!!$ call atmp2%free()
!!$
!!$ call datp%mv_to(csc_datp)
!!$ call datdatp%mv_to(csc_datdatp)
!!$
!!$ call csc_mat_col_prod(csc_datp,csc_datdatp,omp,info)
!!$ call csc_mat_col_prod(csc_datdatp,csc_datdatp,oden,info)
!!$ call psb_sum(ctxt,omp)
!!$ call psb_sum(ctxt,oden)
!!$
!!$
!!$ ! !$ write(debug_unit,*) trim(name),' OMP_R :',omp
!!$ ! ! $ write(debug_unit,*) trim(name),' ODEN_R:',oden
!!$ omp = omp/oden
!!$ ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10))
!!$ ! Compute omega_int
!!$ ommx = szero
!!$ do i=1, ncol
!!$ if (ilaggr(i) >0) then
!!$ omi(i) = omp(ilaggr(i))
!!$ else
!!$ omi(i) = szero
!!$ end if
!!$ if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
!!$ end do
!!$ ! Compute omega_fine
!!$ ! Going over the columns of atmp means going over the rows
!!$ ! of A^T. Hopefully ;-)
!!$ call atmp%cp_to(acsc)
!!$
!!$ do i=1, nrow
!!$ omf(i) = ommx
!!$ do j= acsc%icp(i),acsc%icp(i+1)-1
!!$ if(abs(omi(acsc%ia(j))) .lt. abs(omf(i))) omf(i)=omi(acsc%ia(j))
!!$ end do
!!$ ! ! if(min(real(omf(i)),aimag(omf(i))) < szero) omf(i) = szero
!!$ if(psb_minreal(omf(i)) < szero) omf(i) = szero
!!$ end do
!!$ omf(1:nrow) = omf(1:nrow)*adinv(1:nrow)
!!$ call psb_halo(omf,desc_a,info)
!!$ call acsc%free()
!!$
!!$
!!$ call atmp%mv_to(acsr1)
!!$
!!$ do i=1,acsr1%get_nrows()
!!$ do j=acsr1%irp(i),acsr1%irp(i+1)-1
!!$ if (acsr1%ja(j) == i) then
!!$ acsr1%val(j) = sone - acsr1%val(j)*omf(acsr1%ja(j))
!!$ else
!!$ acsr1%val(j) = - acsr1%val(j)*omf(acsr1%ja(j))
!!$ end if
!!$ end do
!!$ end do
!!$ call atmp%mv_from(acsr1)
!!$
!!$ call rtilde%mv_to(tmpcoo)
!!$ nzl = tmpcoo%get_nzeros()
!!$ i=0
!!$ do k=1, nzl
!!$ if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then
!!$ i = i+1
!!$ tmpcoo%val(i) = tmpcoo%val(k)
!!$ tmpcoo%ia(i) = tmpcoo%ia(k)
!!$ tmpcoo%ja(i) = tmpcoo%ja(k)
!!$ end if
!!$ end do
!!$ call tmpcoo%set_nzeros(i)
!!$ call rtilde%mv_from(tmpcoo)
!!$ call rtilde%cscnv(info,type='csr')
!!$
!!$ call psb_spspmm(rtilde,atmp,op_restr,info)
!!$
!!$ !
!!$ ! Now we have to gather the halo of op_prol, and add it to itself
!!$ ! to multiply it by A,
!!$ !
!!$ call op_prol%clone(tmp_prol,info)
!!$ if (info == psb_success_) call psb_sphalo(tmp_prol,desc_a,am4,info,&
!!$ & colcnv=.false.,rowscale=.true.)
!!$ if (info == psb_success_) call psb_rwextd(ncol,tmp_prol,info,b=am4)
!!$ if (info == psb_success_) call am4%free()
!!$
!!$ if(info /= psb_success_) then
!!$ call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol')
!!$ goto 9999
!!$ end if
!!$
!!$ !
!!$ ! Now we have to fix this. The only rows of B that are correct
!!$ ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
!!$ !
!!$ call op_restr%mv_to(tmpcoo)
!!$
!!$ nzl = tmpcoo%get_nzeros()
!!$ i=0
!!$ do k=1, nzl
!!$ if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then
!!$ i = i+1
!!$ tmpcoo%val(i) = tmpcoo%val(k)
!!$ tmpcoo%ia(i) = tmpcoo%ia(k)
!!$ tmpcoo%ja(i) = tmpcoo%ja(k)
!!$ end if
!!$ end do
!!$ call tmpcoo%set_nzeros(i)
!!$ call op_restr%mv_from(tmpcoo)
!!$ call op_restr%cscnv(info,type='csr')
!!$
!!$
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'starting sphalo/ rwxtd'
!!$
!!$ call psb_spspmm(la,tmp_prol,am3,info)
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done SPSPMM 2'
!!$
!!$ call psb_sphalo(am3,desc_a,am4,info,&
!!$ & colcnv=.false.,rowscale=.true.)
!!$ if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4)
!!$ if (info == psb_success_) call am4%free()
!!$
!!$ if(info /= psb_success_) then
!!$ call psb_errpush(psb_err_internal_error_,name,&
!!$ & a_err='Extend am3')
!!$ goto 9999
!!$ end if
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done sphalo/ rwxtd'
!!$
!!$ call psb_spspmm(op_restr,am3,ac,info)
!!$ if (info == psb_success_) call am3%free()
!!$ if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
!!$
!!$ if (info /= psb_success_) then
!!$ call psb_errpush(psb_err_internal_error_,name,&
!!$ &a_err='Build ac = op_restr x am3')
!!$ goto 9999
!!$ end if
amgprec/impl/aggregator/amg_saggrmat_smth_bld.f90
+1 -1
View File
@@ -116,7 +116,7 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_sml_parms), intent(inout) :: parms
type(psb_sspmat_type), intent(out) :: op_prol,ac,op_restr
type(psb_sspmat_type), intent(inout) :: op_prol,ac,op_restr
type(psb_lsspmat_type), intent(inout) :: t_prol
type(psb_desc_type), intent(inout) :: desc_ac
integer(psb_ipk_), intent(out) :: info
amgprec/impl/aggregator/amg_z_dec_aggregator_tprol.f90
+2 -2
View File
@@ -83,8 +83,8 @@ subroutine amg_z_dec_aggregator_build_tprol(ag,parms,ag_data,&
class(amg_z_dec_aggregator_type), target, intent(inout) :: ag
type(amg_dml_parms), intent(inout) :: parms
type(amg_daggr_data), intent(in) :: ag_data
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_zspmat_type), intent(inout) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_lzspmat_type), intent(out) :: t_prol
integer(psb_ipk_), intent(out) :: info
amgprec/impl/aggregator/amg_z_symdec_aggregator_tprol.f90
+2 -2
View File
@@ -86,8 +86,8 @@ subroutine amg_z_symdec_aggregator_build_tprol(ag,parms,ag_data,&
class(amg_z_symdec_aggregator_type), target, intent(inout) :: ag
type(amg_dml_parms), intent(inout) :: parms
type(amg_daggr_data), intent(in) :: ag_data
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_zspmat_type), intent(inout) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_lzspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info
amgprec/impl/aggregator/amg_zaggrmat_minnrg_bld.f90
+360 -358
View File
@@ -105,7 +105,7 @@
!
!
subroutine amg_zaggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
& ac,desc_ac,op_prol,op_restr,info)
& ac,desc_ac,op_prol,op_restr,t_prol,info)
use psb_base_mod
use amg_base_prec_type
use amg_z_inner_mod, amg_protect_name => amg_zaggrmat_minnrg_bld
@@ -117,8 +117,8 @@ subroutine amg_zaggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_dml_parms), intent(inout) :: parms
type(psb_lzspmat_type), intent(inout) :: op_prol
type(psb_lzspmat_type), intent(out) :: ac,op_restr
type(psb_lzspmat_type), intent(inout) :: t_prol
type(psb_zspmat_type), intent(inout) :: op_prol, ac,op_restr
type(psb_desc_type), intent(inout) :: desc_ac
integer(psb_ipk_), intent(out) :: info
@@ -171,6 +171,8 @@ subroutine amg_zaggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
filter_mat = (parms%aggr_filter == amg_filter_mat_)
!NEEDS TO BE REWORKED !!
! naggr: number of local aggregates
! nrow: local rows.
!
@@ -183,361 +185,361 @@ subroutine amg_zaggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
goto 9999
end if
! Get the diagonal D
adiag = a%get_diag(info)
if (info == psb_success_) &
& call psb_realloc(ncol,adiag,info)
if (info == psb_success_) &
& call psb_halo(adiag,desc_a,info)
if (info == psb_success_) call a%cp_to_l(la)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
goto 9999
end if
do i=1,size(adiag)
if (adiag(i) /= zzero) then
adinv(i) = zone / adiag(i)
else
adinv(i) = zone
end if
end do
! 1. Allocate Ptilde in sparse matrix form
call op_prol%mv_to(tmpcoo)
call ptilde%mv_from(tmpcoo)
call ptilde%cscnv(info,type='csr')
if (info == psb_success_) call la%cscnv(am3,info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call la%cscnv(da,info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Initial copies done.'
call da%scal(adinv,info)
call psb_spspmm(da,ptilde,dap,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
goto 9999
end if
call dap%clone(atmp,info)
call psb_sphalo(atmp,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.,outfmt='CSR ')
if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=am4)
if (info == psb_success_) call am4%free()
call psb_spspmm(da,atmp,dadap,info)
call atmp%free()
! !$ write(0,*) 'Columns of AP',psb_sp_get_ncols(ap)
! !$ write(0,*) 'Columns of ADAP',psb_sp_get_ncols(adap)
call dap%mv_to(csc_dap)
call dadap%mv_to(csc_dadap)
call csc_mat_col_prod(csc_dap,csc_dadap,omp,info)
call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info)
call psb_sum(ctxt,omp)
call psb_sum(ctxt,oden)
! !$ write(0,*) trim(name),' OMP :',omp
! !$ write(0,*) trim(name),' ODEN:',oden
omp = omp/oden
! !$ write(0,*) 'Check on output prolongator ',omp(1:min(size(omp),10))
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
call am3%mv_to(acsr3)
! Compute omega_int
ommx = zzero
do i=1, ncol
if (ilaggr(i) >0) then
omi(i) = omp(ilaggr(i))
else
omi(i) = zzero
end if
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
end do
! Compute omega_fine
do i=1, nrow
omf(i) = ommx
do j=acsr3%irp(i),acsr3%irp(i+1)-1
if(abs(omi(acsr3%ja(j))) .lt. abs(omf(i))) omf(i)=omi(acsr3%ja(j))
end do
!!$ if(min(real(omf(i)),aimag(omf(i))) < dzero) omf(i) = zzero
if(psb_minreal(omf(i)) < dzero) omf(i) = zzero
end do
omf(1:nrow) = omf(1:nrow) * adinv(1:nrow)
if (filter_mat) then
!
! Build the filtered matrix Af from A
!
call la%cscnv(acsrf,info,dupl=psb_dupl_add_)
do i=1,nrow
tmp = zzero
jd = -1
do j=acsrf%irp(i),acsrf%irp(i+1)-1
if (acsrf%ja(j) == i) jd = j
if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then
tmp=tmp+acsrf%val(j)
acsrf%val(j)=zzero
endif
enddo
if (jd == -1) then
write(0,*) 'Wrong input: we need the diagonal!!!!', i
else
acsrf%val(jd)=acsrf%val(jd)-tmp
end if
enddo
! Take out zeroed terms
call acsrf%clean_zeros(info)
!
! Build the smoothed prolongator using the filtered matrix
!
do i=1,acsrf%get_nrows()
do j=acsrf%irp(i),acsrf%irp(i+1)-1
if (acsrf%ja(j) == i) then
acsrf%val(j) = zone - omf(i)*acsrf%val(j)
else
acsrf%val(j) = - omf(i)*acsrf%val(j)
end if
end do
end do
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done gather, going for SYMBMM 1'
call af%mv_from(acsrf)
!
! op_prol = (I-w*D*Af)Ptilde
! Doing it this way means to consider diag(Af_i)
!
!
call psb_spspmm(af,ptilde,op_prol,info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done SPSPMM 1'
else
!
! Build the smoothed prolongator using the original matrix
!
do i=1,acsr3%get_nrows()
do j=acsr3%irp(i),acsr3%irp(i+1)-1
if (acsr3%ja(j) == i) then
acsr3%val(j) = zone - omf(i)*acsr3%val(j)
else
acsr3%val(j) = - omf(i)*acsr3%val(j)
end if
end do
end do
call am3%mv_from(acsr3)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done gather, going for SYMBMM 1'
!
!
! op_prol = (I-w*D*A)Ptilde
!
!
call psb_spspmm(am3,ptilde,op_prol,info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
end if
!
! Ok, let's start over with the restrictor
!
call ptilde%transc(rtilde)
call la%cscnv(atmp,info,type='csr')
call psb_sphalo(atmp,desc_a,am4,info,&
& colcnv=.true.,rowscale=.true.)
nrt = am4%get_nrows()
call am4%csclip(atmp2,info,lone,nrt,lone,ncol)
call atmp2%cscnv(info,type='CSR')
if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2)
call am4%free()
call atmp2%free()
! This is to compute the transpose. It ONLY works if the
! original A has a symmetric pattern.
call atmp%transc(atmp2)
call atmp2%csclip(dat,info,lone,nrow,lone,ncol)
call dat%cscnv(info,type='csr')
call dat%scal(adinv,info)
! Now for the product.
call psb_spspmm(dat,ptilde,datp,info)
call datp%clone(atmp2,info)
call psb_sphalo(atmp2,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.,outfmt='CSR ')
if (info == psb_success_) call psb_rwextd(ncol,atmp2,info,b=am4)
if (info == psb_success_) call am4%free()
call psb_symbmm(dat,atmp2,datdatp,info)
call psb_numbmm(dat,atmp2,datdatp)
call atmp2%free()
call datp%mv_to(csc_datp)
call datdatp%mv_to(csc_datdatp)
call csc_mat_col_prod(csc_datp,csc_datdatp,omp,info)
call csc_mat_col_prod(csc_datdatp,csc_datdatp,oden,info)
call psb_sum(ctxt,omp)
call psb_sum(ctxt,oden)
! !$ write(debug_unit,*) trim(name),' OMP_R :',omp
! ! $ write(debug_unit,*) trim(name),' ODEN_R:',oden
omp = omp/oden
! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10))
! Compute omega_int
ommx = zzero
do i=1, ncol
if (ilaggr(i) >0) then
omi(i) = omp(ilaggr(i))
else
omi(i) = zzero
end if
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
end do
! Compute omega_fine
! Going over the columns of atmp means going over the rows
! of A^T. Hopefully ;-)
call atmp%cp_to(acsc)
do i=1, nrow
omf(i) = ommx
do j= acsc%icp(i),acsc%icp(i+1)-1
if(abs(omi(acsc%ia(j))) .lt. abs(omf(i))) omf(i)=omi(acsc%ia(j))
end do
!!$ if(min(real(omf(i)),aimag(omf(i))) < dzero) omf(i) = zzero
if(psb_minreal(omf(i)) < dzero) omf(i) = zzero
end do
omf(1:nrow) = omf(1:nrow)*adinv(1:nrow)
call psb_halo(omf,desc_a,info)
call acsc%free()
call atmp%mv_to(acsr1)
do i=1,acsr1%get_nrows()
do j=acsr1%irp(i),acsr1%irp(i+1)-1
if (acsr1%ja(j) == i) then
acsr1%val(j) = zone - acsr1%val(j)*omf(acsr1%ja(j))
else
acsr1%val(j) = - acsr1%val(j)*omf(acsr1%ja(j))
end if
end do
end do
call atmp%mv_from(acsr1)
call rtilde%mv_to(tmpcoo)
nzl = tmpcoo%get_nzeros()
i=0
do k=1, nzl
if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then
i = i+1
tmpcoo%val(i) = tmpcoo%val(k)
tmpcoo%ia(i) = tmpcoo%ia(k)
tmpcoo%ja(i) = tmpcoo%ja(k)
end if
end do
call tmpcoo%set_nzeros(i)
call rtilde%mv_from(tmpcoo)
call rtilde%cscnv(info,type='csr')
call psb_spspmm(rtilde,atmp,op_restr,info)
!
! Now we have to gather the halo of op_prol, and add it to itself
! to multiply it by A,
!
call op_prol%clone(tmp_prol,info)
if (info == psb_success_) call psb_sphalo(tmp_prol,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.)
if (info == psb_success_) call psb_rwextd(ncol,tmp_prol,info,b=am4)
if (info == psb_success_) call am4%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol')
goto 9999
end if
!
! Now we have to fix this. The only rows of B that are correct
! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
!
call op_restr%mv_to(tmpcoo)
nzl = tmpcoo%get_nzeros()
i=0
do k=1, nzl
if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then
i = i+1
tmpcoo%val(i) = tmpcoo%val(k)
tmpcoo%ia(i) = tmpcoo%ia(k)
tmpcoo%ja(i) = tmpcoo%ja(k)
end if
end do
call tmpcoo%set_nzeros(i)
call op_restr%mv_from(tmpcoo)
call op_restr%cscnv(info,type='csr')
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd'
call psb_spspmm(la,tmp_prol,am3,info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done SPSPMM 2'
call psb_sphalo(am3,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.)
if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4)
if (info == psb_success_) call am4%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Extend am3')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done sphalo/ rwxtd'
call psb_spspmm(op_restr,am3,ac,info)
if (info == psb_success_) call am3%free()
if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
&a_err='Build ac = op_restr x am3')
goto 9999
end if
!!$ ! Get the diagonal D
!!$ adiag = a%get_diag(info)
!!$ if (info == psb_success_) &
!!$ & call psb_realloc(ncol,adiag,info)
!!$ if (info == psb_success_) &
!!$ & call psb_halo(adiag,desc_a,info)
!!$ if (info == psb_success_) call a%cp_to_l(la)
!!$ if (info /= psb_success_) then
!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
!!$ goto 9999
!!$ end if
!!$
!!$ do i=1,size(adiag)
!!$ if (adiag(i) /= zzero) then
!!$ adinv(i) = zone / adiag(i)
!!$ else
!!$ adinv(i) = zone
!!$ end if
!!$ end do
!!$
!!$
!!$
!!$ ! 1. Allocate Ptilde in sparse matrix form
!!$ call op_prol%mv_to(tmpcoo)
!!$ call ptilde%mv_from(tmpcoo)
!!$ call ptilde%cscnv(info,type='csr')
!!$
!!$ if (info == psb_success_) call la%cscnv(am3,info,type='csr',dupl=psb_dupl_add_)
!!$ if (info == psb_success_) call la%cscnv(da,info,type='csr',dupl=psb_dupl_add_)
!!$ if (info /= psb_success_) then
!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
!!$ goto 9999
!!$ end if
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' Initial copies done.'
!!$
!!$ call da%scal(adinv,info)
!!$
!!$ call psb_spspmm(da,ptilde,dap,info)
!!$
!!$ if(info /= psb_success_) then
!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
!!$ goto 9999
!!$ end if
!!$
!!$ call dap%clone(atmp,info)
!!$
!!$ call psb_sphalo(atmp,desc_a,am4,info,&
!!$ & colcnv=.false.,rowscale=.true.,outfmt='CSR ')
!!$ if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=am4)
!!$ if (info == psb_success_) call am4%free()
!!$
!!$ call psb_spspmm(da,atmp,dadap,info)
!!$ call atmp%free()
!!$
!!$ ! !$ write(0,*) 'Columns of AP',psb_sp_get_ncols(ap)
!!$ ! !$ write(0,*) 'Columns of ADAP',psb_sp_get_ncols(adap)
!!$ call dap%mv_to(csc_dap)
!!$ call dadap%mv_to(csc_dadap)
!!$
!!$ call csc_mat_col_prod(csc_dap,csc_dadap,omp,info)
!!$ call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info)
!!$ call psb_sum(ctxt,omp)
!!$ call psb_sum(ctxt,oden)
!!$ ! !$ write(0,*) trim(name),' OMP :',omp
!!$ ! !$ write(0,*) trim(name),' ODEN:',oden
!!$
!!$ omp = omp/oden
!!$
!!$ ! !$ write(0,*) 'Check on output prolongator ',omp(1:min(size(omp),10))
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done NUMBMM 1'
!!$
!!$ call am3%mv_to(acsr3)
!!$ ! Compute omega_int
!!$ ommx = zzero
!!$ do i=1, ncol
!!$ if (ilaggr(i) >0) then
!!$ omi(i) = omp(ilaggr(i))
!!$ else
!!$ omi(i) = zzero
!!$ end if
!!$ if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
!!$ end do
!!$ ! Compute omega_fine
!!$ do i=1, nrow
!!$ omf(i) = ommx
!!$ do j=acsr3%irp(i),acsr3%irp(i+1)-1
!!$ if(abs(omi(acsr3%ja(j))) .lt. abs(omf(i))) omf(i)=omi(acsr3%ja(j))
!!$ end do
!!$ ! ! if(min(real(omf(i)),aimag(omf(i))) < dzero) omf(i) = zzero
!!$ if(psb_minreal(omf(i)) < dzero) omf(i) = zzero
!!$ end do
!!$
!!$ omf(1:nrow) = omf(1:nrow) * adinv(1:nrow)
!!$
!!$ if (filter_mat) then
!!$ !
!!$ ! Build the filtered matrix Af from A
!!$ !
!!$ call la%cscnv(acsrf,info,dupl=psb_dupl_add_)
!!$
!!$ do i=1,nrow
!!$ tmp = zzero
!!$ jd = -1
!!$ do j=acsrf%irp(i),acsrf%irp(i+1)-1
!!$ if (acsrf%ja(j) == i) jd = j
!!$ if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then
!!$ tmp=tmp+acsrf%val(j)
!!$ acsrf%val(j)=zzero
!!$ endif
!!$ enddo
!!$ if (jd == -1) then
!!$ write(0,*) 'Wrong input: we need the diagonal!!!!', i
!!$ else
!!$ acsrf%val(jd)=acsrf%val(jd)-tmp
!!$ end if
!!$ enddo
!!$ ! Take out zeroed terms
!!$ call acsrf%clean_zeros(info)
!!$
!!$ !
!!$ ! Build the smoothed prolongator using the filtered matrix
!!$ !
!!$ do i=1,acsrf%get_nrows()
!!$ do j=acsrf%irp(i),acsrf%irp(i+1)-1
!!$ if (acsrf%ja(j) == i) then
!!$ acsrf%val(j) = zone - omf(i)*acsrf%val(j)
!!$ else
!!$ acsrf%val(j) = - omf(i)*acsrf%val(j)
!!$ end if
!!$ end do
!!$ end do
!!$
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done gather, going for SYMBMM 1'
!!$
!!$ call af%mv_from(acsrf)
!!$ !
!!$ ! op_prol = (I-w*D*Af)Ptilde
!!$ ! Doing it this way means to consider diag(Af_i)
!!$ !
!!$ !
!!$ call psb_spspmm(af,ptilde,op_prol,info)
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done SPSPMM 1'
!!$ else
!!$ !
!!$ ! Build the smoothed prolongator using the original matrix
!!$ !
!!$ do i=1,acsr3%get_nrows()
!!$ do j=acsr3%irp(i),acsr3%irp(i+1)-1
!!$ if (acsr3%ja(j) == i) then
!!$ acsr3%val(j) = zone - omf(i)*acsr3%val(j)
!!$ else
!!$ acsr3%val(j) = - omf(i)*acsr3%val(j)
!!$ end if
!!$ end do
!!$ end do
!!$
!!$ call am3%mv_from(acsr3)
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done gather, going for SYMBMM 1'
!!$ !
!!$ !
!!$ ! op_prol = (I-w*D*A)Ptilde
!!$ !
!!$ !
!!$ call psb_spspmm(am3,ptilde,op_prol,info)
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done NUMBMM 1'
!!$
!!$ end if
!!$
!!$
!!$ !
!!$ ! Ok, let's start over with the restrictor
!!$ !
!!$ call ptilde%transc(rtilde)
!!$ call la%cscnv(atmp,info,type='csr')
!!$ call psb_sphalo(atmp,desc_a,am4,info,&
!!$ & colcnv=.true.,rowscale=.true.)
!!$ nrt = am4%get_nrows()
!!$ call am4%csclip(atmp2,info,lone,nrt,lone,ncol)
!!$ call atmp2%cscnv(info,type='CSR')
!!$ if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2)
!!$ call am4%free()
!!$ call atmp2%free()
!!$
!!$ ! This is to compute the transpose. It ONLY works if the
!!$ ! original A has a symmetric pattern.
!!$ call atmp%transc(atmp2)
!!$ call atmp2%csclip(dat,info,lone,nrow,lone,ncol)
!!$ call dat%cscnv(info,type='csr')
!!$ call dat%scal(adinv,info)
!!$
!!$ ! Now for the product.
!!$ call psb_spspmm(dat,ptilde,datp,info)
!!$
!!$ call datp%clone(atmp2,info)
!!$ call psb_sphalo(atmp2,desc_a,am4,info,&
!!$ & colcnv=.false.,rowscale=.true.,outfmt='CSR ')
!!$ if (info == psb_success_) call psb_rwextd(ncol,atmp2,info,b=am4)
!!$ if (info == psb_success_) call am4%free()
!!$
!!$
!!$ call psb_symbmm(dat,atmp2,datdatp,info)
!!$ call psb_numbmm(dat,atmp2,datdatp)
!!$ call atmp2%free()
!!$
!!$ call datp%mv_to(csc_datp)
!!$ call datdatp%mv_to(csc_datdatp)
!!$
!!$ call csc_mat_col_prod(csc_datp,csc_datdatp,omp,info)
!!$ call csc_mat_col_prod(csc_datdatp,csc_datdatp,oden,info)
!!$ call psb_sum(ctxt,omp)
!!$ call psb_sum(ctxt,oden)
!!$
!!$
!!$ ! !$ write(debug_unit,*) trim(name),' OMP_R :',omp
!!$ ! ! $ write(debug_unit,*) trim(name),' ODEN_R:',oden
!!$ omp = omp/oden
!!$ ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10))
!!$ ! Compute omega_int
!!$ ommx = zzero
!!$ do i=1, ncol
!!$ if (ilaggr(i) >0) then
!!$ omi(i) = omp(ilaggr(i))
!!$ else
!!$ omi(i) = zzero
!!$ end if
!!$ if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
!!$ end do
!!$ ! Compute omega_fine
!!$ ! Going over the columns of atmp means going over the rows
!!$ ! of A^T. Hopefully ;-)
!!$ call atmp%cp_to(acsc)
!!$
!!$ do i=1, nrow
!!$ omf(i) = ommx
!!$ do j= acsc%icp(i),acsc%icp(i+1)-1
!!$ if(abs(omi(acsc%ia(j))) .lt. abs(omf(i))) omf(i)=omi(acsc%ia(j))
!!$ end do
!!$ ! ! if(min(real(omf(i)),aimag(omf(i))) < dzero) omf(i) = zzero
!!$ if(psb_minreal(omf(i)) < dzero) omf(i) = zzero
!!$ end do
!!$ omf(1:nrow) = omf(1:nrow)*adinv(1:nrow)
!!$ call psb_halo(omf,desc_a,info)
!!$ call acsc%free()
!!$
!!$
!!$ call atmp%mv_to(acsr1)
!!$
!!$ do i=1,acsr1%get_nrows()
!!$ do j=acsr1%irp(i),acsr1%irp(i+1)-1
!!$ if (acsr1%ja(j) == i) then
!!$ acsr1%val(j) = zone - acsr1%val(j)*omf(acsr1%ja(j))
!!$ else
!!$ acsr1%val(j) = - acsr1%val(j)*omf(acsr1%ja(j))
!!$ end if
!!$ end do
!!$ end do
!!$ call atmp%mv_from(acsr1)
!!$
!!$ call rtilde%mv_to(tmpcoo)
!!$ nzl = tmpcoo%get_nzeros()
!!$ i=0
!!$ do k=1, nzl
!!$ if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then
!!$ i = i+1
!!$ tmpcoo%val(i) = tmpcoo%val(k)
!!$ tmpcoo%ia(i) = tmpcoo%ia(k)
!!$ tmpcoo%ja(i) = tmpcoo%ja(k)
!!$ end if
!!$ end do
!!$ call tmpcoo%set_nzeros(i)
!!$ call rtilde%mv_from(tmpcoo)
!!$ call rtilde%cscnv(info,type='csr')
!!$
!!$ call psb_spspmm(rtilde,atmp,op_restr,info)
!!$
!!$ !
!!$ ! Now we have to gather the halo of op_prol, and add it to itself
!!$ ! to multiply it by A,
!!$ !
!!$ call op_prol%clone(tmp_prol,info)
!!$ if (info == psb_success_) call psb_sphalo(tmp_prol,desc_a,am4,info,&
!!$ & colcnv=.false.,rowscale=.true.)
!!$ if (info == psb_success_) call psb_rwextd(ncol,tmp_prol,info,b=am4)
!!$ if (info == psb_success_) call am4%free()
!!$
!!$ if(info /= psb_success_) then
!!$ call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol')
!!$ goto 9999
!!$ end if
!!$
!!$ !
!!$ ! Now we have to fix this. The only rows of B that are correct
!!$ ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
!!$ !
!!$ call op_restr%mv_to(tmpcoo)
!!$
!!$ nzl = tmpcoo%get_nzeros()
!!$ i=0
!!$ do k=1, nzl
!!$ if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then
!!$ i = i+1
!!$ tmpcoo%val(i) = tmpcoo%val(k)
!!$ tmpcoo%ia(i) = tmpcoo%ia(k)
!!$ tmpcoo%ja(i) = tmpcoo%ja(k)
!!$ end if
!!$ end do
!!$ call tmpcoo%set_nzeros(i)
!!$ call op_restr%mv_from(tmpcoo)
!!$ call op_restr%cscnv(info,type='csr')
!!$
!!$
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'starting sphalo/ rwxtd'
!!$
!!$ call psb_spspmm(la,tmp_prol,am3,info)
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done SPSPMM 2'
!!$
!!$ call psb_sphalo(am3,desc_a,am4,info,&
!!$ & colcnv=.false.,rowscale=.true.)
!!$ if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4)
!!$ if (info == psb_success_) call am4%free()
!!$
!!$ if(info /= psb_success_) then
!!$ call psb_errpush(psb_err_internal_error_,name,&
!!$ & a_err='Extend am3')
!!$ goto 9999
!!$ end if
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'Done sphalo/ rwxtd'
!!$
!!$ call psb_spspmm(op_restr,am3,ac,info)
!!$ if (info == psb_success_) call am3%free()
!!$ if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
!!$
!!$ if (info /= psb_success_) then
!!$ call psb_errpush(psb_err_internal_error_,name,&
!!$ &a_err='Build ac = op_restr x am3')
!!$ goto 9999
!!$ end if
amgprec/impl/aggregator/amg_zaggrmat_smth_bld.f90
+1 -1
View File
@@ -116,7 +116,7 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_dml_parms), intent(inout) :: parms
type(psb_zspmat_type), intent(out) :: op_prol,ac,op_restr
type(psb_zspmat_type), intent(inout) :: op_prol,ac,op_restr
type(psb_lzspmat_type), intent(inout) :: t_prol
type(psb_desc_type), intent(inout) :: desc_ac
integer(psb_ipk_), intent(out) :: info
amgprec/impl/amg_ccprecset.F90
-2
View File
@@ -571,7 +571,6 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
type(amg_c_krm_solver_type) :: krm_slv
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_krm_,info,pos=pos)
call p%precv(nlev_)%set(krm_slv,info)
call p%precv(nlev_)%default()
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
end block
end select
@@ -729,7 +728,6 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
type(amg_c_krm_solver_type) :: krm_slv
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_krm_,info,pos=pos)
call p%precv(nlev_)%set(krm_slv,info)
call p%precv(nlev_)%default()
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
end block
end select
amgprec/impl/amg_cprecset.F90
+1 -1
View File
@@ -45,7 +45,7 @@ subroutine amg_cprecsetsm(p,val,info,ilev,ilmax,pos)
implicit none
! Arguments
class(amg_cprec_type), intent(inout) :: p
class(amg_cprec_type), target, intent(inout):: p
class(amg_c_base_smoother_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev,ilmax
amgprec/impl/amg_dcprecset.F90
-2
View File
@@ -599,7 +599,6 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
type(amg_d_krm_solver_type) :: krm_slv
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_krm_,info,pos=pos)
call p%precv(nlev_)%set(krm_slv,info)
call p%precv(nlev_)%default()
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
end block
end select
@@ -773,7 +772,6 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
type(amg_d_krm_solver_type) :: krm_slv
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_krm_,info,pos=pos)
call p%precv(nlev_)%set(krm_slv,info)
call p%precv(nlev_)%default()
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
end block
end select
amgprec/impl/amg_dprecset.F90
+1 -1
View File
@@ -45,7 +45,7 @@ subroutine amg_dprecsetsm(p,val,info,ilev,ilmax,pos)
implicit none
! Arguments
class(amg_dprec_type), intent(inout) :: p
class(amg_dprec_type), target, intent(inout):: p
class(amg_d_base_smoother_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev,ilmax
amgprec/impl/amg_dslud_interface.c
+15 -15
View File
@@ -94,7 +94,7 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#define HANDLE_SIZE 8
#if defined(SLUD_VERSION_63)
#if (SLUD_VERSION_>=63)
typedef struct {
SuperMatrix *A;
dLUstruct_t *LUstruct;
@@ -135,7 +135,7 @@ int amg_dsludist_fact(int n, int nl, int nnzl, int ffstr,
SuperMatrix *A;
NRformat_loc *Astore;
#if defined(SLUD_VERSION_63)
#if (SLUD_VERSION_>=63)
dScalePermstruct_t *ScalePermstruct;
dLUstruct_t *LUstruct;
dSOLVEstruct_t SOLVEstruct;
@@ -148,9 +148,9 @@ int amg_dsludist_fact(int n, int nl, int nnzl, int ffstr,
int i, panel_size, permc_spec, relax, info;
trans_t trans;
double drop_tol = 0.0, b[1], berr[1];
#if defined(SLUD_VERSION_63) || defined(SLUD_VERSION_6)||defined(SLUD_VERSION_5)
#if (SLUD_VERSION_>=50)
superlu_dist_options_t options;
#elif defined(SLUD_VERSION_4)||defined(SLUD_VERSION_3)
#elif (SLUD_VERSION_>=30)
superlu_options_t options;
#else
choke_on_me;
@@ -174,7 +174,7 @@ int amg_dsludist_fact(int n, int nl, int nnzl, int ffstr,
SLU_NR_loc, SLU_D, SLU_GE);
/* Initialize ScalePermstruct and LUstruct. */
#if defined(SLUD_VERSION_63)
#if (SLUD_VERSION_>=63)
ScalePermstruct = (dScalePermstruct_t *) SUPERLU_MALLOC(sizeof(dScalePermstruct_t));
LUstruct = (dLUstruct_t *) SUPERLU_MALLOC(sizeof(dLUstruct_t));
dScalePermstructInit(n,n, ScalePermstruct);
@@ -183,11 +183,11 @@ int amg_dsludist_fact(int n, int nl, int nnzl, int ffstr,
LUstruct = (LUstruct_t *) SUPERLU_MALLOC(sizeof(LUstruct_t));
ScalePermstructInit(n,n, ScalePermstruct);
#endif
#if defined(SLUD_VERSION_63)
#if (SLUD_VERSION_>=63)
dLUstructInit(n, LUstruct);
#elif defined(SLUD_VERSION_4) || defined(SLUD_VERSION_5) || defined(SLUD_VERSION_6)
#elif (SLUD_VERSION_>=40)
LUstructInit(n, LUstruct);
#elif defined(SLUD_VERSION_3)
#elif (SLUD_VERSION_>=30)
LUstructInit(n,n, LUstruct);
#else
choke_on_me;
@@ -245,7 +245,7 @@ int amg_dsludist_solve(int itrans, int n, int nrhs,
*/
#ifdef Have_SLUDist_
SuperMatrix *A;
#if defined(SLUD_VERSION_63)
#if (SLUD_VERSION_>=63)
dScalePermstruct_t *ScalePermstruct;
dLUstruct_t *LUstruct;
dSOLVEstruct_t SOLVEstruct;
@@ -259,9 +259,9 @@ int amg_dsludist_solve(int itrans, int n, int nrhs,
trans_t trans;
double drop_tol = 0.0;
double *berr;
#if defined(SLUD_VERSION_63) || defined(SLUD_VERSION_6) ||defined(SLUD_VERSION_5)
#if (SLUD_VERSION_>=50)
superlu_dist_options_t options;
#elif defined(SLUD_VERSION_4)|| defined(SLUD_VERSION_3)
#elif (SLUD_VERSION_>=30)
superlu_options_t options;
#else
choke_on_me;
@@ -331,7 +331,7 @@ int amg_dsludist_free(void *f_factors)
*/
#ifdef Have_SLUDist_
SuperMatrix *A;
#if defined(SLUD_VERSION_63)
#if (SLUD_VERSION_>=63)
dScalePermstruct_t *ScalePermstruct;
dLUstruct_t *LUstruct;
dSOLVEstruct_t SOLVEstruct;
@@ -345,9 +345,9 @@ int amg_dsludist_free(void *f_factors)
trans_t trans;
double drop_tol = 0.0;
double *berr;
#if defined(SLUD_VERSION_63)||defined(SLUD_VERSION_6)||defined(SLUD_VERSION_5)
#if (SLUD_VERSION_>=50)
superlu_dist_options_t options;
#elif defined(SLUD_VERSION_4)||defined(SLUD_VERSION_3)
#elif (SLUD_VERSION_>=30)
superlu_options_t options;
#else
choke_on_me;
@@ -368,7 +368,7 @@ int amg_dsludist_free(void *f_factors)
// we either have a leak or a segfault here.
// To be investigated further.
//Destroy_CompRowLoc_Matrix_dist(A);
#if defined(SLUD_VERSION_63)
#if (SLUD_VERSION_>=63)
dScalePermstructFree(ScalePermstruct);
dLUstructFree(LUstruct);
#else
amgprec/impl/amg_scprecset.F90
-2
View File
@@ -571,7 +571,6 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
type(amg_s_krm_solver_type) :: krm_slv
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_krm_,info,pos=pos)
call p%precv(nlev_)%set(krm_slv,info)
call p%precv(nlev_)%default()
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
end block
end select
@@ -729,7 +728,6 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
type(amg_s_krm_solver_type) :: krm_slv
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_krm_,info,pos=pos)
call p%precv(nlev_)%set(krm_slv,info)
call p%precv(nlev_)%default()
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
end block
end select
amgprec/impl/amg_sprecset.F90
+1 -1
View File
@@ -45,7 +45,7 @@ subroutine amg_sprecsetsm(p,val,info,ilev,ilmax,pos)
implicit none
! Arguments
class(amg_sprec_type), intent(inout) :: p
class(amg_sprec_type), target, intent(inout):: p
class(amg_s_base_smoother_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev,ilmax
amgprec/impl/amg_zcprecset.F90
-2
View File
@@ -599,7 +599,6 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
type(amg_z_krm_solver_type) :: krm_slv
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_krm_,info,pos=pos)
call p%precv(nlev_)%set(krm_slv,info)
call p%precv(nlev_)%default()
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
end block
end select
@@ -773,7 +772,6 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
type(amg_z_krm_solver_type) :: krm_slv
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_krm_,info,pos=pos)
call p%precv(nlev_)%set(krm_slv,info)
call p%precv(nlev_)%default()
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
end block
end select
amgprec/impl/amg_zprecset.F90
+1 -1
View File
@@ -45,7 +45,7 @@ subroutine amg_zprecsetsm(p,val,info,ilev,ilmax,pos)
implicit none
! Arguments
class(amg_zprec_type), intent(inout) :: p
class(amg_zprec_type), target, intent(inout):: p
class(amg_z_base_smoother_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev,ilmax
amgprec/impl/amg_zslud_interface.c
+15 -15
View File
@@ -94,7 +94,7 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#define HANDLE_SIZE 8
#if defined(SLUD_VERSION_63)
#if (SLUD_VERSION_>=63)
typedef struct {
SuperMatrix *A;
zLUstruct_t *LUstruct;
@@ -142,7 +142,7 @@ int amg_zsludist_fact(int n, int nl, int nnzl, int ffstr,
SuperMatrix *A;
NRformat_loc *Astore;
#if defined(SLUD_VERSION_63)
#if (SLUD_VERSION_>=63)
zScalePermstruct_t *ScalePermstruct;
zLUstruct_t *LUstruct;
zSOLVEstruct_t SOLVEstruct;
@@ -155,9 +155,9 @@ int amg_zsludist_fact(int n, int nl, int nnzl, int ffstr,
int i, panel_size, permc_spec, relax, info;
trans_t trans;
double drop_tol = 0.0,berr[1];
#if defined(SLUD_VERSION_63) || defined(SLUD_VERSION_6)||defined(SLUD_VERSION_5)
#if (SLUD_VERSION_>=50)
superlu_dist_options_t options;
#elif defined(SLUD_VERSION_4)||defined(SLUD_VERSION_3)
#elif (SLUD_VERSION_>=30)
superlu_options_t options;
#else
choke_on_me;
@@ -181,7 +181,7 @@ int amg_zsludist_fact(int n, int nl, int nnzl, int ffstr,
SLU_NR_loc, SLU_Z, SLU_GE);
/* Initialize ScalePermstruct and LUstruct. */
#if defined(SLUD_VERSION_63)
#if (SLUD_VERSION_>=63)
ScalePermstruct = (zScalePermstruct_t *) SUPERLU_MALLOC(sizeof(zScalePermstruct_t));
LUstruct = (zLUstruct_t *) SUPERLU_MALLOC(sizeof(zLUstruct_t));
zScalePermstructInit(n,n, ScalePermstruct);
@@ -190,11 +190,11 @@ int amg_zsludist_fact(int n, int nl, int nnzl, int ffstr,
LUstruct = (LUstruct_t *) SUPERLU_MALLOC(sizeof(LUstruct_t));
ScalePermstructInit(n,n, ScalePermstruct);
#endif
#if defined(SLUD_VERSION_63)
#if (SLUD_VERSION_>=63)
zLUstructInit(n, LUstruct);
#elif defined(SLUD_VERSION_4) || defined(SLUD_VERSION_5) || defined(SLUD_VERSION_6)
#elif (SLUD_VERSION_>=40)
LUstructInit(n, LUstruct);
#elif defined(SLUD_VERSION_3)
#elif (SLUD_VERSION_>=30)
LUstructInit(n,n, LUstruct);
#else
choke_on_me;
@@ -257,7 +257,7 @@ int amg_zsludist_solve(int itrans, int n, int nrhs,
*/
#ifdef Have_SLUDist_
SuperMatrix *A;
#if defined(SLUD_VERSION_63)
#if (SLUD_VERSION_>=63)
zScalePermstruct_t *ScalePermstruct;
zLUstruct_t *LUstruct;
zSOLVEstruct_t SOLVEstruct;
@@ -271,9 +271,9 @@ int amg_zsludist_solve(int itrans, int n, int nrhs,
trans_t trans;
double drop_tol = 0.0;
double *berr;
#if defined(SLUD_VERSION_63) || defined(SLUD_VERSION_6) ||defined(SLUD_VERSION_5)
#if (SLUD_VERSION_>=50)
superlu_dist_options_t options;
#elif defined(SLUD_VERSION_4)|| defined(SLUD_VERSION_3)
#elif (SLUD_VERSION_>=30)
superlu_options_t options;
#else
choke_on_me;
@@ -343,7 +343,7 @@ int amg_zsludist_free(void *f_factors)
*/
#ifdef Have_SLUDist_
SuperMatrix *A;
#if defined(SLUD_VERSION_63)
#if (SLUD_VERSION_>=63)
zScalePermstruct_t *ScalePermstruct;
zLUstruct_t *LUstruct;
zSOLVEstruct_t SOLVEstruct;
@@ -357,9 +357,9 @@ int amg_zsludist_free(void *f_factors)
trans_t trans;
double drop_tol = 0.0;
double *berr;
#if defined(SLUD_VERSION_63)||defined(SLUD_VERSION_6)||defined(SLUD_VERSION_5)
#if (SLUD_VERSION_>=50)
superlu_dist_options_t options;
#elif defined(SLUD_VERSION_4)||defined(SLUD_VERSION_3)
#elif (SLUD_VERSION_>=30)
superlu_options_t options;
#else
choke_on_me;
@@ -380,7 +380,7 @@ int amg_zsludist_free(void *f_factors)
// we either have a leak or a segfault here.
// To be investigated further.
//Destroy_CompRowLoc_Matrix_dist(A);
#if defined(SLUD_VERSION_63)
#if (SLUD_VERSION_>=63)
zScalePermstructFree(ScalePermstruct);
zLUstructFree(LUstruct);
#else
amgprec/impl/level/amg_c_base_onelev_descr.f90
+2
View File
@@ -83,6 +83,8 @@ subroutine amg_c_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity)
write(iout_,*)
if (il == ilmin) then
call lv%parms%mlcycledsc(iout_,info)
end if
if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then
if (allocated(lv%aggr)) then
call lv%aggr%descr(lv%parms,iout_,info)
else
amgprec/impl/level/amg_c_base_onelev_dump.f90
+14 -12
View File
@@ -101,7 +101,13 @@ subroutine amg_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
end if
if (global_num_) then
if (level >= 2) then
if (level == 1) then
if (ac_) then
ivr = lv%base_desc%get_global_indices(owned=.false.)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
call lv%base_a%print(fname,head=head,iv=ivr)
end if
else if (level >= 2) then
if (ac_) then
ivr = lv%desc_ac%get_global_indices(owned=.false.)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
@@ -126,7 +132,12 @@ subroutine amg_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
end if
end if
else
if (level >= 2) then
if (level == 1) then
if (ac_) then
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
call lv%base_a%print(fname,head=head)
end if
else if (level >= 2) then
if (ac_) then
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
call lv%ac%print(fname,head=head)
@@ -146,16 +157,7 @@ subroutine amg_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
end if
end if
if (level >= 2) then
if (allocated(lv%sm)) then
call lv%sm%dump(lv%desc_ac,level,info,smoother=smoother, &
& solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
end if
if (allocated(lv%sm2a)) then
call lv%sm2a%dump(lv%desc_ac,level,info,smoother=smoother, &
& solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
end if
else
if (level >= 1) then
if (allocated(lv%sm)) then
call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, &
& solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
amgprec/impl/level/amg_d_base_onelev_descr.f90
+2
View File
@@ -83,6 +83,8 @@ subroutine amg_d_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity)
write(iout_,*)
if (il == ilmin) then
call lv%parms%mlcycledsc(iout_,info)
end if
if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then
if (allocated(lv%aggr)) then
call lv%aggr%descr(lv%parms,iout_,info)
else
amgprec/impl/level/amg_d_base_onelev_dump.f90
+14 -12
View File
@@ -101,7 +101,13 @@ subroutine amg_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
end if
if (global_num_) then
if (level >= 2) then
if (level == 1) then
if (ac_) then
ivr = lv%base_desc%get_global_indices(owned=.false.)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
call lv%base_a%print(fname,head=head,iv=ivr)
end if
else if (level >= 2) then
if (ac_) then
ivr = lv%desc_ac%get_global_indices(owned=.false.)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
@@ -126,7 +132,12 @@ subroutine amg_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
end if
end if
else
if (level >= 2) then
if (level == 1) then
if (ac_) then
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
call lv%base_a%print(fname,head=head)
end if
else if (level >= 2) then
if (ac_) then
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
call lv%ac%print(fname,head=head)
@@ -146,16 +157,7 @@ subroutine amg_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
end if
end if
if (level >= 2) then
if (allocated(lv%sm)) then
call lv%sm%dump(lv%desc_ac,level,info,smoother=smoother, &
& solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
end if
if (allocated(lv%sm2a)) then
call lv%sm2a%dump(lv%desc_ac,level,info,smoother=smoother, &
& solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
end if
else
if (level >= 1) then
if (allocated(lv%sm)) then
call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, &
& solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
amgprec/impl/level/amg_s_base_onelev_descr.f90
+2
View File
@@ -83,6 +83,8 @@ subroutine amg_s_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity)
write(iout_,*)
if (il == ilmin) then
call lv%parms%mlcycledsc(iout_,info)
end if
if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then
if (allocated(lv%aggr)) then
call lv%aggr%descr(lv%parms,iout_,info)
else
amgprec/impl/level/amg_s_base_onelev_dump.f90
+14 -12
View File
@@ -101,7 +101,13 @@ subroutine amg_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
end if
if (global_num_) then
if (level >= 2) then
if (level == 1) then
if (ac_) then
ivr = lv%base_desc%get_global_indices(owned=.false.)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
call lv%base_a%print(fname,head=head,iv=ivr)
end if
else if (level >= 2) then
if (ac_) then
ivr = lv%desc_ac%get_global_indices(owned=.false.)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
@@ -126,7 +132,12 @@ subroutine amg_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
end if
end if
else
if (level >= 2) then
if (level == 1) then
if (ac_) then
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
call lv%base_a%print(fname,head=head)
end if
else if (level >= 2) then
if (ac_) then
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
call lv%ac%print(fname,head=head)
@@ -146,16 +157,7 @@ subroutine amg_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
end if
end if
if (level >= 2) then
if (allocated(lv%sm)) then
call lv%sm%dump(lv%desc_ac,level,info,smoother=smoother, &
& solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
end if
if (allocated(lv%sm2a)) then
call lv%sm2a%dump(lv%desc_ac,level,info,smoother=smoother, &
& solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
end if
else
if (level >= 1) then
if (allocated(lv%sm)) then
call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, &
& solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
amgprec/impl/level/amg_z_base_onelev_descr.f90
+2
View File
@@ -83,6 +83,8 @@ subroutine amg_z_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity)
write(iout_,*)
if (il == ilmin) then
call lv%parms%mlcycledsc(iout_,info)
end if
if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then
if (allocated(lv%aggr)) then
call lv%aggr%descr(lv%parms,iout_,info)
else
amgprec/impl/level/amg_z_base_onelev_dump.f90
+14 -12
View File
@@ -101,7 +101,13 @@ subroutine amg_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
end if
if (global_num_) then
if (level >= 2) then
if (level == 1) then
if (ac_) then
ivr = lv%base_desc%get_global_indices(owned=.false.)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
call lv%base_a%print(fname,head=head,iv=ivr)
end if
else if (level >= 2) then
if (ac_) then
ivr = lv%desc_ac%get_global_indices(owned=.false.)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
@@ -126,7 +132,12 @@ subroutine amg_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
end if
end if
else
if (level >= 2) then
if (level == 1) then
if (ac_) then
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
call lv%base_a%print(fname,head=head)
end if
else if (level >= 2) then
if (ac_) then
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
call lv%ac%print(fname,head=head)
@@ -146,16 +157,7 @@ subroutine amg_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
end if
end if
if (level >= 2) then
if (allocated(lv%sm)) then
call lv%sm%dump(lv%desc_ac,level,info,smoother=smoother, &
& solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
end if
if (allocated(lv%sm2a)) then
call lv%sm2a%dump(lv%desc_ac,level,info,smoother=smoother, &
& solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
end if
else
if (level >= 1) then
if (allocated(lv%sm)) then
call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, &
& solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
amgprec/impl/smoother/amg_c_as_smoother_free.f90
+1
View File
@@ -61,6 +61,7 @@ subroutine amg_c_as_smoother_free(sm,info)
end if
end if
call sm%nd%free()
call sm%desc_data%free(info)
call psb_erractionrestore(err_act)
return
amgprec/impl/smoother/amg_d_as_smoother_free.f90
+1
View File
@@ -61,6 +61,7 @@ subroutine amg_d_as_smoother_free(sm,info)
end if
end if
call sm%nd%free()
call sm%desc_data%free(info)
call psb_erractionrestore(err_act)
return
amgprec/impl/smoother/amg_s_as_smoother_free.f90
+1
View File
@@ -61,6 +61,7 @@ subroutine amg_s_as_smoother_free(sm,info)
end if
end if
call sm%nd%free()
call sm%desc_data%free(info)
call psb_erractionrestore(err_act)
return
amgprec/impl/smoother/amg_z_as_smoother_free.f90
+1
View File
@@ -61,6 +61,7 @@ subroutine amg_z_as_smoother_free(sm,info)
end if
end if
call sm%nd%free()
call sm%desc_data%free(info)
call psb_erractionrestore(err_act)
return
amgprec/impl/solver/amg_c_base_solver_csetr.f90
+1 -1
View File
@@ -42,7 +42,7 @@ subroutine amg_c_base_solver_csetr(sv,what,val,info,idx)
Implicit None
! Arguments
class(amg_c_base_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(in) :: what
character(len=*), intent(in) :: what
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
amgprec/impl/solver/amg_c_bwgs_solver_bld.f90
+1 -1
View File
@@ -44,7 +44,7 @@ subroutine amg_c_bwgs_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
! Arguments
type(psb_cspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
Type(psb_desc_type), Intent(inout) :: desc_a
class(amg_c_bwgs_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
type(psb_cspmat_type), intent(in), target, optional :: b
amgprec/impl/solver/amg_c_krm_solver_impl.f90
+3 -2
View File
@@ -77,7 +77,7 @@
! This is the implementation file corresponding to amg_c_krm_solver_mod.
!
!
subroutine amg_c_krm_solver_bld(a,desc_a,sv,info,b,amold,vmold)
subroutine amg_c_krm_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
use psb_base_mod
use amg_c_krm_solver, amg_protect_name => amg_c_krm_solver_bld
@@ -85,13 +85,14 @@ subroutine amg_c_krm_solver_bld(a,desc_a,sv,info,b,amold,vmold)
Implicit None
! Arguments
type(psb_cspmat_type), intent(inout), target :: a
type(psb_cspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(inout) :: desc_a
class(amg_c_krm_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
type(psb_cspmat_type), intent(in), target, optional :: b
class(psb_c_base_sparse_mat), intent(in), optional :: amold
class(psb_c_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
! Local variables
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota
integer(psb_lpk_) :: lnr
amgprec/impl/solver/amg_d_base_solver_csetr.f90
+1 -1
View File
@@ -42,7 +42,7 @@ subroutine amg_d_base_solver_csetr(sv,what,val,info,idx)
Implicit None
! Arguments
class(amg_d_base_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(in) :: what
character(len=*), intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
amgprec/impl/solver/amg_d_bwgs_solver_bld.f90
+1 -1
View File
@@ -44,7 +44,7 @@ subroutine amg_d_bwgs_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
! Arguments
type(psb_dspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
Type(psb_desc_type), Intent(inout) :: desc_a
class(amg_d_bwgs_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
type(psb_dspmat_type), intent(in), target, optional :: b
amgprec/impl/solver/amg_d_krm_solver_impl.f90
+3 -2
View File
@@ -77,7 +77,7 @@
! This is the implementation file corresponding to amg_d_krm_solver_mod.
!
!
subroutine amg_d_krm_solver_bld(a,desc_a,sv,info,b,amold,vmold)
subroutine amg_d_krm_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
use psb_base_mod
use amg_d_krm_solver, amg_protect_name => amg_d_krm_solver_bld
@@ -85,13 +85,14 @@ subroutine amg_d_krm_solver_bld(a,desc_a,sv,info,b,amold,vmold)
Implicit None
! Arguments
type(psb_dspmat_type), intent(inout), target :: a
type(psb_dspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(inout) :: desc_a
class(amg_d_krm_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
type(psb_dspmat_type), intent(in), target, optional :: b
class(psb_d_base_sparse_mat), intent(in), optional :: amold
class(psb_d_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
! Local variables
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota
integer(psb_lpk_) :: lnr
amgprec/impl/solver/amg_s_base_solver_csetr.f90
+1 -1
View File
@@ -42,7 +42,7 @@ subroutine amg_s_base_solver_csetr(sv,what,val,info,idx)
Implicit None
! Arguments
class(amg_s_base_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(in) :: what
character(len=*), intent(in) :: what
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
amgprec/impl/solver/amg_s_bwgs_solver_bld.f90
+1 -1
View File
@@ -44,7 +44,7 @@ subroutine amg_s_bwgs_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
! Arguments
type(psb_sspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
Type(psb_desc_type), Intent(inout) :: desc_a
class(amg_s_bwgs_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
type(psb_sspmat_type), intent(in), target, optional :: b
amgprec/impl/solver/amg_s_krm_solver_impl.f90
+3 -2
View File
@@ -77,7 +77,7 @@
! This is the implementation file corresponding to amg_s_krm_solver_mod.
!
!
subroutine amg_s_krm_solver_bld(a,desc_a,sv,info,b,amold,vmold)
subroutine amg_s_krm_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
use psb_base_mod
use amg_s_krm_solver, amg_protect_name => amg_s_krm_solver_bld
@@ -85,13 +85,14 @@ subroutine amg_s_krm_solver_bld(a,desc_a,sv,info,b,amold,vmold)
Implicit None
! Arguments
type(psb_sspmat_type), intent(inout), target :: a
type(psb_sspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(inout) :: desc_a
class(amg_s_krm_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
type(psb_sspmat_type), intent(in), target, optional :: b
class(psb_s_base_sparse_mat), intent(in), optional :: amold
class(psb_s_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
! Local variables
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota
integer(psb_lpk_) :: lnr
amgprec/impl/solver/amg_z_base_solver_csetr.f90
+1 -1
View File
@@ -42,7 +42,7 @@ subroutine amg_z_base_solver_csetr(sv,what,val,info,idx)
Implicit None
! Arguments
class(amg_z_base_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(in) :: what
character(len=*), intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
amgprec/impl/solver/amg_z_bwgs_solver_bld.f90
+1 -1
View File
@@ -44,7 +44,7 @@ subroutine amg_z_bwgs_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
! Arguments
type(psb_zspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
Type(psb_desc_type), Intent(inout) :: desc_a
class(amg_z_bwgs_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
type(psb_zspmat_type), intent(in), target, optional :: b
amgprec/impl/solver/amg_z_krm_solver_impl.f90
+3 -2
View File
@@ -77,7 +77,7 @@
! This is the implementation file corresponding to amg_z_krm_solver_mod.
!
!
subroutine amg_z_krm_solver_bld(a,desc_a,sv,info,b,amold,vmold)
subroutine amg_z_krm_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
use psb_base_mod
use amg_z_krm_solver, amg_protect_name => amg_z_krm_solver_bld
@@ -85,13 +85,14 @@ subroutine amg_z_krm_solver_bld(a,desc_a,sv,info,b,amold,vmold)
Implicit None
! Arguments
type(psb_zspmat_type), intent(inout), target :: a
type(psb_zspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(inout) :: desc_a
class(amg_z_krm_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
type(psb_zspmat_type), intent(in), target, optional :: b
class(psb_z_base_sparse_mat), intent(in), optional :: amold
class(psb_z_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
! Local variables
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota
integer(psb_lpk_) :: lnr
config/pac.m4
+3 -1
View File
@@ -852,6 +852,7 @@ if test "x$pac_sludist_header_ok" == "xyes" ; then
dnl Maybe lib?
SLUDIST_LIBS="$amg4psblas_cv_superludist -L$amg4psblas_cv_superludistdir/lib";
LIBS="$SLUDIST_LIBS -lm $save_LIBS";
AC_MSG_CHECKING([for superlu_malloc_dist in $SLUDIST_LIBS])
AC_TRY_LINK_FUNC(superlu_malloc_dist,
[amg4psblas_cv_have_superludist=yes;pac_sludist_lib_ok=yes;],
[amg4psblas_cv_have_superludist=no;pac_sludist_lib_ok=no;
@@ -861,12 +862,13 @@ if test "x$pac_sludist_header_ok" == "xyes" ; then
dnl Maybe lib64?
SLUDIST_LIBS="$amg4psblas_cv_superludist -L$amg4psblas_cv_superludistdir/lib64";
LIBS="$SLUDIST_LIBS -lm $save_LIBS";
AC_MSG_CHECKING([for superlu_malloc_dist in $SLUDIST_LIBS])
AC_TRY_LINK_FUNC(superlu_malloc_dist,
[amg4psblas_cv_have_superludist=yes;pac_sludist_lib_ok=yes;],
[amg4psblas_cv_have_superludist=no;pac_sludist_lib_ok=no;
SLUDIST_LIBS="";SLUDIST_INCLUDES=""])
fi
AC_MSG_RESULT($pac_sludist_lib_ok)
AC_MSG_RESULT([$pac_sludist_lib_ok $SLUDIST_LIBS])
fi
if test "x$pac_sludist_lib_ok" == "xyes" ; then
configure
Vendored
+1274 -12
View File
File diff suppressed because it is too large Load Diff
configure.ac
+97 -8
View File
@@ -133,6 +133,9 @@ FCFLAGS="$save_FCFLAGS";
save_CFLAGS="$CFLAGS";
AC_PROG_CC([cc xlc pgcc icc gcc ])
CFLAGS="$save_CFLAGS";
save_CXXFLAGS="$CXXFLAGS";
AC_PROG_CXX([CC xlc++ icpc g++])
CXXFLAGS="$save_CXXFLAGS";
dnl AC_PROG_CXX
dnl AC_PROG_F90 doesn't exist, at the time of writing this !
@@ -158,6 +161,16 @@ if eval "$FC -qversion 2>&1 | grep XL 2>/dev/null" ; then
# since (as far as it is known to us) -WF, is not used in earlier versions.
# More problems could be undocumented yet.
fi
if test "X$CC" == "X" ; then
AC_MSG_ERROR([Problem : No C compiler specified nor found!])
fi
AC_PROG_CC_STDC()
if test "x$ac_cv_prog_cc_stdc" == "xno" ; then
AC_MSG_ERROR([Problem : Need a C99 compiler ! ])
else
C99OPT="$ac_cv_prog_cc_stdc";
fi
###############################################################################
# Suitable MPI compilers detection
###############################################################################
@@ -171,6 +184,7 @@ if test x"$pac_cv_serial_mpi" == x"yes" ; then
FAKEMPI="fakempi.o";
MPIFC="$FC";
MPICC="$CC";
MPICXX="$CXX";
CXXDEFINES="-DSERIAL_MPI $CXXDEFINES";
else
@@ -190,9 +204,17 @@ if test "X$MPIFC" = "X" ; then
fi
ACX_MPI([], [AC_MSG_ERROR([[Cannot find any suitable MPI implementation for Fortran]])])
AC_LANG([C++])
if test "X$MPICXX" = "X" ; then
# This is our MPICC compiler preference: it will override ACX_MPI's first try.
AC_CHECK_PROGS([MPICXX],[mpxlc++ mpiicpc mpicxx])
fi
ACX_MPI([], [AC_MSG_ERROR([[Cannot find any suitable MPI implementation for C++]])])
AC_LANG([Fortran])
FC="$MPIFC" ;
CC="$MPICC";
CXX="$MPICXX";
fi
AC_LANG([C])
@@ -217,10 +239,12 @@ fi
dnl NOTE : no spaces before the comma, and no brackets before the second argument!
PAC_ARG_WITH_FLAGS(ccopt,CCOPT)
PAC_ARG_WITH_FLAGS(cxxopt,CXXOPT)
PAC_ARG_WITH_FLAGS(fcopt,FCOPT)
PAC_ARG_WITH_LIBS
PAC_ARG_WITH_FLAGS(clibs,CLIBS)
PAC_ARG_WITH_FLAGS(flibs,FLIBS)
PAC_ARG_WITH_FLAGS(cxxlibs,CXXLIBS)
dnl candidates for removal:
PAC_ARG_WITH_FLAGS(library-path,LIBRARYPATH)
@@ -230,6 +254,20 @@ PAC_ARG_WITH_FLAGS(module-path,MODULE_PATH)
# we just gave the user the chance to append values to these variables
PAC_ARG_WITH_EXTRA_LIBS
# Check if we need extra libs (e.g. for OpenMPI)
AC_MSG_CHECKING([Extra mpicxx libs?])
xtrlibs=`mpicxx --showme:link 2>/dev/null`;
if (( $? == 0 ))
then
EXTRA_LIBS="$EXTRA_LIBS $xtrlibs";
AC_MSG_RESULT([$xtrlibs])
else
AC_MSG_RESULT([none])
fi
###############################################################################
# Sanity checks, although redundant (useful when debugging this configure.ac)!
###############################################################################
@@ -395,6 +433,36 @@ if test "X$CCOPT" == "X" ; then
fi
fi
#CFLAGS="${CCOPT}"
if test "X$CXXOPT" == "X" ; then
CXXOPT="$CXXFLAGS";
fi
if test "X$CXXOPT" == "X" ; then
if test "X$psblas_cv_fc" == "Xgcc" ; then
# note that no space should be placed around the equality symbol in assignements
# Note : 'native' is valid _only_ on GCC/x86 (32/64 bits)
CXXOPT="-g -O3 $CXXOPT"
elif test "X$psblas_cv_fc" == X"xlf" ; then
# XL compiler : consider using -qarch=auto
CXXOPT="-O3 -qarch=auto $CXXOPT"
elif test "X$psblas_cv_fc" == X"ifc" ; then
# other compilers ..
CXXOPT="-O3 $CXXOPT"
elif test "X$psblas_cv_fc" == X"pg" ; then
# other compilers ..
CXXCOPT="-fast $CXXOPT"
# NOTE : PG & Sun use -fast instead -O3
elif test "X$psblas_cv_fc" == X"sun" ; then
# other compilers ..
CXXOPT="-fast $CXXOPT"
elif test "X$psblas_cv_fc" == X"cray" ; then
CXXOPT="-O3 $CXXOPT"
MPICXX="CC"
else
CXXOPT="-g -O3 $CXXOPT"
fi
fi
# Honor FCFLAGS if they were specified explicitly, but --with-fcopt take precedence
if test "X$FCOPT" == "X" ; then
@@ -443,7 +511,8 @@ fi
##############################################################################
FC=${FC}
CC=${CC}
MPCC=${MPICC}
CXX=${CXX}
CCOPT="$CCOPT $C99OPT"
##############################################################################
@@ -478,6 +547,30 @@ fi
if test "X$FLINK" == "X" ; then
FLINK=${MPF90}
fi
# Custom test : do we have a module or include for MPI Fortran interface?
if test x"$pac_cv_serial_mpi" == x"yes" ; then
FDEFINES="$psblas_cv_define_prepend-DSERIAL_MPI $psblas_cv_define_prepend-DMPI_MOD $FDEFINES";
else
PAC_FORTRAN_CHECK_HAVE_MPI_MOD_F08()
if test x"$pac_cv_mpi_f08" == x"yes" ; then
dnl FDEFINES="$psblas_cv_define_prepend-DMPI_MOD_F08 $FDEFINES";
FDEFINES="$psblas_cv_define_prepend-DMPI_MOD $FDEFINES";
else
PAC_FORTRAN_CHECK_HAVE_MPI_MOD(
[FDEFINES="$psblas_cv_define_prepend-DMPI_MOD $FDEFINES"],
[FDEFINES="$psblas_cv_define_prepend-DMPI_H $FDEFINES"])
fi
fi
FLINK="$MPIFC"
PAC_ARG_OPENMP()
if test x"$pac_cv_openmp" == x"yes" ; then
FDEFINES="$psblas_cv_define_prepend-DOPENMP $FDEFINES";
CDEFINES="-DOPENMP $CDEFINES";
FCOPT="$FCOPT $pac_cv_openmp_fcopt";
CCOPT="$CCOPT $pac_cv_openmp_ccopt";
FLINK="$FLINK $pac_cv_openmp_fcopt";
fi
PAC_FORTRAN_HAVE_PSBLAS([AC_MSG_RESULT([yes.])],
[AC_MSG_ERROR([no. Could not find working version of PSBLAS.])])
@@ -693,14 +786,10 @@ fi
PAC_CHECK_SUPERLUDIST()
if test "x$amg4psblas_cv_have_superludist" == "xyes" ; then
pac_sludist_version="$amg4psblas_cv_superludist_major";
if (($amg4psblas_cv_superludist_major==6)); then
if (($amg4psblas_cv_superludist_minor>=3)); then
pac_sludist_version="63";
fi
fi
pac_sludist_version="$amg4psblas_cv_superludist_major$amg4psblas_cv_superludist_minor";
AC_MSG_NOTICE([Configuring with SuperLU_DIST version flag $pac_sludist_version])
SLUDIST_FLAGS=""
SLUDIST_FLAGS="-DHave_SLUDist_ -DSLUD_VERSION_$pac_sludist_version $SLUDIST_INCLUDES"
SLUDIST_FLAGS="-DHave_SLUDist_ -DSLUD_VERSION_="$pac_sludist_version" $SLUDIST_INCLUDES"
FDEFINES="$amg_cv_define_prepend-DHAVE_SLUDIST_ $FDEFINES"
else
SLUDIST_FLAGS=""
configure_n
+64 -11
View File
@@ -753,6 +753,7 @@ infodir
docdir
oldincludedir
includedir
runstatedir
localstatedir
sharedstatedir
sysconfdir
@@ -877,6 +878,7 @@ datadir='${datarootdir}'
sysconfdir='${prefix}/etc'
sharedstatedir='${prefix}/com'
localstatedir='${prefix}/var'
runstatedir='${localstatedir}/run'
includedir='${prefix}/include'
oldincludedir='/usr/include'
docdir='${datarootdir}/doc/${PACKAGE_TARNAME}'
@@ -1129,6 +1131,15 @@ do
| -silent | --silent | --silen | --sile | --sil)
silent=yes ;;
-runstatedir | --runstatedir | --runstatedi | --runstated \
| --runstate | --runstat | --runsta | --runst | --runs \
| --run | --ru | --r)
ac_prev=runstatedir ;;
-runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \
| --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \
| --run=* | --ru=* | --r=*)
runstatedir=$ac_optarg ;;
-sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
ac_prev=sbindir ;;
-sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
@@ -1266,7 +1277,7 @@ fi
for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \
datadir sysconfdir sharedstatedir localstatedir includedir \
oldincludedir docdir infodir htmldir dvidir pdfdir psdir \
libdir localedir mandir
libdir localedir mandir runstatedir
do
eval ac_val=\$$ac_var
# Remove trailing slashes.
@@ -1419,6 +1430,7 @@ Fine tuning of the installation directories:
--sysconfdir=DIR read-only single-machine data [PREFIX/etc]
--sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com]
--localstatedir=DIR modifiable single-machine data [PREFIX/var]
--runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run]
--libdir=DIR object code libraries [EPREFIX/lib]
--includedir=DIR C header files [PREFIX/include]
--oldincludedir=DIR C header files for non-gcc [/usr/include]
@@ -8087,6 +8099,44 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking support for Fortran ISO_C_BINDING module" >&5
$as_echo_n "checking support for Fortran ISO_C_BINDING module... " >&6; }
ac_ext=${ac_fc_srcext-f}
ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5'
ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_fc_compiler_gnu
ac_exeext=''
ac_ext='f90'
ac_fc=${MPIFC-$FC};
cat > conftest.$ac_ext <<_ACEOF
program conftest
use iso_c_binding
end program conftest
_ACEOF
if ac_fn_fc_try_compile "$LINENO"; then :
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
$as_echo "yes" >&6; }
:
else
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
$as_echo "no" >&6; }
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
as_fn_error $? "Sorry, cannot build PSBLAS without support for ISO_C_BINDING.
Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8." "$LINENO" 5
fi
rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
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
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking support for ISO_FORTRAN_ENV" >&5
$as_echo_n "checking support for ISO_FORTRAN_ENV... " >&6; }
ac_ext=${ac_fc_srcext-f}
@@ -10706,6 +10756,8 @@ rm -f core conftest.err conftest.$ac_objext \
if test "x$pac_sludist_lib_ok" == "xno" ; then
SLUDIST_LIBS="$amg4psblas_cv_superludist -L$amg4psblas_cv_superludistdir/lib";
LIBS="$SLUDIST_LIBS -lm $save_LIBS";
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for superlu_malloc_dist in $SLUDIST_LIBS" >&5
$as_echo_n "checking for superlu_malloc_dist in $SLUDIST_LIBS... " >&6; }
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
@@ -10736,6 +10788,8 @@ rm -f core conftest.err conftest.$ac_objext \
if test "x$pac_sludist_lib_ok" == "xno" ; then
SLUDIST_LIBS="$amg4psblas_cv_superludist -L$amg4psblas_cv_superludistdir/lib64";
LIBS="$SLUDIST_LIBS -lm $save_LIBS";
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for superlu_malloc_dist in $SLUDIST_LIBS" >&5
$as_echo_n "checking for superlu_malloc_dist in $SLUDIST_LIBS... " >&6; }
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
@@ -10763,8 +10817,8 @@ fi
rm -f core conftest.err conftest.$ac_objext \
conftest$ac_exeext conftest.$ac_ext
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $pac_sludist_lib_ok" >&5
$as_echo "$pac_sludist_lib_ok" >&6; }
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $pac_sludist_lib_ok $SLUDIST_LIBS" >&5
$as_echo "$pac_sludist_lib_ok $SLUDIST_LIBS" >&6; }
fi
if test "x$pac_sludist_lib_ok" == "xyes" ; then
@@ -10906,14 +10960,11 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu
if test "x$amg4psblas_cv_have_superludist" == "xyes" ; then
pac_sludist_version="$amg4psblas_cv_superludist_major";
if (($amg4psblas_cv_superludist_major==6)); then
if (($amg4psblas_cv_superludist_minor>=3)); then
pac_sludist_version="63";
fi
fi
pac_sludist_version="$amg4psblas_cv_superludist_major$amg4psblas_cv_superludist_minor";
{ $as_echo "$as_me:${as_lineno-$LINENO}: Configuring with SuperLU_DIST version flag $pac_sludist_version" >&5
$as_echo "$as_me: Configuring with SuperLU_DIST version flag $pac_sludist_version" >&6;}
SLUDIST_FLAGS=""
SLUDIST_FLAGS="-DHave_SLUDist_ -DSLUD_VERSION_$pac_sludist_version $SLUDIST_INCLUDES"
SLUDIST_FLAGS="-DHave_SLUDist_ -DSLUD_VERSION_="$pac_sludist_version" $SLUDIST_INCLUDES"
FDEFINES="$amg_cv_define_prepend-DHAVE_SLUDIST_ $FDEFINES"
else
SLUDIST_FLAGS=""
@@ -12275,7 +12326,9 @@ $as_echo X/"$am_mf" |
{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
as_fn_error $? "Something went wrong bootstrapping makefile fragments
for automatic dependency tracking. Try re-running configure with the
for automatic dependency tracking. If GNU make was not used, consider
re-running the configure script with MAKE=\"gmake\" (or whatever is
necessary). You can also try re-running configure with the
'--disable-dependency-tracking' option to at least be able to build
the package (albeit without support for automatic dependency tracking).
See \`config.log' for more details" "$LINENO" 5; }
configure_n.ac
+9 -7
View File
@@ -673,6 +673,12 @@ PAC_FORTRAN_TEST_VOLATILE(
[AC_MSG_ERROR([Sorry, cannot build PSBLAS without support for VOLATILE])]
)
PAC_FORTRAN_TEST_ISO_C_BIND(
[],
[AC_MSG_ERROR([Sorry, cannot build PSBLAS without support for ISO_C_BINDING.
Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8.])]
)
PAC_FORTRAN_TEST_ISO_FORTRAN_ENV(
[],
[AC_MSG_ERROR([Sorry, cannot build PSBLAS without support for ISO_FORTRAN_ENV])]
@@ -856,14 +862,10 @@ fi
PAC_CHECK_SUPERLUDIST()
if test "x$amg4psblas_cv_have_superludist" == "xyes" ; then
pac_sludist_version="$amg4psblas_cv_superludist_major";
if (($amg4psblas_cv_superludist_major==6)); then
if (($amg4psblas_cv_superludist_minor>=3)); then
pac_sludist_version="63";
fi
fi
pac_sludist_version="$amg4psblas_cv_superludist_major$amg4psblas_cv_superludist_minor";
AC_MSG_NOTICE([Configuring with SuperLU_DIST version flag $pac_sludist_version])
SLUDIST_FLAGS=""
SLUDIST_FLAGS="-DHave_SLUDist_ -DSLUD_VERSION_$pac_sludist_version $SLUDIST_INCLUDES"
SLUDIST_FLAGS="-DHave_SLUDist_ -DSLUD_VERSION_="$pac_sludist_version" $SLUDIST_INCLUDES"
FDEFINES="$amg_cv_define_prepend-DHAVE_SLUDIST_ $FDEFINES"
else
SLUDIST_FLAGS=""
docs/amg4psblas_1.0-guide.pdf
BIN
View File
Binary file not shown.
docs/html/userhtmlsu3.html
+2 -2
View File
@@ -4228,9 +4228,9 @@ class="cmtt-12">github</span><span
class="cmtt-12">.</span><span
class="cmtt-12">com</span><span
class="cmtt-12">/</span><span
class="cmtt-12">sfilippone</span><span
class="cmtt-12">psctoolkit</span><span
class="cmtt-12">/</span><span
class="cmtt-12">amg4psblas</span><span
class="cmtt-12">psctoolkit</span><span
class="cmtt-12">/</span><span
class="cmtt-12">issues</span><span
class="cmtt-12">&#x003E;.</span>
docs/html/userhtmlsu4.html
+2 -2
View File
@@ -36,8 +36,8 @@ class="cmr-12">If you find any bugs in our codes, please report them through our
<span
class="cmr-12">on</span><br
class="newline" /> <a
href="https://github.com/psctoolkit/amg4psblas/issues" class="url" ><span
class="cmtt-12">https://github.com/psctoolkit/amg4psblas/issues</span></a><br
href="https://github.com/psctoolkit/psctoolkit/issues" class="url" ><span
class="cmtt-12">https://github.com/psctoolkit/psctoolkit/issues</span></a><br
class="newline" />
<!--l. 195--><p class="indent" > <span
class="cmr-12">To enable us to track the bug, please provide a log from the failing application, the</span>
docs/html/userhtmlsu6.html
+4 -2
View File
@@ -79,7 +79,8 @@ class="cmr-12">found in the example program file </span><span class="obeylines-h
class="cmtt-12">amg_dexample_ml.f90</span></span></span><span
class="cmr-12">, in the directory</span>
<span class="obeylines-h"><span class="verb"><span
class="cmtt-12">samples/simple/fileread</span></span></span> <span
class="cmtt-12">samples/simple/file</span></span></span><span class="obeylines-h"><span class="verb"><span
class="cmtt-12">read</span></span></span> <span
class="cmr-12">of the AMG4PSBLAS implementation (see Section</span><span
class="cmr-12">&#x00A0;</span><a
href="userhtmlsu5.html#x13-120003.5"><span
@@ -114,7 +115,8 @@ class="cmr-12">for</span>
<span
class="cmr-12">details). If these versions are installed, the corresponding codes are available in</span>
<span class="obeylines-h"><span class="verb"><span
class="cmtt-12">samples/simple/fileread/</span></span></span><span
class="cmtt-12">samples/simple/file</span></span></span><span class="obeylines-h"><span class="verb"><span
class="cmtt-12">read</span></span></span><span
class="cmr-12">.</span>
docs/html/userhtmlsu7.html
+16 -11
View File
@@ -143,7 +143,7 @@ class="cmr-12">GPU environment</span>
<div class="center"
>
<!--l. 556--><p class="noindent" >
<!--l. 557--><p class="noindent" >
<div class="minipage"><pre class="verbatim" id="verbatim-12">
&#x00A0;&#x00A0;call&#x00A0;desc_a%cnv(mold=igmold)
&#x00A0;&#x00A0;call&#x00A0;a%cscnv(info,mold=agmold)
@@ -167,7 +167,7 @@ class="cmr-12">GPU environment</span>
&#x00A0;&#x00A0;stop
&#x00A0;
</pre>
<!--l. 583--><p class="nopar" ></div></div>
<!--l. 584--><p class="nopar" ></div></div>
<br /> <div class="caption"
><span class="id">Listing 7: </span><span
class="content">setup of a GPU-enabled test program part three.</span></div><!--tex4ht:label?: x16-15003r7 -->
@@ -175,25 +175,30 @@ class="content">setup of a GPU-enabled test program part three.</span></div><!--
</div><hr class="endfloat" />
<!--l. 591--><p class="indent" > <span
class="cmr-12">It is very important to employ solvers that are suited to the GPU, i.e. solvers that</span>
<!--l. 592--><p class="indent" > <span
class="cmr-12">It is very important to employ smoothers and coarsest solvers that are suited to the</span>
<span
class="cmr-12">do NOT employ triangular system solve kernels. Solvers that satisfy this constraint</span>
class="cmr-12">GPU, i.e. methods that do NOT employ triangular system solve kernels. Methods that</span>
<span
class="cmr-12">include:</span>
class="cmr-12">satisfy this constraint include:</span>
<ul class="itemize1">
<li class="itemize"><span class="obeylines-h"><span class="verb"><span
class="cmtt-12">JACOBI</span></span></span>
</li>
<li class="itemize"><span class="obeylines-h"><span class="verb"><span
class="cmtt-12">BJAC</span></span></span> <span
class="cmr-12">with the following methods on the local blocks:</span>
<ul class="itemize2">
<li class="itemize"><span class="obeylines-h"><span class="verb"><span
class="cmtt-12">INVK</span></span></span>
</li>
<li class="itemize"><span class="obeylines-h"><span class="verb"><span
</li>
<li class="itemize"><span class="obeylines-h"><span class="verb"><span
class="cmtt-12">INVT</span></span></span>
</li>
<li class="itemize"><span class="obeylines-h"><span class="verb"><span
</li>
<li class="itemize"><span class="obeylines-h"><span class="verb"><span
class="cmtt-12">AINV</span></span></span></li></ul>
<!--l. 600--><p class="noindent" ><span
</li></ul>
<!--l. 604--><p class="noindent" ><span
class="cmr-12">and their </span><span
class="cmmi-12">&#x2113;</span><sub><span
class="cmr-8">1</span></sub> <span
docs/src/Makefile
+3 -3
View File
@@ -211,12 +211,12 @@ ps: $(PS)
.PHONY: clean clean-tmp preview print gzip gunzip tar ci
clean:
clean: clean-tmp
rm -f $(PDF) $(PS)
cd tmp ; rm -r -f *
clean-tmp:
cd tmp ; rm -r -f *
(test -d tmp && cd tmp && rm -r -f *)
#----------------------------------------------------------------------------
docs/src/building.tex
+1 -1
View File
@@ -190,7 +190,7 @@ make install
\subsection{Bug reporting}
If you find any bugs in our codes, please report them through our
issues page on \\[2mm]
\url{https://github.com/psctoolkit/amg4psblas/issues}\\
\url{https://github.com/psctoolkit/psctoolkit/issues}\\
To enable us to track the bug, please provide a log from the failing
application, the test conditions, and ideally a self-contained test
docs/src/configureout.txt
+1 -1
View File
@@ -159,4 +159,4 @@ Some influential environment variables:
Use these variables to override the choices made by `configure' or to help
it to find libraries and programs with nonstandard names/locations.
Report bugs to <https://github.com/sfilippone/amg4psblas/issues>.
Report bugs to <https://github.com/psctoolkit/psctoolkit/issues>.
docs/src/gettingstarted.tex
+10 -6
View File
@@ -129,7 +129,7 @@ relevant data structures, performed
through the PSBLAS routines for sparse matrix and vector management, is not reported
here for the sake of conciseness.
The complete code can be found in the example program file \verb|amg_dexample_ml.f90|,
in the directory \verb|samples/simple/fileread| of the AMG4PSBLAS implementation (see
in the directory \verb|samples/simple/file|\-\verb|read| of the AMG4PSBLAS implementation (see
Section~\ref{sec:ex_and_test}). A sample test problem along with the relevant
input data is available in \verb|samples/simple/fileread/runs|.
For details on the use of the PSBLAS routines, see the PSBLAS User's
@@ -139,7 +139,7 @@ The setup and application of the default multilevel preconditioner
for the real single precision and the complex, single and double
precision, versions are obtained with straightforward modifications of the previous
example (see Section~\ref{sec:userinterface} for details). If these versions are installed,
the corresponding codes are available in \verb|samples/simple/fileread/|.
the corresponding codes are available in \verb|samples/simple/file|\-\verb|read|.
\begin{listing}[tbp]
\begin{center}
@@ -539,7 +539,8 @@ Krylov method. At the end of the code, we close the GPU environment
call prec%allocate_wrk(info)
t1 = psb_wtime()
call psb_krylov(s_choice%kmethd,a,prec,b,x,s_choice%eps,&
& desc_a,info,itmax=s_choice%itmax,iter=iter,err=err,itrace=s_choice%itrace,&
& desc_a,info,itmax=s_choice%itmax,iter=iter,err=err,&
& itrace=s_choice%itrace,&
& istop=s_choice%istopc,irst=s_choice%irst)
call prec%deallocate_wrk(info)
call psb_barrier(ctxt)
@@ -588,15 +589,18 @@ Krylov method. At the end of the code, we close the GPU environment
\caption{setup of a GPU-enabled test program part three.\label{fig:gpu-ex3}}
\end{listing}
It is very important to employ solvers that are suited
to the GPU, i.e. solvers that do NOT employ triangular
system solve kernels. Solvers that satisfy this constraint include:
It is very important to employ smoothers and coarsest solvers that are suited
to the GPU, i.e. methods that do NOT employ triangular
system solve kernels. Methods that satisfy this constraint include:
\begin{itemize}
\item \verb|JACOBI|
\item \verb|BJAC| with the following methods on the local blocks:
\begin{itemize}
\item \verb|INVK|
\item \verb|INVT|
\item \verb|AINV|
\end{itemize}
\end{itemize}
and their $\ell_1$ variants.
%%% Local Variables:
examples/gpu/amg_dexample_gpu.f90
+19 -20
View File
@@ -39,23 +39,18 @@
!
! This sample program solves a linear system obtained by discretizing a
! PDE with Dirichlet BCs. The solver is CG, coupled with one of the
! following multi-level preconditioner, as explained in Section 4.1 of
! following multi-level preconditioner, as explained in Section 4.2 of
! the AMG4PSBLAS User's and Reference Guide:
!
! - choice = 1, the default multi-level preconditioner solver, i.e.,
! V-cycle with decoupled smoothed aggregation, 1 hybrid forward/backward
! GS sweep as pre/post-smoother and UMFPACK as coarsest-level
! solver (Sec. 4.1, Listing 1)
! - choice = 1, a V-cycle with decoupled smoothed aggregation, 4 Jacobi
! sweeps as pre/post-smoother and 8 Jacobi sweeps as coarsest-level
! solver with replicated coarsest matrix
!
! - choice = 2, a V-cycle preconditioner with 1 block-Jacobi sweep
! (with ILU(0) on the blocks) as pre- and post-smoother, and 8 block-Jacobi
! sweeps (with ILU(0) on the blocks) as coarsest-level solver (Sec. 4.1, Listing 2)
!
! - choice = 3, W-cycle preconditioner based on the coupled aggregation relying
! on matching, with maximum size of aggregates equal to 8 and smoothed prolongators,
! 2 hybrid forward/backward GS sweeps as pre/post-smoother, a distributed coarsest
! matrix, and preconditioned Flexible Conjugate Gradient as coarsest-level solver
! (Sec. 4.1, Listing 3)
! - choice = 2, a W-cycle based on the coupled aggregation relying on matching,
! with maximum size of aggregates equal to 8 and smoothed prolongators,
! 2 sweeps of Block-Jacobi ipre/post-smoother using approximate inverse INVK and
! 4 sweeps of Block-Jacobi with INVK as coarsest-level solver on distributed
! coarsest matrix
!
! The matrix and the rhs are read from files (if an rhs is not available, the
! unit rhs is set).
@@ -183,8 +178,9 @@ program amg_dexample_gpu
case(1)
! initialize a V-cycle preconditioner with 4 Jacobi sweep
! and 8 Jacobi sweeps as coarsest-level solver
! initialize a V-cycle preconditioner, relying on decoupled smoothed aggregation
! with 4 Jacobi sweeps as pre/post-smoother
! and 8 Jacobi sweeps as coarsest-level solver on replicated coarsest matrix
call P%init(ctxt,'ML',info)
call P%set('SMOOTHER_TYPE','JACOBI',info)
@@ -195,19 +191,22 @@ program amg_dexample_gpu
case(2)
! initialize a V-cycle preconditioner based on the coupled aggregation relying on matching,
! initialize a W-cycle preconditioner based on the coupled aggregation relying on matching,
! with maximum size of aggregates equal to 8 and smoothed prolongators,
! Block-Jacobi smoother using approximate inverse INVK and
! and 4 sweeps of INVK on he coarsest level
! 2 sweeps of Block-Jacobi pre/post-smoother using approximate inverse INVK and
! 4 sweeps of Block-Jacobi with INVK on the coarsest level distributed matrix
call P%init(ctxt,'ML',info)
call P%set('PAR_AGGR_ALG','COUPLED',info)
call P%set('AGGR_TYPE','MATCHBOXP',info)
call P%set('AGGR_SIZE',8,info)
call P%set('ML_CYCLE','WCYCLE',info)
call P%set('SMOOTHER_TYPE','BJAC',info)
call P%set('SMOOTHER_SWEEPS',2,info)
call P%set('SUB_SOLVE','INVK',info)
call P%set('COARSE_SOLVE','INVK',info)
call P%set('COARSE_SOLVE','BJAC',info)
call P%set('COARSE_SUBSOLVE','INVK',info)
call P%set('COARSE_SWEEPS',4,info)
call P%set('COARSE_MAT','DIST',info)
kmethod = 'CG'
samples/advanced/fileread/amg_cf_sample.f90
+2 -2
View File
@@ -676,8 +676,9 @@ contains
call read_data(prec%aggr_prol,inp_unit) ! aggregation type
call read_data(prec%par_aggr_alg,inp_unit) ! parallel aggregation alg
call read_data(prec%aggr_ord,inp_unit) ! ordering for aggregation
call read_data(prec%aggr_filter,inp_unit) ! filtering
call read_data(prec%mncrratio,inp_unit) ! minimum aggregation ratio
call read_data(prec%aggr_filter,inp_unit) ! filtering
call read_data(prec%athres,inp_unit) ! smoothed aggr thresh
call read_data(prec%thrvsz,inp_unit) ! size of aggr thresh vector
if (prec%thrvsz > 0) then
call psb_realloc(prec%thrvsz,prec%athresv,info)
@@ -685,7 +686,6 @@ contains
else
read(inp_unit,*) ! dummy read to skip a record
end if
call read_data(prec%athres,inp_unit) ! smoothed aggr thresh
! coasest-level solver
call read_data(prec%csolve,inp_unit) ! coarsest-lev solver
call read_data(prec%csbsolve,inp_unit) ! coarsest-lev subsolver
samples/advanced/fileread/amg_df_sample.f90
+2 -2
View File
@@ -676,8 +676,9 @@ contains
call read_data(prec%aggr_prol,inp_unit) ! aggregation type
call read_data(prec%par_aggr_alg,inp_unit) ! parallel aggregation alg
call read_data(prec%aggr_ord,inp_unit) ! ordering for aggregation
call read_data(prec%aggr_filter,inp_unit) ! filtering
call read_data(prec%mncrratio,inp_unit) ! minimum aggregation ratio
call read_data(prec%aggr_filter,inp_unit) ! filtering
call read_data(prec%athres,inp_unit) ! smoothed aggr thresh
call read_data(prec%thrvsz,inp_unit) ! size of aggr thresh vector
if (prec%thrvsz > 0) then
call psb_realloc(prec%thrvsz,prec%athresv,info)
@@ -685,7 +686,6 @@ contains
else
read(inp_unit,*) ! dummy read to skip a record
end if
call read_data(prec%athres,inp_unit) ! smoothed aggr thresh
! coasest-level solver
call read_data(prec%csolve,inp_unit) ! coarsest-lev solver
call read_data(prec%csbsolve,inp_unit) ! coarsest-lev subsolver
samples/advanced/fileread/amg_sf_sample.f90
+2 -2
View File
@@ -676,8 +676,9 @@ contains
call read_data(prec%aggr_prol,inp_unit) ! aggregation type
call read_data(prec%par_aggr_alg,inp_unit) ! parallel aggregation alg
call read_data(prec%aggr_ord,inp_unit) ! ordering for aggregation
call read_data(prec%aggr_filter,inp_unit) ! filtering
call read_data(prec%mncrratio,inp_unit) ! minimum aggregation ratio
call read_data(prec%aggr_filter,inp_unit) ! filtering
call read_data(prec%athres,inp_unit) ! smoothed aggr thresh
call read_data(prec%thrvsz,inp_unit) ! size of aggr thresh vector
if (prec%thrvsz > 0) then
call psb_realloc(prec%thrvsz,prec%athresv,info)
@@ -685,7 +686,6 @@ contains
else
read(inp_unit,*) ! dummy read to skip a record
end if
call read_data(prec%athres,inp_unit) ! smoothed aggr thresh
! coasest-level solver
call read_data(prec%csolve,inp_unit) ! coarsest-lev solver
call read_data(prec%csbsolve,inp_unit) ! coarsest-lev subsolver
samples/advanced/fileread/amg_zf_sample.f90
+2 -2
View File
@@ -676,8 +676,9 @@ contains
call read_data(prec%aggr_prol,inp_unit) ! aggregation type
call read_data(prec%par_aggr_alg,inp_unit) ! parallel aggregation alg
call read_data(prec%aggr_ord,inp_unit) ! ordering for aggregation
call read_data(prec%aggr_filter,inp_unit) ! filtering
call read_data(prec%mncrratio,inp_unit) ! minimum aggregation ratio
call read_data(prec%aggr_filter,inp_unit) ! filtering
call read_data(prec%athres,inp_unit) ! smoothed aggr thresh
call read_data(prec%thrvsz,inp_unit) ! size of aggr thresh vector
if (prec%thrvsz > 0) then
call psb_realloc(prec%thrvsz,prec%athresv,info)
@@ -685,7 +686,6 @@ contains
else
read(inp_unit,*) ! dummy read to skip a record
end if
call read_data(prec%athres,inp_unit) ! smoothed aggr thresh
! coasest-level solver
call read_data(prec%csolve,inp_unit) ! coarsest-lev solver
call read_data(prec%csbsolve,inp_unit) ! coarsest-lev subsolver
samples/advanced/fileread/runs/amg_cfs.inp
+2 -2
View File
@@ -41,11 +41,11 @@ VCYCLE ! Type of multilevel CYCLE: VCYCLE WCYCLE KCYCLE MUL
SMOOTHED ! Type of aggregation: SMOOTHED UNSMOOTHED
DEC ! Parallel aggregation: DEC, SYMDEC
NATURAL ! Ordering of aggregation NATURAL DEGREE
FILTER ! Filtering of matrix: FILTER NOFILTER
-1.5 ! Coarsening ratio, if < 0 use library default
FILTER ! Filtering of matrix: FILTER NOFILTER
-0.0100d0 ! Smoothed aggregation threshold, ignored if < 0
-2 ! Number of thresholds in vector, next line ignored if <= 0
0.05 0.025 ! Thresholds
-0.0100d0 ! Smoothed aggregation threshold, ignored if < 0
%%%%%%%%%%% Coarse level solver %%%%%%%%%%%%%%%%
SLU ! Coarsest-level solver: MUMPS UMF SLU SLUDIST JACOBI GS BJAC
SLU ! Coarsest-level subsolver for BJAC: ILU ILUT MILU UMF MUMPS SLU
samples/advanced/fileread/runs/amg_dfs.inp
+5 -5
View File
@@ -1,8 +1,8 @@
%%%%%%%%%%% General arguments % Lines starting with % are ignored.
mld_mat.mtx ! Other matrices from: http://math.nist.gov/MatrixMarket/ or
mld_rhs.mtx ! rhs ! http://www.cise.ufl.edu/research/sparse/matrices/index.html
amg_mat.mtx ! Other matrices from: http://math.nist.gov/MatrixMarket/ or
amg_rhs.mtx ! rhs ! http://www.cise.ufl.edu/research/sparse/matrices/index.html
NONE ! Initial guess
mld_sol.mtx ! Reference solution
amg_sol.mtx ! Reference solution
MM ! File format: MatrixMarket or Harwell-Boeing
CSR ! Storage format: CSR COO JAD
GRAPH ! PART (partition method): BLOCK GRAPH
@@ -41,11 +41,11 @@ VCYCLE ! Type of multilevel CYCLE: VCYCLE WCYCLE KCYCLE MUL
SMOOTHED ! Type of aggregation: SMOOTHED UNSMOOTHED
DEC ! Parallel aggregation: DEC, SYMDEC
NATURAL ! Ordering of aggregation NATURAL DEGREE
FILTER ! Filtering of matrix: FILTER NOFILTER
-1.5 ! Coarsening ratio, if < 0 use library default
FILTER ! Filtering of matrix: FILTER NOFILTER
-0.0100d0 ! Smoothed aggregation threshold, ignored if < 0
-2 ! Number of thresholds in vector, next line ignored if <= 0
0.05 0.025 ! Thresholds
-0.0100d0 ! Smoothed aggregation threshold, ignored if < 0
%%%%%%%%%%% Coarse level solver %%%%%%%%%%%%%%%%
UMF ! Coarsest-level solver: MUMPS UMF SLU SLUDIST JACOBI GS BJAC
UMF ! Coarsest-level subsolver for BJAC: ILU ILUT MILU UMF MUMPS SLU
samples/advanced/fileread/runs/amg_sfs.inp
+5 -5
View File
@@ -1,8 +1,8 @@
%%%%%%%%%%% General arguments % Lines starting with % are ignored.
mld_mat.mtx ! Other matrices from: http://math.nist.gov/MatrixMarket/ or
mld_rhs.mtx ! rhs ! http://www.cise.ufl.edu/research/sparse/matrices/index.html
amg_mat.mtx ! Other matrices from: http://math.nist.gov/MatrixMarket/ or
amg_rhs.mtx ! rhs ! http://www.cise.ufl.edu/research/sparse/matrices/index.html
NONE ! Initial guess
mld_sol.mtx ! Reference solution
amg_sol.mtx ! Reference solution
MM ! File format: MatrixMarket or Harwell-Boeing
CSR ! Storage format: CSR COO JAD
GRAPH ! PART (partition method): BLOCK GRAPH
@@ -41,11 +41,11 @@ VCYCLE ! Type of multilevel CYCLE: VCYCLE WCYCLE KCYCLE MUL
SMOOTHED ! Type of aggregation: SMOOTHED UNSMOOTHED
DEC ! Parallel aggregation: DEC, SYMDEC
NATURAL ! Ordering of aggregation NATURAL DEGREE
FILTER ! Filtering of matrix: FILTER NOFILTER
-1.5 ! Coarsening ratio, if < 0 use library default
FILTER ! Filtering of matrix: FILTER NOFILTER
-0.0100d0 ! Smoothed aggregation threshold, ignored if < 0
-2 ! Number of thresholds in vector, next line ignored if <= 0
0.05 0.025 ! Thresholds
-0.0100d0 ! Smoothed aggregation threshold, ignored if < 0
%%%%%%%%%%% Coarse level solver %%%%%%%%%%%%%%%%
SLU ! Coarsest-level solver: MUMPS UMF SLU SLUDIST JACOBI GS BJAC
SLU ! Coarsest-level subsolver for BJAC: ILU ILUT MILU UMF MUMPS SLU
samples/advanced/fileread/runs/amg_zfs.inp
+2 -2
View File
@@ -41,11 +41,11 @@ VCYCLE ! Type of multilevel CYCLE: VCYCLE WCYCLE KCYCLE MUL
SMOOTHED ! Type of aggregation: SMOOTHED UNSMOOTHED
DEC ! Parallel aggregation: DEC, SYMDEC
NATURAL ! Ordering of aggregation NATURAL DEGREE
FILTER ! Filtering of matrix: FILTER NOFILTER
-1.5 ! Coarsening ratio, if < 0 use library default
FILTER ! Filtering of matrix: FILTER NOFILTER
-0.0100d0 ! Smoothed aggregation threshold, ignored if < 0
-2 ! Number of thresholds in vector, next line ignored if <= 0
0.05 0.025 ! Thresholds
-0.0100d0 ! Smoothed aggregation threshold, ignored if < 0
%%%%%%%%%%% Coarse level solver %%%%%%%%%%%%%%%%
UMF ! Coarsest-level solver: MUMPS UMF SLU SLUDIST JACOBI GS BJAC
UMF ! Coarsest-level subsolver for BJAC: ILU ILUT MILU UMF MUMPS SLU
samples/advanced/pdegen/Makefile
+1 -1
View File
@@ -44,7 +44,7 @@ check: all
clean:
/bin/rm -f data_input.o *.o *$(.mod)\
$(EXEDIR)/mld_d_pde3d $(EXEDIR)/mld_s_pde3d $(EXEDIR)/mld_d_pde2d $(EXEDIR)/mld_s_pde2d
$(EXEDIR)/amg_d_pde3d $(EXEDIR)/amg_s_pde3d $(EXEDIR)/amg_d_pde2d $(EXEDIR)/amg_s_pde2d
verycleanlib:
(cd ../..; make veryclean)
samples/advanced/pdegen/amg_d_pde2d.f90
+48 -8
View File
@@ -119,7 +119,7 @@ program amg_d_pde2d
character(len=10) :: ptype ! preconditioner type
integer(psb_ipk_) :: outer_sweeps ! number of outer sweeps: sweeps for 1-level,
! AMG cycles for ML
! AMG cycles for ML
! general AMG data
character(len=16) :: mlcycle ! AMG cycle type
integer(psb_ipk_) :: maxlevs ! maximum number of levels in AMG preconditioner
@@ -174,6 +174,17 @@ program amg_d_pde2d
real(psb_dpk_) :: cthres ! threshold for ILUT factorization
integer(psb_ipk_) :: cjswp ! sweeps for GS or JAC coarsest-lev subsolver
! Dump data
logical :: dump = .false.
integer(psb_ipk_) :: dlmin ! Minimum level to dump
integer(psb_ipk_) :: dlmax ! Maximum level to dump
logical :: dump_ac = .false.
logical :: dump_rp = .false.
logical :: dump_tprol = .false.
logical :: dump_smoother = .false.
logical :: dump_solver = .false.
logical :: dump_global_num = .false.
end type precdata
type(precdata) :: p_choice
@@ -338,12 +349,12 @@ program amg_d_pde2d
call prec%set('sub_prol', p_choice%prol2, info,pos='post')
select case(trim(psb_toupper(p_choice%solve2)))
case('INVK')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set('sub_solve', p_choice%solve2, info)
case('INVT')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set('sub_solve', p_choice%solve2, info)
case('AINV')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set('ainv_alg', p_choice%variant, info)
call prec%set('sub_solve', p_choice%solve2, info)
call prec%set('ainv_alg', p_choice%variant2, info)
case default
call prec%set('sub_solve', p_choice%solve2, info, pos='post')
end select
@@ -392,6 +403,12 @@ program amg_d_pde2d
write(psb_out_unit,'(" ")')
end if
if (p_choice%dump) then
call prec%dump(info,istart=p_choice%dlmin,iend=p_choice%dlmax,&
& ac=p_choice%dump_ac,rp=p_choice%dump_rp,tprol=p_choice%dump_tprol,&
& smoother=p_choice%dump_smoother, solver=p_choice%dump_solver, &
& global_num=p_choice%dump_global_num)
end if
!
! iterative method parameters
!
@@ -530,6 +547,7 @@ contains
! preconditioner type
call read_data(prec%descr,inp_unit) ! verbose description of the prec
call read_data(prec%ptype,inp_unit) ! preconditioner type
! First smoother / 1-lev preconditioner
call read_data(prec%smther,inp_unit) ! smoother type
call read_data(prec%jsweeps,inp_unit) ! (pre-)smoother / 1-lev prec sweeps
@@ -563,8 +581,9 @@ contains
call read_data(prec%aggr_type,inp_unit) ! type of aggregation
call read_data(prec%aggr_size,inp_unit) ! Requested size of the aggregates for MATCHBOXP
call read_data(prec%aggr_ord,inp_unit) ! ordering for aggregation
call read_data(prec%aggr_filter,inp_unit) ! filtering
call read_data(prec%mncrratio,inp_unit) ! minimum aggregation ratio
call read_data(prec%aggr_filter,inp_unit) ! filtering
call read_data(prec%athres,inp_unit) ! smoothed aggr thresh
call read_data(prec%thrvsz,inp_unit) ! size of aggr thresh vector
if (prec%thrvsz > 0) then
call psb_realloc(prec%thrvsz,prec%athresv,info)
@@ -572,7 +591,6 @@ contains
else
read(inp_unit,*) ! dummy read to skip a record
end if
call read_data(prec%athres,inp_unit) ! smoothed aggr thresh
! coasest-level solver
call read_data(prec%csolve,inp_unit) ! coarsest-lev solver
call read_data(prec%csbsolve,inp_unit) ! coarsest-lev subsolver
@@ -580,6 +598,17 @@ contains
call read_data(prec%cfill,inp_unit) ! fill-in for incompl LU
call read_data(prec%cthres,inp_unit) ! Threshold for ILUT
call read_data(prec%cjswp,inp_unit) ! sweeps for GS/JAC subsolver
! dump
call read_data(prec%dump,inp_unit) ! Dump on file?
call read_data(prec%dlmin,inp_unit) ! Minimum level to dump
call read_data(prec%dlmax,inp_unit) ! Maximum level to dump
call read_data(prec%dump_ac,inp_unit)
call read_data(prec%dump_rp,inp_unit)
call read_data(prec%dump_tprol,inp_unit)
call read_data(prec%dump_smoother,inp_unit)
call read_data(prec%dump_solver,inp_unit)
call read_data(prec%dump_global_num,inp_unit)
if (inp_unit /= psb_inp_unit) then
close(inp_unit)
end if
@@ -626,6 +655,7 @@ contains
call psb_bcast(ctxt,prec%mlcycle)
call psb_bcast(ctxt,prec%outer_sweeps)
call psb_bcast(ctxt,prec%maxlevs)
call psb_bcast(ctxt,prec%csizepp)
call psb_bcast(ctxt,prec%aggr_prol)
call psb_bcast(ctxt,prec%par_aggr_alg)
@@ -641,13 +671,23 @@ contains
end if
call psb_bcast(ctxt,prec%athres)
call psb_bcast(ctxt,prec%csizepp)
call psb_bcast(ctxt,prec%cmat)
call psb_bcast(ctxt,prec%csolve)
call psb_bcast(ctxt,prec%csbsolve)
call psb_bcast(ctxt,prec%cfill)
call psb_bcast(ctxt,prec%cthres)
call psb_bcast(ctxt,prec%cjswp)
! dump
call psb_bcast(ctxt,prec%dump)
call psb_bcast(ctxt,prec%dlmin)
call psb_bcast(ctxt,prec%dlmax)
call psb_bcast(ctxt,prec%dump_ac)
call psb_bcast(ctxt,prec%dump_rp)
call psb_bcast(ctxt,prec%dump_tprol)
call psb_bcast(ctxt,prec%dump_smoother)
call psb_bcast(ctxt,prec%dump_solver)
call psb_bcast(ctxt,prec%dump_global_num)
end subroutine get_parms
samples/advanced/pdegen/amg_d_pde3d.f90
+49 -8
View File
@@ -120,7 +120,7 @@ program amg_d_pde3d
character(len=10) :: ptype ! preconditioner type
integer(psb_ipk_) :: outer_sweeps ! number of outer sweeps: sweeps for 1-level,
! AMG cycles for ML
! AMG cycles for ML
! general AMG data
character(len=16) :: mlcycle ! AMG cycle type
integer(psb_ipk_) :: maxlevs ! maximum number of levels in AMG preconditioner
@@ -175,6 +175,17 @@ program amg_d_pde3d
real(psb_dpk_) :: cthres ! threshold for ILUT factorization
integer(psb_ipk_) :: cjswp ! sweeps for GS or JAC coarsest-lev subsolver
! Dump data
logical :: dump = .false.
integer(psb_ipk_) :: dlmin ! Minimum level to dump
integer(psb_ipk_) :: dlmax ! Maximum level to dump
logical :: dump_ac = .false.
logical :: dump_rp = .false.
logical :: dump_tprol = .false.
logical :: dump_smoother = .false.
logical :: dump_solver = .false.
logical :: dump_global_num = .false.
end type precdata
type(precdata) :: p_choice
@@ -342,12 +353,12 @@ program amg_d_pde3d
call prec%set('sub_prol', p_choice%prol2, info,pos='post')
select case(trim(psb_toupper(p_choice%solve2)))
case('INVK')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set('sub_solve', p_choice%solve2, info)
case('INVT')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set('sub_solve', p_choice%solve2, info)
case('AINV')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set('ainv_alg', p_choice%variant, info)
call prec%set('sub_solve', p_choice%solve2, info)
call prec%set('ainv_alg', p_choice%variant2, info)
case default
call prec%set('sub_solve', p_choice%solve2, info, pos='post')
end select
@@ -396,6 +407,12 @@ program amg_d_pde3d
write(psb_out_unit,'(" ")')
end if
if (p_choice%dump) then
call prec%dump(info,istart=p_choice%dlmin,iend=p_choice%dlmax,&
& ac=p_choice%dump_ac,rp=p_choice%dump_rp,tprol=p_choice%dump_tprol,&
& smoother=p_choice%dump_smoother, solver=p_choice%dump_solver, &
& global_num=p_choice%dump_global_num)
end if
!
! iterative method parameters
!
@@ -534,6 +551,7 @@ contains
! preconditioner type
call read_data(prec%descr,inp_unit) ! verbose description of the prec
call read_data(prec%ptype,inp_unit) ! preconditioner type
! First smoother / 1-lev preconditioner
call read_data(prec%smther,inp_unit) ! smoother type
call read_data(prec%jsweeps,inp_unit) ! (pre-)smoother / 1-lev prec sweeps
@@ -567,8 +585,9 @@ contains
call read_data(prec%aggr_type,inp_unit) ! type of aggregation
call read_data(prec%aggr_size,inp_unit) ! Requested size of the aggregates for MATCHBOXP
call read_data(prec%aggr_ord,inp_unit) ! ordering for aggregation
call read_data(prec%aggr_filter,inp_unit) ! filtering
call read_data(prec%mncrratio,inp_unit) ! minimum aggregation ratio
call read_data(prec%aggr_filter,inp_unit) ! filtering
call read_data(prec%athres,inp_unit) ! smoothed aggr thresh
call read_data(prec%thrvsz,inp_unit) ! size of aggr thresh vector
if (prec%thrvsz > 0) then
call psb_realloc(prec%thrvsz,prec%athresv,info)
@@ -576,7 +595,6 @@ contains
else
read(inp_unit,*) ! dummy read to skip a record
end if
call read_data(prec%athres,inp_unit) ! smoothed aggr thresh
! coasest-level solver
call read_data(prec%csolve,inp_unit) ! coarsest-lev solver
call read_data(prec%csbsolve,inp_unit) ! coarsest-lev subsolver
@@ -584,6 +602,17 @@ contains
call read_data(prec%cfill,inp_unit) ! fill-in for incompl LU
call read_data(prec%cthres,inp_unit) ! Threshold for ILUT
call read_data(prec%cjswp,inp_unit) ! sweeps for GS/JAC subsolver
! dump
call read_data(prec%dump,inp_unit) ! Dump on file?
call read_data(prec%dlmin,inp_unit) ! Minimum level to dump
call read_data(prec%dlmax,inp_unit) ! Maximum level to dump
call read_data(prec%dump_ac,inp_unit)
call read_data(prec%dump_rp,inp_unit)
call read_data(prec%dump_tprol,inp_unit)
call read_data(prec%dump_smoother,inp_unit)
call read_data(prec%dump_solver,inp_unit)
call read_data(prec%dump_global_num,inp_unit)
if (inp_unit /= psb_inp_unit) then
close(inp_unit)
end if
@@ -630,6 +659,7 @@ contains
call psb_bcast(ctxt,prec%mlcycle)
call psb_bcast(ctxt,prec%outer_sweeps)
call psb_bcast(ctxt,prec%maxlevs)
call psb_bcast(ctxt,prec%csizepp)
call psb_bcast(ctxt,prec%aggr_prol)
call psb_bcast(ctxt,prec%par_aggr_alg)
@@ -645,13 +675,24 @@ contains
end if
call psb_bcast(ctxt,prec%athres)
call psb_bcast(ctxt,prec%csizepp)
call psb_bcast(ctxt,prec%cmat)
call psb_bcast(ctxt,prec%csolve)
call psb_bcast(ctxt,prec%csbsolve)
call psb_bcast(ctxt,prec%cfill)
call psb_bcast(ctxt,prec%cthres)
call psb_bcast(ctxt,prec%cjswp)
! dump
call psb_bcast(ctxt,prec%dump)
call psb_bcast(ctxt,prec%dlmin)
call psb_bcast(ctxt,prec%dlmax)
call psb_bcast(ctxt,prec%dump_ac)
call psb_bcast(ctxt,prec%dump_rp)
call psb_bcast(ctxt,prec%dump_tprol)
call psb_bcast(ctxt,prec%dump_smoother)
call psb_bcast(ctxt,prec%dump_solver)
call psb_bcast(ctxt,prec%dump_global_num)
end subroutine get_parms
samples/advanced/pdegen/amg_d_pde3d_base_mod.f90
+1 -1
View File
@@ -64,7 +64,7 @@ contains
b3=done/sqrt(3.0_psb_dpk_)
end function b3
function c(x,y,z)
use psb_base_mod, only : psb_dpk_, done
use psb_base_mod, only : psb_dpk_, dzero, done
real(psb_dpk_) :: c
real(psb_dpk_), intent(in) :: x,y,z
c=dzero
samples/advanced/pdegen/amg_s_pde2d.f90
+48 -8
View File
@@ -119,7 +119,7 @@ program amg_s_pde2d
character(len=10) :: ptype ! preconditioner type
integer(psb_ipk_) :: outer_sweeps ! number of outer sweeps: sweeps for 1-level,
! AMG cycles for ML
! AMG cycles for ML
! general AMG data
character(len=16) :: mlcycle ! AMG cycle type
integer(psb_ipk_) :: maxlevs ! maximum number of levels in AMG preconditioner
@@ -174,6 +174,17 @@ program amg_s_pde2d
real(psb_spk_) :: cthres ! threshold for ILUT factorization
integer(psb_ipk_) :: cjswp ! sweeps for GS or JAC coarsest-lev subsolver
! Dump data
logical :: dump = .false.
integer(psb_ipk_) :: dlmin ! Minimum level to dump
integer(psb_ipk_) :: dlmax ! Maximum level to dump
logical :: dump_ac = .false.
logical :: dump_rp = .false.
logical :: dump_tprol = .false.
logical :: dump_smoother = .false.
logical :: dump_solver = .false.
logical :: dump_global_num = .false.
end type precdata
type(precdata) :: p_choice
@@ -338,12 +349,12 @@ program amg_s_pde2d
call prec%set('sub_prol', p_choice%prol2, info,pos='post')
select case(trim(psb_toupper(p_choice%solve2)))
case('INVK')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set('sub_solve', p_choice%solve2, info)
case('INVT')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set('sub_solve', p_choice%solve2, info)
case('AINV')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set('ainv_alg', p_choice%variant, info)
call prec%set('sub_solve', p_choice%solve2, info)
call prec%set('ainv_alg', p_choice%variant2, info)
case default
call prec%set('sub_solve', p_choice%solve2, info, pos='post')
end select
@@ -392,6 +403,12 @@ program amg_s_pde2d
write(psb_out_unit,'(" ")')
end if
if (p_choice%dump) then
call prec%dump(info,istart=p_choice%dlmin,iend=p_choice%dlmax,&
& ac=p_choice%dump_ac,rp=p_choice%dump_rp,tprol=p_choice%dump_tprol,&
& smoother=p_choice%dump_smoother, solver=p_choice%dump_solver, &
& global_num=p_choice%dump_global_num)
end if
!
! iterative method parameters
!
@@ -530,6 +547,7 @@ contains
! preconditioner type
call read_data(prec%descr,inp_unit) ! verbose description of the prec
call read_data(prec%ptype,inp_unit) ! preconditioner type
! First smoother / 1-lev preconditioner
call read_data(prec%smther,inp_unit) ! smoother type
call read_data(prec%jsweeps,inp_unit) ! (pre-)smoother / 1-lev prec sweeps
@@ -563,8 +581,9 @@ contains
call read_data(prec%aggr_type,inp_unit) ! type of aggregation
call read_data(prec%aggr_size,inp_unit) ! Requested size of the aggregates for MATCHBOXP
call read_data(prec%aggr_ord,inp_unit) ! ordering for aggregation
call read_data(prec%aggr_filter,inp_unit) ! filtering
call read_data(prec%mncrratio,inp_unit) ! minimum aggregation ratio
call read_data(prec%aggr_filter,inp_unit) ! filtering
call read_data(prec%athres,inp_unit) ! smoothed aggr thresh
call read_data(prec%thrvsz,inp_unit) ! size of aggr thresh vector
if (prec%thrvsz > 0) then
call psb_realloc(prec%thrvsz,prec%athresv,info)
@@ -572,7 +591,6 @@ contains
else
read(inp_unit,*) ! dummy read to skip a record
end if
call read_data(prec%athres,inp_unit) ! smoothed aggr thresh
! coasest-level solver
call read_data(prec%csolve,inp_unit) ! coarsest-lev solver
call read_data(prec%csbsolve,inp_unit) ! coarsest-lev subsolver
@@ -580,6 +598,17 @@ contains
call read_data(prec%cfill,inp_unit) ! fill-in for incompl LU
call read_data(prec%cthres,inp_unit) ! Threshold for ILUT
call read_data(prec%cjswp,inp_unit) ! sweeps for GS/JAC subsolver
! dump
call read_data(prec%dump,inp_unit) ! Dump on file?
call read_data(prec%dlmin,inp_unit) ! Minimum level to dump
call read_data(prec%dlmax,inp_unit) ! Maximum level to dump
call read_data(prec%dump_ac,inp_unit)
call read_data(prec%dump_rp,inp_unit)
call read_data(prec%dump_tprol,inp_unit)
call read_data(prec%dump_smoother,inp_unit)
call read_data(prec%dump_solver,inp_unit)
call read_data(prec%dump_global_num,inp_unit)
if (inp_unit /= psb_inp_unit) then
close(inp_unit)
end if
@@ -626,6 +655,7 @@ contains
call psb_bcast(ctxt,prec%mlcycle)
call psb_bcast(ctxt,prec%outer_sweeps)
call psb_bcast(ctxt,prec%maxlevs)
call psb_bcast(ctxt,prec%csizepp)
call psb_bcast(ctxt,prec%aggr_prol)
call psb_bcast(ctxt,prec%par_aggr_alg)
@@ -641,13 +671,23 @@ contains
end if
call psb_bcast(ctxt,prec%athres)
call psb_bcast(ctxt,prec%csizepp)
call psb_bcast(ctxt,prec%cmat)
call psb_bcast(ctxt,prec%csolve)
call psb_bcast(ctxt,prec%csbsolve)
call psb_bcast(ctxt,prec%cfill)
call psb_bcast(ctxt,prec%cthres)
call psb_bcast(ctxt,prec%cjswp)
! dump
call psb_bcast(ctxt,prec%dump)
call psb_bcast(ctxt,prec%dlmin)
call psb_bcast(ctxt,prec%dlmax)
call psb_bcast(ctxt,prec%dump_ac)
call psb_bcast(ctxt,prec%dump_rp)
call psb_bcast(ctxt,prec%dump_tprol)
call psb_bcast(ctxt,prec%dump_smoother)
call psb_bcast(ctxt,prec%dump_solver)
call psb_bcast(ctxt,prec%dump_global_num)
end subroutine get_parms
samples/advanced/pdegen/amg_s_pde3d.f90
+49 -8
View File
@@ -120,7 +120,7 @@ program amg_s_pde3d
character(len=10) :: ptype ! preconditioner type
integer(psb_ipk_) :: outer_sweeps ! number of outer sweeps: sweeps for 1-level,
! AMG cycles for ML
! AMG cycles for ML
! general AMG data
character(len=16) :: mlcycle ! AMG cycle type
integer(psb_ipk_) :: maxlevs ! maximum number of levels in AMG preconditioner
@@ -175,6 +175,17 @@ program amg_s_pde3d
real(psb_spk_) :: cthres ! threshold for ILUT factorization
integer(psb_ipk_) :: cjswp ! sweeps for GS or JAC coarsest-lev subsolver
! Dump data
logical :: dump = .false.
integer(psb_ipk_) :: dlmin ! Minimum level to dump
integer(psb_ipk_) :: dlmax ! Maximum level to dump
logical :: dump_ac = .false.
logical :: dump_rp = .false.
logical :: dump_tprol = .false.
logical :: dump_smoother = .false.
logical :: dump_solver = .false.
logical :: dump_global_num = .false.
end type precdata
type(precdata) :: p_choice
@@ -342,12 +353,12 @@ program amg_s_pde3d
call prec%set('sub_prol', p_choice%prol2, info,pos='post')
select case(trim(psb_toupper(p_choice%solve2)))
case('INVK')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set('sub_solve', p_choice%solve2, info)
case('INVT')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set('sub_solve', p_choice%solve2, info)
case('AINV')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set('ainv_alg', p_choice%variant, info)
call prec%set('sub_solve', p_choice%solve2, info)
call prec%set('ainv_alg', p_choice%variant2, info)
case default
call prec%set('sub_solve', p_choice%solve2, info, pos='post')
end select
@@ -396,6 +407,12 @@ program amg_s_pde3d
write(psb_out_unit,'(" ")')
end if
if (p_choice%dump) then
call prec%dump(info,istart=p_choice%dlmin,iend=p_choice%dlmax,&
& ac=p_choice%dump_ac,rp=p_choice%dump_rp,tprol=p_choice%dump_tprol,&
& smoother=p_choice%dump_smoother, solver=p_choice%dump_solver, &
& global_num=p_choice%dump_global_num)
end if
!
! iterative method parameters
!
@@ -534,6 +551,7 @@ contains
! preconditioner type
call read_data(prec%descr,inp_unit) ! verbose description of the prec
call read_data(prec%ptype,inp_unit) ! preconditioner type
! First smoother / 1-lev preconditioner
call read_data(prec%smther,inp_unit) ! smoother type
call read_data(prec%jsweeps,inp_unit) ! (pre-)smoother / 1-lev prec sweeps
@@ -567,8 +585,9 @@ contains
call read_data(prec%aggr_type,inp_unit) ! type of aggregation
call read_data(prec%aggr_size,inp_unit) ! Requested size of the aggregates for MATCHBOXP
call read_data(prec%aggr_ord,inp_unit) ! ordering for aggregation
call read_data(prec%aggr_filter,inp_unit) ! filtering
call read_data(prec%mncrratio,inp_unit) ! minimum aggregation ratio
call read_data(prec%aggr_filter,inp_unit) ! filtering
call read_data(prec%athres,inp_unit) ! smoothed aggr thresh
call read_data(prec%thrvsz,inp_unit) ! size of aggr thresh vector
if (prec%thrvsz > 0) then
call psb_realloc(prec%thrvsz,prec%athresv,info)
@@ -576,7 +595,6 @@ contains
else
read(inp_unit,*) ! dummy read to skip a record
end if
call read_data(prec%athres,inp_unit) ! smoothed aggr thresh
! coasest-level solver
call read_data(prec%csolve,inp_unit) ! coarsest-lev solver
call read_data(prec%csbsolve,inp_unit) ! coarsest-lev subsolver
@@ -584,6 +602,17 @@ contains
call read_data(prec%cfill,inp_unit) ! fill-in for incompl LU
call read_data(prec%cthres,inp_unit) ! Threshold for ILUT
call read_data(prec%cjswp,inp_unit) ! sweeps for GS/JAC subsolver
! dump
call read_data(prec%dump,inp_unit) ! Dump on file?
call read_data(prec%dlmin,inp_unit) ! Minimum level to dump
call read_data(prec%dlmax,inp_unit) ! Maximum level to dump
call read_data(prec%dump_ac,inp_unit)
call read_data(prec%dump_rp,inp_unit)
call read_data(prec%dump_tprol,inp_unit)
call read_data(prec%dump_smoother,inp_unit)
call read_data(prec%dump_solver,inp_unit)
call read_data(prec%dump_global_num,inp_unit)
if (inp_unit /= psb_inp_unit) then
close(inp_unit)
end if
@@ -630,6 +659,7 @@ contains
call psb_bcast(ctxt,prec%mlcycle)
call psb_bcast(ctxt,prec%outer_sweeps)
call psb_bcast(ctxt,prec%maxlevs)
call psb_bcast(ctxt,prec%csizepp)
call psb_bcast(ctxt,prec%aggr_prol)
call psb_bcast(ctxt,prec%par_aggr_alg)
@@ -645,13 +675,24 @@ contains
end if
call psb_bcast(ctxt,prec%athres)
call psb_bcast(ctxt,prec%csizepp)
call psb_bcast(ctxt,prec%cmat)
call psb_bcast(ctxt,prec%csolve)
call psb_bcast(ctxt,prec%csbsolve)
call psb_bcast(ctxt,prec%cfill)
call psb_bcast(ctxt,prec%cthres)
call psb_bcast(ctxt,prec%cjswp)
! dump
call psb_bcast(ctxt,prec%dump)
call psb_bcast(ctxt,prec%dlmin)
call psb_bcast(ctxt,prec%dlmax)
call psb_bcast(ctxt,prec%dump_ac)
call psb_bcast(ctxt,prec%dump_rp)
call psb_bcast(ctxt,prec%dump_tprol)
call psb_bcast(ctxt,prec%dump_smoother)
call psb_bcast(ctxt,prec%dump_solver)
call psb_bcast(ctxt,prec%dump_global_num)
end subroutine get_parms

Some files were not shown because too many files have changed in this diff Show More