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

Compare commits

merge into: fdurastante/amg4psblas:implement-ainv
Branches Tags
fdurastante/amg4psblas:development fdurastante/amg4psblas:mumps-devel fdurastante/amg4psblas:ExperimentMixed fdurastante/amg4psblas:communication_v2 fdurastante/amg4psblas:remap-coarse fdurastante/amg4psblas:merge-kinsol-maint fdurastante/amg4psblas:maint-1.2.0 fdurastante/amg4psblas:testmergemaint fdurastante/amg4psblas:kinsol-stop fdurastante/amg4psblas:merge-maint-par fdurastante/amg4psblas:gpucinterfaces fdurastante/amg4psblas:matrix-free fdurastante/amg4psblas:cmake fdurastante/amg4psblas:repackage fdurastante/amg4psblas:repack-newsolve fdurastante/amg4psblas:l1-and-0-aggr fdurastante/amg4psblas:l1aggregation fdurastante/amg4psblas:PolySmooth fdurastante/amg4psblas:Poly-novrl fdurastante/amg4psblas:maint-1.1 fdurastante/amg4psblas:jac_solver fdurastante/amg4psblas:master fdurastante/amg4psblas:dev-openmp fdurastante/amg4psblas:TestFerdous fdurastante/amg4psblas:omp-walther fdurastante/amg4psblas:openmp-match fdurastante/amg4psblas:maint-1.1.0 fdurastante/amg4psblas:fixmatch fdurastante/amg4psblas:tspmm fdurastante/amg4psblas:maint-1.0 fdurastante/amg4psblas:maint-1.0.1 fdurastante/amg4psblas:fix-sludist7 fdurastante/amg4psblas:savebcmatch fdurastante/amg4psblas:configry fdurastante/amg4psblas:mergeparmatch fdurastante/amg4psblas:documentation fdurastante/amg4psblas:new-context fdurastante/amg4psblas:implement-ainv fdurastante/amg4psblas:merge-amgext fdurastante/amg4psblas:unify_aggr_bld fdurastante/amg4psblas:unify_aggr_bld_richardson fdurastante/amg4psblas:pizdaint-runs fdurastante/amg4psblas:richardson fdurastante/amg4psblas:stopcriterion
fdurastante/amg4psblas:v1.2.0-1 fdurastante/amg4psblas:v1.2.0 fdurastante/amg4psblas:v1.2.0-rc3 fdurastante/amg4psblas:v1.2.0-rc2 fdurastante/amg4psblas:v1.2.0-rc1 fdurastante/amg4psblas:v1.1.2 fdurastante/amg4psblas:v1.1.1 fdurastante/amg4psblas:v1.1.0 fdurastante/amg4psblas:v1.0.1 fdurastante/amg4psblas:V1.0.0 fdurastante/amg4psblas:v1.0-rc2
..
pull from: fdurastante/amg4psblas:merge-amgext
Branches Tags
fdurastante/amg4psblas:mumps-devel fdurastante/amg4psblas:development fdurastante/amg4psblas:ExperimentMixed fdurastante/amg4psblas:communication_v2 fdurastante/amg4psblas:remap-coarse fdurastante/amg4psblas:merge-kinsol-maint fdurastante/amg4psblas:maint-1.2.0 fdurastante/amg4psblas:testmergemaint fdurastante/amg4psblas:kinsol-stop fdurastante/amg4psblas:merge-maint-par fdurastante/amg4psblas:gpucinterfaces fdurastante/amg4psblas:matrix-free fdurastante/amg4psblas:cmake fdurastante/amg4psblas:repackage fdurastante/amg4psblas:repack-newsolve fdurastante/amg4psblas:l1-and-0-aggr fdurastante/amg4psblas:l1aggregation fdurastante/amg4psblas:PolySmooth fdurastante/amg4psblas:Poly-novrl fdurastante/amg4psblas:maint-1.1 fdurastante/amg4psblas:jac_solver fdurastante/amg4psblas:master fdurastante/amg4psblas:dev-openmp fdurastante/amg4psblas:TestFerdous fdurastante/amg4psblas:omp-walther fdurastante/amg4psblas:openmp-match fdurastante/amg4psblas:maint-1.1.0 fdurastante/amg4psblas:fixmatch fdurastante/amg4psblas:tspmm fdurastante/amg4psblas:maint-1.0 fdurastante/amg4psblas:maint-1.0.1 fdurastante/amg4psblas:fix-sludist7 fdurastante/amg4psblas:savebcmatch fdurastante/amg4psblas:configry fdurastante/amg4psblas:mergeparmatch fdurastante/amg4psblas:documentation fdurastante/amg4psblas:new-context fdurastante/amg4psblas:implement-ainv fdurastante/amg4psblas:merge-amgext fdurastante/amg4psblas:unify_aggr_bld fdurastante/amg4psblas:unify_aggr_bld_richardson fdurastante/amg4psblas:pizdaint-runs fdurastante/amg4psblas:richardson fdurastante/amg4psblas:stopcriterion
fdurastante/amg4psblas:v1.2.0-1 fdurastante/amg4psblas:v1.2.0 fdurastante/amg4psblas:v1.2.0-rc3 fdurastante/amg4psblas:v1.2.0-rc2 fdurastante/amg4psblas:v1.2.0-rc1 fdurastante/amg4psblas:v1.1.2 fdurastante/amg4psblas:v1.1.1 fdurastante/amg4psblas:v1.1.0 fdurastante/amg4psblas:v1.0.1 fdurastante/amg4psblas:V1.0.0 fdurastante/amg4psblas:v1.0-rc2
1 Commits
implement-ainv .. merge-amgext
Author SHA1 Message Date
Cirdans-Home a2a1532b90 Added rkr solver 2020-11-30 23:07:52 +01:00
87 changed files with 3894 additions and 4659 deletions
Expand all files Collapse all files
amgprec/Makefile
+13 -4
View File
@@ -15,7 +15,8 @@ DMODOBJS=amg_d_prec_type.o \
amg_d_base_aggregator_mod.o \
amg_d_dec_aggregator_mod.o amg_d_symdec_aggregator_mod.o \
amg_d_ainv_solver.o amg_d_base_ainv_mod.o \
amg_d_invk_solver.o amg_d_invt_solver.o
amg_d_invk_solver.o amg_d_invt_solver.o \
amg_d_rkr_solver.o
#amg_d_bcmatch_aggregator_mod.o
SMODOBJS=amg_s_prec_type.o amg_s_ilu_fact_mod.o \
@@ -26,7 +27,8 @@ SMODOBJS=amg_s_prec_type.o amg_s_ilu_fact_mod.o \
amg_s_base_aggregator_mod.o \
amg_s_dec_aggregator_mod.o amg_s_symdec_aggregator_mod.o \
amg_s_ainv_solver.o amg_s_base_ainv_mod.o \
amg_s_invk_solver.o amg_s_invt_solver.o
amg_s_invk_solver.o amg_s_invt_solver.o \
amg_s_rkr_solver.o
ZMODOBJS=amg_z_prec_type.o amg_z_ilu_fact_mod.o \
amg_z_inner_mod.o amg_z_ilu_solver.o amg_z_diag_solver.o amg_z_jac_smoother.o amg_z_as_smoother.o \
@@ -36,7 +38,8 @@ ZMODOBJS=amg_z_prec_type.o amg_z_ilu_fact_mod.o \
amg_z_base_aggregator_mod.o \
amg_z_dec_aggregator_mod.o amg_z_symdec_aggregator_mod.o \
amg_z_ainv_solver.o amg_z_base_ainv_mod.o \
amg_z_invk_solver.o amg_z_invt_solver.o
amg_z_invk_solver.o amg_z_invt_solver.o \
amg_z_rkr_solver.o
CMODOBJS=amg_c_prec_type.o amg_c_ilu_fact_mod.o \
amg_c_inner_mod.o amg_c_ilu_solver.o amg_c_diag_solver.o amg_c_jac_smoother.o amg_c_as_smoother.o \
@@ -46,7 +49,8 @@ CMODOBJS=amg_c_prec_type.o amg_c_ilu_fact_mod.o \
amg_c_base_aggregator_mod.o \
amg_c_dec_aggregator_mod.o amg_c_symdec_aggregator_mod.o \
amg_c_ainv_solver.o amg_c_base_ainv_mod.o \
amg_c_invk_solver.o amg_c_invt_solver.o
amg_c_invk_solver.o amg_c_invt_solver.o \
amg_c_rkr_solver.o
@@ -137,6 +141,11 @@ amg_c_base_ainv_mod.o: amg_c_base_solver_mod.o amg_base_ainv_mod.o
amg_d_base_ainv_mod.o: amg_d_base_solver_mod.o amg_base_ainv_mod.o
amg_z_base_ainv_mod.o: amg_z_base_solver_mod.o amg_base_ainv_mod.o
amg_d_rkr_solver.o: amg_d_base_solver_mod.o amg_d_prec_type.o
amg_s_rkr_solver.o: amg_s_base_solver_mod.o amg_s_prec_type.o
amg_c_rkr_solver.o: amg_c_base_solver_mod.o amg_c_prec_type.o
amg_z_rkr_solver.o: amg_z_base_solver_mod.o amg_z_prec_type.o
amg_s_base_solver_mod.o amg_d_base_solver_mod.o amg_c_base_solver_mod.o amg_z_base_solver_mod.o: amg_base_prec_type.o
amg_d_mumps_solver.o amg_d_gs_solver.o amg_d_id_solver.o amg_d_sludist_solver.o amg_d_slu_solver.o \
amgprec/amg_base_prec_type.F90
-20
View File
@@ -408,28 +408,8 @@ module amg_base_prec_type
module procedure amg_d_equal_aggregation, amg_s_equal_aggregation
end interface amg_equal_aggregation
!
! default to no remapping.
! Will need a more sophisticated strategy.
!
logical, private, save :: do_remap=.false.
contains
function amg_get_do_remap() result(res)
implicit none
logical :: res
res = do_remap
end function amg_get_do_remap
subroutine amg_set_do_remap(val)
implicit none
logical, intent(in) :: val
do_remap = val
end subroutine amg_set_do_remap
!
! Function: amg_stringval
!
amgprec/amg_c_onelev_mod.f90
+19 -156
View File
@@ -152,15 +152,6 @@ module amg_c_onelev_mod
end type amg_cmlprec_wrk_type
private :: c_wrk_alloc, c_wrk_free, &
& c_wrk_clone, c_wrk_move_alloc, c_wrk_cnv, c_wrk_sizeof
type amg_c_remap_data_type
type(psb_cspmat_type) :: ac_pre_remap
type(psb_desc_type) :: desc_ac_pre_remap
integer(psb_ipk_) :: idest
integer(psb_ipk_), allocatable :: isrc(:), nrsrc(:), naggr(:)
contains
procedure, pass(rmp) :: clone => c_remap_data_clone
end type amg_c_remap_data_type
type amg_c_onelev_type
class(amg_c_base_smoother_type), allocatable :: sm, sm2a
@@ -175,8 +166,7 @@ module amg_c_onelev_mod
type(psb_cspmat_type), pointer :: base_a => null()
type(psb_desc_type), pointer :: base_desc => null()
type(psb_lcspmat_type) :: tprol
type(psb_clinmap_type) :: linmap
type(amg_c_remap_data_type) :: remap_data
type(psb_clinmap_type) :: map
real(psb_spk_) :: szratio
contains
procedure, pass(lv) :: bld_tprol => c_base_onelev_bld_tprol
@@ -206,13 +196,6 @@ module amg_c_onelev_mod
procedure, nopass :: stringval => amg_stringval
procedure, pass(lv) :: move_alloc => c_base_onelev_move_alloc
procedure, pass(lv) :: map_rstr_a => amg_c_base_onelev_map_rstr_a
procedure, pass(lv) :: map_prol_a => amg_c_base_onelev_map_prol_a
procedure, pass(lv) :: map_rstr_v => amg_c_base_onelev_map_rstr_v
procedure, pass(lv) :: map_prol_v => amg_c_base_onelev_map_prol_v
generic, public :: map_rstr => map_rstr_a, map_rstr_v
generic, public :: map_prol => map_prol_a, map_prol_v
end type amg_c_onelev_type
type amg_c_onelev_node
@@ -411,53 +394,6 @@ interface
logical, optional, intent(in) :: ac, rp, smoother, solver, tprol, global_num
end subroutine amg_c_base_onelev_dump
end interface
interface
subroutine amg_c_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
import
implicit none
class(amg_c_onelev_type), target, intent(inout) :: lv
complex(psb_spk_), intent(in) :: alpha, beta
complex(psb_spk_), intent(inout) :: u(:)
complex(psb_spk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional :: work(:)
end subroutine amg_c_base_onelev_map_rstr_a
subroutine amg_c_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,work,vtx,vty)
import
implicit none
class(amg_c_onelev_type), target, intent(inout) :: lv
complex(psb_spk_), intent(in) :: alpha, beta
type(psb_c_vect_type), intent(inout) :: vect_u, vect_v
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional :: work(:)
type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty
end subroutine amg_c_base_onelev_map_rstr_v
end interface
interface
subroutine amg_c_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
import
implicit none
class(amg_c_onelev_type), target, intent(inout) :: lv
complex(psb_spk_), intent(in) :: alpha, beta
complex(psb_spk_), intent(inout) :: u(:)
complex(psb_spk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional :: work(:)
end subroutine amg_c_base_onelev_map_prol_a
subroutine amg_c_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
import
implicit none
class(amg_c_onelev_type), target, intent(inout) :: lv
complex(psb_spk_), intent(in) :: alpha, beta
type(psb_c_vect_type), intent(inout) :: vect_u, vect_v
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional :: work(:)
type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty
end subroutine amg_c_base_onelev_map_prol_v
end interface
contains
!
@@ -487,7 +423,7 @@ contains
val = val + lv%desc_ac%sizeof()
val = val + lv%ac%sizeof()
val = val + lv%tprol%sizeof()
val = val + lv%linmap%sizeof()
val = val + lv%map%sizeof()
if (allocated(lv%sm)) val = val + lv%sm%sizeof()
if (allocated(lv%sm2a)) val = val + lv%sm2a%sizeof()
if (allocated(lv%aggr)) val = val + lv%aggr%sizeof()
@@ -617,8 +553,7 @@ contains
if (info == psb_success_) call lv%ac%clone(lvout%ac,info)
if (info == psb_success_) call lv%tprol%clone(lvout%tprol,info)
if (info == psb_success_) call lv%desc_ac%clone(lvout%desc_ac,info)
if (info == psb_success_) call lv%linmap%clone(lvout%linmap,info)
if (info == psb_success_) call lv%remap_data%clone(lvout%remap_data,info)
if (info == psb_success_) call lv%map%clone(lvout%map,info)
lvout%base_a => lv%base_a
lvout%base_desc => lv%base_desc
@@ -649,7 +584,7 @@ contains
if (info == psb_success_) call psb_move_alloc(lv%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(lv%tprol,b%tprol,info)
if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(lv%linmap,b%linmap,info)
if (info == psb_success_) call psb_move_alloc(lv%map,b%map,info)
b%base_a => lv%base_a
b%base_desc => lv%base_desc
@@ -704,17 +639,7 @@ contains
info = psb_success_
nwv = lv%get_wrksz()
if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
if (info == 0) then
if (lv%remap_data%desc_ac_pre_remap%is_asb()) then
!
! Need to fix this, we need two different allocations
!
call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold,&
& desc2=lv%remap_data%desc_ac_pre_remap)
else
call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold)
end if
end if
if (info == 0) call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold)
end subroutine c_base_onelev_allocate_wrk
@@ -734,7 +659,7 @@ contains
end if
end subroutine c_base_onelev_free_wrk
subroutine c_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
subroutine c_wrk_alloc(wk,nwv,desc,info,vmold)
use psb_base_mod
Implicit None
@@ -745,67 +670,25 @@ contains
type(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type), intent(in), optional :: vmold
type(psb_desc_type), intent(in), optional :: desc2
!
integer(psb_ipk_) :: i
info = psb_success_
call wk%free(info)
if (present(desc2)) then
!!$ write(0,*) 'Check on wrk_alloc 2',&
!!$ & desc2%get_local_rows(), desc%get_local_rows(),&
!!$ & desc2%get_local_cols(),desc%get_local_cols()
!!$ flush(0)
if (desc2%get_local_cols()>desc%get_local_cols()) then
call psb_geasb(wk%vx2l,desc2,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vy2l,desc2,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vtx,desc2,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vty,desc2,info,&
& scratch=.true.,mold=vmold)
allocate(wk%wv(nwv),stat=info)
do i=1,nwv
call psb_geasb(wk%wv(i),desc2,info,&
& scratch=.true.,mold=vmold)
end do
else
!!$ write(0,*) 'Check on wrk_alloc 1.5 ',&
!!$ & desc%get_local_rows(),&
!!$ & desc%get_local_cols()
call psb_geasb(wk%vx2l,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vy2l,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vtx,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vty,desc,info,&
& scratch=.true.,mold=vmold)
allocate(wk%wv(nwv),stat=info)
do i=1,nwv
call psb_geasb(wk%wv(i),desc,info,&
& scratch=.true.,mold=vmold)
end do
end if
else
!!$ write(0,*) 'Check on wrk_alloc 1 ',&
!!$ & desc%get_local_rows(),&
!!$ & desc%get_local_cols()
call psb_geasb(wk%vx2l,desc,info,&
call psb_geasb(wk%vx2l,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vy2l,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vtx,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vty,desc,info,&
& scratch=.true.,mold=vmold)
allocate(wk%wv(nwv),stat=info)
do i=1,nwv
call psb_geasb(wk%wv(i),desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vy2l,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vtx,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vty,desc,info,&
& scratch=.true.,mold=vmold)
allocate(wk%wv(nwv),stat=info)
do i=1,nwv
call psb_geasb(wk%wv(i),desc,info,&
& scratch=.true.,mold=vmold)
end do
end if
end do
end subroutine c_wrk_alloc
subroutine c_wrk_free(wk,info)
@@ -938,24 +821,4 @@ contains
end if
end function c_wrk_sizeof
subroutine c_remap_data_clone(rmp, remap_out, info)
use psb_base_mod
implicit none
! Arguments
class(amg_c_remap_data_type), target, intent(inout) :: rmp
class(amg_c_remap_data_type), target, intent(inout) :: remap_out
integer(psb_ipk_), intent(out) :: info
!
integer(psb_ipk_) :: i
info = psb_success_
call rmp%ac_pre_remap%clone(remap_out%ac_pre_remap,info)
if (info == psb_success_) &
& call rmp%desc_ac_pre_remap%clone(remap_out%desc_ac_pre_remap,info)
remap_out%idest = rmp%idest
call psb_safe_ab_cpy(rmp%isrc,remap_out%isrc,info)
call psb_safe_ab_cpy(rmp%nrsrc,remap_out%nrsrc,info)
end subroutine c_remap_data_clone
end module amg_c_onelev_mod
amgprec/amg_c_prec_type.f90
+10 -9
View File
@@ -738,15 +738,16 @@ contains
character(len=*), intent(in), optional :: prefix, head
logical, optional, intent(in) :: smoother, solver,ac, rp, tprol, global_num
integer(psb_ipk_) :: i, j, il1, iln, lev
type(psb_ctxt_type) :: ctxt
type(psb_ctxt_type) :: icontxt
integer(psb_ipk_) :: iam, np, iproc_
character(len=80) :: prefix_
character(len=120) :: fname ! len should be at least 20 more than
! len of prefix_
info = 0
ctxt = prec%ctxt
call psb_info(ctxt,iam,np)
icontxt = prec%ctxt
call psb_info(icontxt,iam,np)
iln = size(prec%precv)
if (present(istart)) then
il1 = max(1,istart)
@@ -811,13 +812,13 @@ contains
integer(psb_ipk_), intent(out) :: info
! Local vars
integer(psb_ipk_) :: i, j, ln, lev
type(psb_ctxt_type) :: ctxt
type(psb_ctxt_type) :: icontxt
integer(psb_ipk_) :: iam, np
info = psb_success_
select type(pout => precout)
class is (amg_cprec_type)
pout%ctxt = prec%ctxt
pout%ctxt = prec%ctxt
pout%ag_data = prec%ag_data
pout%outer_sweeps = prec%outer_sweeps
if (allocated(prec%precv)) then
@@ -833,8 +834,8 @@ contains
if (info == psb_success_) then
pout%precv(lev)%base_a => pout%precv(lev)%ac
pout%precv(lev)%base_desc => pout%precv(lev)%desc_ac
pout%precv(lev)%linmap%p_desc_U => pout%precv(lev-1)%base_desc
pout%precv(lev)%linmap%p_desc_V => pout%precv(lev)%base_desc
pout%precv(lev)%map%p_desc_U => pout%precv(lev-1)%base_desc
pout%precv(lev)%map%p_desc_V => pout%precv(lev)%base_desc
end if
end do
end if
@@ -874,8 +875,8 @@ contains
do i=2, size(b%precv)
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%linmap%p_desc_U => b%precv(i-1)%base_desc
b%precv(i)%linmap%p_desc_V => b%precv(i)%base_desc
b%precv(i)%map%p_desc_U => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_V => b%precv(i)%base_desc
end do
else
amgprec/amg_d_onelev_mod.f90
+19 -156
View File
@@ -152,15 +152,6 @@ module amg_d_onelev_mod
end type amg_dmlprec_wrk_type
private :: d_wrk_alloc, d_wrk_free, &
& d_wrk_clone, d_wrk_move_alloc, d_wrk_cnv, d_wrk_sizeof
type amg_d_remap_data_type
type(psb_dspmat_type) :: ac_pre_remap
type(psb_desc_type) :: desc_ac_pre_remap
integer(psb_ipk_) :: idest
integer(psb_ipk_), allocatable :: isrc(:), nrsrc(:), naggr(:)
contains
procedure, pass(rmp) :: clone => d_remap_data_clone
end type amg_d_remap_data_type
type amg_d_onelev_type
class(amg_d_base_smoother_type), allocatable :: sm, sm2a
@@ -175,8 +166,7 @@ module amg_d_onelev_mod
type(psb_dspmat_type), pointer :: base_a => null()
type(psb_desc_type), pointer :: base_desc => null()
type(psb_ldspmat_type) :: tprol
type(psb_dlinmap_type) :: linmap
type(amg_d_remap_data_type) :: remap_data
type(psb_dlinmap_type) :: map
real(psb_dpk_) :: szratio
contains
procedure, pass(lv) :: bld_tprol => d_base_onelev_bld_tprol
@@ -206,13 +196,6 @@ module amg_d_onelev_mod
procedure, nopass :: stringval => amg_stringval
procedure, pass(lv) :: move_alloc => d_base_onelev_move_alloc
procedure, pass(lv) :: map_rstr_a => amg_d_base_onelev_map_rstr_a
procedure, pass(lv) :: map_prol_a => amg_d_base_onelev_map_prol_a
procedure, pass(lv) :: map_rstr_v => amg_d_base_onelev_map_rstr_v
procedure, pass(lv) :: map_prol_v => amg_d_base_onelev_map_prol_v
generic, public :: map_rstr => map_rstr_a, map_rstr_v
generic, public :: map_prol => map_prol_a, map_prol_v
end type amg_d_onelev_type
type amg_d_onelev_node
@@ -411,53 +394,6 @@ interface
logical, optional, intent(in) :: ac, rp, smoother, solver, tprol, global_num
end subroutine amg_d_base_onelev_dump
end interface
interface
subroutine amg_d_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
import
implicit none
class(amg_d_onelev_type), target, intent(inout) :: lv
real(psb_dpk_), intent(in) :: alpha, beta
real(psb_dpk_), intent(inout) :: u(:)
real(psb_dpk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional :: work(:)
end subroutine amg_d_base_onelev_map_rstr_a
subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,work,vtx,vty)
import
implicit none
class(amg_d_onelev_type), target, intent(inout) :: lv
real(psb_dpk_), intent(in) :: alpha, beta
type(psb_d_vect_type), intent(inout) :: vect_u, vect_v
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional :: work(:)
type(psb_d_vect_type), optional, target, intent(inout) :: vtx,vty
end subroutine amg_d_base_onelev_map_rstr_v
end interface
interface
subroutine amg_d_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
import
implicit none
class(amg_d_onelev_type), target, intent(inout) :: lv
real(psb_dpk_), intent(in) :: alpha, beta
real(psb_dpk_), intent(inout) :: u(:)
real(psb_dpk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional :: work(:)
end subroutine amg_d_base_onelev_map_prol_a
subroutine amg_d_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
import
implicit none
class(amg_d_onelev_type), target, intent(inout) :: lv
real(psb_dpk_), intent(in) :: alpha, beta
type(psb_d_vect_type), intent(inout) :: vect_u, vect_v
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional :: work(:)
type(psb_d_vect_type), optional, target, intent(inout) :: vtx,vty
end subroutine amg_d_base_onelev_map_prol_v
end interface
contains
!
@@ -487,7 +423,7 @@ contains
val = val + lv%desc_ac%sizeof()
val = val + lv%ac%sizeof()
val = val + lv%tprol%sizeof()
val = val + lv%linmap%sizeof()
val = val + lv%map%sizeof()
if (allocated(lv%sm)) val = val + lv%sm%sizeof()
if (allocated(lv%sm2a)) val = val + lv%sm2a%sizeof()
if (allocated(lv%aggr)) val = val + lv%aggr%sizeof()
@@ -617,8 +553,7 @@ contains
if (info == psb_success_) call lv%ac%clone(lvout%ac,info)
if (info == psb_success_) call lv%tprol%clone(lvout%tprol,info)
if (info == psb_success_) call lv%desc_ac%clone(lvout%desc_ac,info)
if (info == psb_success_) call lv%linmap%clone(lvout%linmap,info)
if (info == psb_success_) call lv%remap_data%clone(lvout%remap_data,info)
if (info == psb_success_) call lv%map%clone(lvout%map,info)
lvout%base_a => lv%base_a
lvout%base_desc => lv%base_desc
@@ -649,7 +584,7 @@ contains
if (info == psb_success_) call psb_move_alloc(lv%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(lv%tprol,b%tprol,info)
if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(lv%linmap,b%linmap,info)
if (info == psb_success_) call psb_move_alloc(lv%map,b%map,info)
b%base_a => lv%base_a
b%base_desc => lv%base_desc
@@ -704,17 +639,7 @@ contains
info = psb_success_
nwv = lv%get_wrksz()
if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
if (info == 0) then
if (lv%remap_data%desc_ac_pre_remap%is_asb()) then
!
! Need to fix this, we need two different allocations
!
call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold,&
& desc2=lv%remap_data%desc_ac_pre_remap)
else
call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold)
end if
end if
if (info == 0) call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold)
end subroutine d_base_onelev_allocate_wrk
@@ -734,7 +659,7 @@ contains
end if
end subroutine d_base_onelev_free_wrk
subroutine d_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
subroutine d_wrk_alloc(wk,nwv,desc,info,vmold)
use psb_base_mod
Implicit None
@@ -745,67 +670,25 @@ contains
type(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type), intent(in), optional :: vmold
type(psb_desc_type), intent(in), optional :: desc2
!
integer(psb_ipk_) :: i
info = psb_success_
call wk%free(info)
if (present(desc2)) then
!!$ write(0,*) 'Check on wrk_alloc 2',&
!!$ & desc2%get_local_rows(), desc%get_local_rows(),&
!!$ & desc2%get_local_cols(),desc%get_local_cols()
!!$ flush(0)
if (desc2%get_local_cols()>desc%get_local_cols()) then
call psb_geasb(wk%vx2l,desc2,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vy2l,desc2,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vtx,desc2,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vty,desc2,info,&
& scratch=.true.,mold=vmold)
allocate(wk%wv(nwv),stat=info)
do i=1,nwv
call psb_geasb(wk%wv(i),desc2,info,&
& scratch=.true.,mold=vmold)
end do
else
!!$ write(0,*) 'Check on wrk_alloc 1.5 ',&
!!$ & desc%get_local_rows(),&
!!$ & desc%get_local_cols()
call psb_geasb(wk%vx2l,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vy2l,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vtx,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vty,desc,info,&
& scratch=.true.,mold=vmold)
allocate(wk%wv(nwv),stat=info)
do i=1,nwv
call psb_geasb(wk%wv(i),desc,info,&
& scratch=.true.,mold=vmold)
end do
end if
else
!!$ write(0,*) 'Check on wrk_alloc 1 ',&
!!$ & desc%get_local_rows(),&
!!$ & desc%get_local_cols()
call psb_geasb(wk%vx2l,desc,info,&
call psb_geasb(wk%vx2l,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vy2l,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vtx,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vty,desc,info,&
& scratch=.true.,mold=vmold)
allocate(wk%wv(nwv),stat=info)
do i=1,nwv
call psb_geasb(wk%wv(i),desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vy2l,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vtx,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vty,desc,info,&
& scratch=.true.,mold=vmold)
allocate(wk%wv(nwv),stat=info)
do i=1,nwv
call psb_geasb(wk%wv(i),desc,info,&
& scratch=.true.,mold=vmold)
end do
end if
end do
end subroutine d_wrk_alloc
subroutine d_wrk_free(wk,info)
@@ -938,24 +821,4 @@ contains
end if
end function d_wrk_sizeof
subroutine d_remap_data_clone(rmp, remap_out, info)
use psb_base_mod
implicit none
! Arguments
class(amg_d_remap_data_type), target, intent(inout) :: rmp
class(amg_d_remap_data_type), target, intent(inout) :: remap_out
integer(psb_ipk_), intent(out) :: info
!
integer(psb_ipk_) :: i
info = psb_success_
call rmp%ac_pre_remap%clone(remap_out%ac_pre_remap,info)
if (info == psb_success_) &
& call rmp%desc_ac_pre_remap%clone(remap_out%desc_ac_pre_remap,info)
remap_out%idest = rmp%idest
call psb_safe_ab_cpy(rmp%isrc,remap_out%isrc,info)
call psb_safe_ab_cpy(rmp%nrsrc,remap_out%nrsrc,info)
end subroutine d_remap_data_clone
end module amg_d_onelev_mod
amgprec/amg_d_prec_type.f90
+10 -9
View File
@@ -738,15 +738,16 @@ contains
character(len=*), intent(in), optional :: prefix, head
logical, optional, intent(in) :: smoother, solver,ac, rp, tprol, global_num
integer(psb_ipk_) :: i, j, il1, iln, lev
type(psb_ctxt_type) :: ctxt
type(psb_ctxt_type) :: icontxt
integer(psb_ipk_) :: iam, np, iproc_
character(len=80) :: prefix_
character(len=120) :: fname ! len should be at least 20 more than
! len of prefix_
info = 0
ctxt = prec%ctxt
call psb_info(ctxt,iam,np)
icontxt = prec%ctxt
call psb_info(icontxt,iam,np)
iln = size(prec%precv)
if (present(istart)) then
il1 = max(1,istart)
@@ -811,13 +812,13 @@ contains
integer(psb_ipk_), intent(out) :: info
! Local vars
integer(psb_ipk_) :: i, j, ln, lev
type(psb_ctxt_type) :: ctxt
type(psb_ctxt_type) :: icontxt
integer(psb_ipk_) :: iam, np
info = psb_success_
select type(pout => precout)
class is (amg_dprec_type)
pout%ctxt = prec%ctxt
pout%ctxt = prec%ctxt
pout%ag_data = prec%ag_data
pout%outer_sweeps = prec%outer_sweeps
if (allocated(prec%precv)) then
@@ -833,8 +834,8 @@ contains
if (info == psb_success_) then
pout%precv(lev)%base_a => pout%precv(lev)%ac
pout%precv(lev)%base_desc => pout%precv(lev)%desc_ac
pout%precv(lev)%linmap%p_desc_U => pout%precv(lev-1)%base_desc
pout%precv(lev)%linmap%p_desc_V => pout%precv(lev)%base_desc
pout%precv(lev)%map%p_desc_U => pout%precv(lev-1)%base_desc
pout%precv(lev)%map%p_desc_V => pout%precv(lev)%base_desc
end if
end do
end if
@@ -874,8 +875,8 @@ contains
do i=2, size(b%precv)
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%linmap%p_desc_U => b%precv(i-1)%base_desc
b%precv(i)%linmap%p_desc_V => b%precv(i)%base_desc
b%precv(i)%map%p_desc_U => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_V => b%precv(i)%base_desc
end do
else
amgprec/amg_s_onelev_mod.f90
+19 -156
View File
@@ -152,15 +152,6 @@ module amg_s_onelev_mod
end type amg_smlprec_wrk_type
private :: s_wrk_alloc, s_wrk_free, &
& s_wrk_clone, s_wrk_move_alloc, s_wrk_cnv, s_wrk_sizeof
type amg_s_remap_data_type
type(psb_sspmat_type) :: ac_pre_remap
type(psb_desc_type) :: desc_ac_pre_remap
integer(psb_ipk_) :: idest
integer(psb_ipk_), allocatable :: isrc(:), nrsrc(:), naggr(:)
contains
procedure, pass(rmp) :: clone => s_remap_data_clone
end type amg_s_remap_data_type
type amg_s_onelev_type
class(amg_s_base_smoother_type), allocatable :: sm, sm2a
@@ -175,8 +166,7 @@ module amg_s_onelev_mod
type(psb_sspmat_type), pointer :: base_a => null()
type(psb_desc_type), pointer :: base_desc => null()
type(psb_lsspmat_type) :: tprol
type(psb_slinmap_type) :: linmap
type(amg_s_remap_data_type) :: remap_data
type(psb_slinmap_type) :: map
real(psb_spk_) :: szratio
contains
procedure, pass(lv) :: bld_tprol => s_base_onelev_bld_tprol
@@ -206,13 +196,6 @@ module amg_s_onelev_mod
procedure, nopass :: stringval => amg_stringval
procedure, pass(lv) :: move_alloc => s_base_onelev_move_alloc
procedure, pass(lv) :: map_rstr_a => amg_s_base_onelev_map_rstr_a
procedure, pass(lv) :: map_prol_a => amg_s_base_onelev_map_prol_a
procedure, pass(lv) :: map_rstr_v => amg_s_base_onelev_map_rstr_v
procedure, pass(lv) :: map_prol_v => amg_s_base_onelev_map_prol_v
generic, public :: map_rstr => map_rstr_a, map_rstr_v
generic, public :: map_prol => map_prol_a, map_prol_v
end type amg_s_onelev_type
type amg_s_onelev_node
@@ -411,53 +394,6 @@ interface
logical, optional, intent(in) :: ac, rp, smoother, solver, tprol, global_num
end subroutine amg_s_base_onelev_dump
end interface
interface
subroutine amg_s_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
import
implicit none
class(amg_s_onelev_type), target, intent(inout) :: lv
real(psb_spk_), intent(in) :: alpha, beta
real(psb_spk_), intent(inout) :: u(:)
real(psb_spk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional :: work(:)
end subroutine amg_s_base_onelev_map_rstr_a
subroutine amg_s_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,work,vtx,vty)
import
implicit none
class(amg_s_onelev_type), target, intent(inout) :: lv
real(psb_spk_), intent(in) :: alpha, beta
type(psb_s_vect_type), intent(inout) :: vect_u, vect_v
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional :: work(:)
type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty
end subroutine amg_s_base_onelev_map_rstr_v
end interface
interface
subroutine amg_s_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
import
implicit none
class(amg_s_onelev_type), target, intent(inout) :: lv
real(psb_spk_), intent(in) :: alpha, beta
real(psb_spk_), intent(inout) :: u(:)
real(psb_spk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional :: work(:)
end subroutine amg_s_base_onelev_map_prol_a
subroutine amg_s_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
import
implicit none
class(amg_s_onelev_type), target, intent(inout) :: lv
real(psb_spk_), intent(in) :: alpha, beta
type(psb_s_vect_type), intent(inout) :: vect_u, vect_v
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional :: work(:)
type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty
end subroutine amg_s_base_onelev_map_prol_v
end interface
contains
!
@@ -487,7 +423,7 @@ contains
val = val + lv%desc_ac%sizeof()
val = val + lv%ac%sizeof()
val = val + lv%tprol%sizeof()
val = val + lv%linmap%sizeof()
val = val + lv%map%sizeof()
if (allocated(lv%sm)) val = val + lv%sm%sizeof()
if (allocated(lv%sm2a)) val = val + lv%sm2a%sizeof()
if (allocated(lv%aggr)) val = val + lv%aggr%sizeof()
@@ -617,8 +553,7 @@ contains
if (info == psb_success_) call lv%ac%clone(lvout%ac,info)
if (info == psb_success_) call lv%tprol%clone(lvout%tprol,info)
if (info == psb_success_) call lv%desc_ac%clone(lvout%desc_ac,info)
if (info == psb_success_) call lv%linmap%clone(lvout%linmap,info)
if (info == psb_success_) call lv%remap_data%clone(lvout%remap_data,info)
if (info == psb_success_) call lv%map%clone(lvout%map,info)
lvout%base_a => lv%base_a
lvout%base_desc => lv%base_desc
@@ -649,7 +584,7 @@ contains
if (info == psb_success_) call psb_move_alloc(lv%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(lv%tprol,b%tprol,info)
if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(lv%linmap,b%linmap,info)
if (info == psb_success_) call psb_move_alloc(lv%map,b%map,info)
b%base_a => lv%base_a
b%base_desc => lv%base_desc
@@ -704,17 +639,7 @@ contains
info = psb_success_
nwv = lv%get_wrksz()
if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
if (info == 0) then
if (lv%remap_data%desc_ac_pre_remap%is_asb()) then
!
! Need to fix this, we need two different allocations
!
call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold,&
& desc2=lv%remap_data%desc_ac_pre_remap)
else
call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold)
end if
end if
if (info == 0) call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold)
end subroutine s_base_onelev_allocate_wrk
@@ -734,7 +659,7 @@ contains
end if
end subroutine s_base_onelev_free_wrk
subroutine s_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
subroutine s_wrk_alloc(wk,nwv,desc,info,vmold)
use psb_base_mod
Implicit None
@@ -745,67 +670,25 @@ contains
type(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type), intent(in), optional :: vmold
type(psb_desc_type), intent(in), optional :: desc2
!
integer(psb_ipk_) :: i
info = psb_success_
call wk%free(info)
if (present(desc2)) then
!!$ write(0,*) 'Check on wrk_alloc 2',&
!!$ & desc2%get_local_rows(), desc%get_local_rows(),&
!!$ & desc2%get_local_cols(),desc%get_local_cols()
!!$ flush(0)
if (desc2%get_local_cols()>desc%get_local_cols()) then
call psb_geasb(wk%vx2l,desc2,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vy2l,desc2,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vtx,desc2,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vty,desc2,info,&
& scratch=.true.,mold=vmold)
allocate(wk%wv(nwv),stat=info)
do i=1,nwv
call psb_geasb(wk%wv(i),desc2,info,&
& scratch=.true.,mold=vmold)
end do
else
!!$ write(0,*) 'Check on wrk_alloc 1.5 ',&
!!$ & desc%get_local_rows(),&
!!$ & desc%get_local_cols()
call psb_geasb(wk%vx2l,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vy2l,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vtx,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vty,desc,info,&
& scratch=.true.,mold=vmold)
allocate(wk%wv(nwv),stat=info)
do i=1,nwv
call psb_geasb(wk%wv(i),desc,info,&
& scratch=.true.,mold=vmold)
end do
end if
else
!!$ write(0,*) 'Check on wrk_alloc 1 ',&
!!$ & desc%get_local_rows(),&
!!$ & desc%get_local_cols()
call psb_geasb(wk%vx2l,desc,info,&
call psb_geasb(wk%vx2l,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vy2l,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vtx,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vty,desc,info,&
& scratch=.true.,mold=vmold)
allocate(wk%wv(nwv),stat=info)
do i=1,nwv
call psb_geasb(wk%wv(i),desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vy2l,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vtx,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vty,desc,info,&
& scratch=.true.,mold=vmold)
allocate(wk%wv(nwv),stat=info)
do i=1,nwv
call psb_geasb(wk%wv(i),desc,info,&
& scratch=.true.,mold=vmold)
end do
end if
end do
end subroutine s_wrk_alloc
subroutine s_wrk_free(wk,info)
@@ -938,24 +821,4 @@ contains
end if
end function s_wrk_sizeof
subroutine s_remap_data_clone(rmp, remap_out, info)
use psb_base_mod
implicit none
! Arguments
class(amg_s_remap_data_type), target, intent(inout) :: rmp
class(amg_s_remap_data_type), target, intent(inout) :: remap_out
integer(psb_ipk_), intent(out) :: info
!
integer(psb_ipk_) :: i
info = psb_success_
call rmp%ac_pre_remap%clone(remap_out%ac_pre_remap,info)
if (info == psb_success_) &
& call rmp%desc_ac_pre_remap%clone(remap_out%desc_ac_pre_remap,info)
remap_out%idest = rmp%idest
call psb_safe_ab_cpy(rmp%isrc,remap_out%isrc,info)
call psb_safe_ab_cpy(rmp%nrsrc,remap_out%nrsrc,info)
end subroutine s_remap_data_clone
end module amg_s_onelev_mod
amgprec/amg_s_prec_type.f90
+10 -9
View File
@@ -738,15 +738,16 @@ contains
character(len=*), intent(in), optional :: prefix, head
logical, optional, intent(in) :: smoother, solver,ac, rp, tprol, global_num
integer(psb_ipk_) :: i, j, il1, iln, lev
type(psb_ctxt_type) :: ctxt
type(psb_ctxt_type) :: icontxt
integer(psb_ipk_) :: iam, np, iproc_
character(len=80) :: prefix_
character(len=120) :: fname ! len should be at least 20 more than
! len of prefix_
info = 0
ctxt = prec%ctxt
call psb_info(ctxt,iam,np)
icontxt = prec%ctxt
call psb_info(icontxt,iam,np)
iln = size(prec%precv)
if (present(istart)) then
il1 = max(1,istart)
@@ -811,13 +812,13 @@ contains
integer(psb_ipk_), intent(out) :: info
! Local vars
integer(psb_ipk_) :: i, j, ln, lev
type(psb_ctxt_type) :: ctxt
type(psb_ctxt_type) :: icontxt
integer(psb_ipk_) :: iam, np
info = psb_success_
select type(pout => precout)
class is (amg_sprec_type)
pout%ctxt = prec%ctxt
pout%ctxt = prec%ctxt
pout%ag_data = prec%ag_data
pout%outer_sweeps = prec%outer_sweeps
if (allocated(prec%precv)) then
@@ -833,8 +834,8 @@ contains
if (info == psb_success_) then
pout%precv(lev)%base_a => pout%precv(lev)%ac
pout%precv(lev)%base_desc => pout%precv(lev)%desc_ac
pout%precv(lev)%linmap%p_desc_U => pout%precv(lev-1)%base_desc
pout%precv(lev)%linmap%p_desc_V => pout%precv(lev)%base_desc
pout%precv(lev)%map%p_desc_U => pout%precv(lev-1)%base_desc
pout%precv(lev)%map%p_desc_V => pout%precv(lev)%base_desc
end if
end do
end if
@@ -874,8 +875,8 @@ contains
do i=2, size(b%precv)
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%linmap%p_desc_U => b%precv(i-1)%base_desc
b%precv(i)%linmap%p_desc_V => b%precv(i)%base_desc
b%precv(i)%map%p_desc_U => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_V => b%precv(i)%base_desc
end do
else
amgprec/amg_z_onelev_mod.f90
+19 -156
View File
@@ -152,15 +152,6 @@ module amg_z_onelev_mod
end type amg_zmlprec_wrk_type
private :: z_wrk_alloc, z_wrk_free, &
& z_wrk_clone, z_wrk_move_alloc, z_wrk_cnv, z_wrk_sizeof
type amg_z_remap_data_type
type(psb_zspmat_type) :: ac_pre_remap
type(psb_desc_type) :: desc_ac_pre_remap
integer(psb_ipk_) :: idest
integer(psb_ipk_), allocatable :: isrc(:), nrsrc(:), naggr(:)
contains
procedure, pass(rmp) :: clone => z_remap_data_clone
end type amg_z_remap_data_type
type amg_z_onelev_type
class(amg_z_base_smoother_type), allocatable :: sm, sm2a
@@ -175,8 +166,7 @@ module amg_z_onelev_mod
type(psb_zspmat_type), pointer :: base_a => null()
type(psb_desc_type), pointer :: base_desc => null()
type(psb_lzspmat_type) :: tprol
type(psb_zlinmap_type) :: linmap
type(amg_z_remap_data_type) :: remap_data
type(psb_zlinmap_type) :: map
real(psb_dpk_) :: szratio
contains
procedure, pass(lv) :: bld_tprol => z_base_onelev_bld_tprol
@@ -206,13 +196,6 @@ module amg_z_onelev_mod
procedure, nopass :: stringval => amg_stringval
procedure, pass(lv) :: move_alloc => z_base_onelev_move_alloc
procedure, pass(lv) :: map_rstr_a => amg_z_base_onelev_map_rstr_a
procedure, pass(lv) :: map_prol_a => amg_z_base_onelev_map_prol_a
procedure, pass(lv) :: map_rstr_v => amg_z_base_onelev_map_rstr_v
procedure, pass(lv) :: map_prol_v => amg_z_base_onelev_map_prol_v
generic, public :: map_rstr => map_rstr_a, map_rstr_v
generic, public :: map_prol => map_prol_a, map_prol_v
end type amg_z_onelev_type
type amg_z_onelev_node
@@ -411,53 +394,6 @@ interface
logical, optional, intent(in) :: ac, rp, smoother, solver, tprol, global_num
end subroutine amg_z_base_onelev_dump
end interface
interface
subroutine amg_z_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
import
implicit none
class(amg_z_onelev_type), target, intent(inout) :: lv
complex(psb_dpk_), intent(in) :: alpha, beta
complex(psb_dpk_), intent(inout) :: u(:)
complex(psb_dpk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional :: work(:)
end subroutine amg_z_base_onelev_map_rstr_a
subroutine amg_z_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,work,vtx,vty)
import
implicit none
class(amg_z_onelev_type), target, intent(inout) :: lv
complex(psb_dpk_), intent(in) :: alpha, beta
type(psb_z_vect_type), intent(inout) :: vect_u, vect_v
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional :: work(:)
type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty
end subroutine amg_z_base_onelev_map_rstr_v
end interface
interface
subroutine amg_z_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
import
implicit none
class(amg_z_onelev_type), target, intent(inout) :: lv
complex(psb_dpk_), intent(in) :: alpha, beta
complex(psb_dpk_), intent(inout) :: u(:)
complex(psb_dpk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional :: work(:)
end subroutine amg_z_base_onelev_map_prol_a
subroutine amg_z_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
import
implicit none
class(amg_z_onelev_type), target, intent(inout) :: lv
complex(psb_dpk_), intent(in) :: alpha, beta
type(psb_z_vect_type), intent(inout) :: vect_u, vect_v
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional :: work(:)
type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty
end subroutine amg_z_base_onelev_map_prol_v
end interface
contains
!
@@ -487,7 +423,7 @@ contains
val = val + lv%desc_ac%sizeof()
val = val + lv%ac%sizeof()
val = val + lv%tprol%sizeof()
val = val + lv%linmap%sizeof()
val = val + lv%map%sizeof()
if (allocated(lv%sm)) val = val + lv%sm%sizeof()
if (allocated(lv%sm2a)) val = val + lv%sm2a%sizeof()
if (allocated(lv%aggr)) val = val + lv%aggr%sizeof()
@@ -617,8 +553,7 @@ contains
if (info == psb_success_) call lv%ac%clone(lvout%ac,info)
if (info == psb_success_) call lv%tprol%clone(lvout%tprol,info)
if (info == psb_success_) call lv%desc_ac%clone(lvout%desc_ac,info)
if (info == psb_success_) call lv%linmap%clone(lvout%linmap,info)
if (info == psb_success_) call lv%remap_data%clone(lvout%remap_data,info)
if (info == psb_success_) call lv%map%clone(lvout%map,info)
lvout%base_a => lv%base_a
lvout%base_desc => lv%base_desc
@@ -649,7 +584,7 @@ contains
if (info == psb_success_) call psb_move_alloc(lv%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(lv%tprol,b%tprol,info)
if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(lv%linmap,b%linmap,info)
if (info == psb_success_) call psb_move_alloc(lv%map,b%map,info)
b%base_a => lv%base_a
b%base_desc => lv%base_desc
@@ -704,17 +639,7 @@ contains
info = psb_success_
nwv = lv%get_wrksz()
if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
if (info == 0) then
if (lv%remap_data%desc_ac_pre_remap%is_asb()) then
!
! Need to fix this, we need two different allocations
!
call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold,&
& desc2=lv%remap_data%desc_ac_pre_remap)
else
call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold)
end if
end if
if (info == 0) call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold)
end subroutine z_base_onelev_allocate_wrk
@@ -734,7 +659,7 @@ contains
end if
end subroutine z_base_onelev_free_wrk
subroutine z_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
subroutine z_wrk_alloc(wk,nwv,desc,info,vmold)
use psb_base_mod
Implicit None
@@ -745,67 +670,25 @@ contains
type(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type), intent(in), optional :: vmold
type(psb_desc_type), intent(in), optional :: desc2
!
integer(psb_ipk_) :: i
info = psb_success_
call wk%free(info)
if (present(desc2)) then
!!$ write(0,*) 'Check on wrk_alloc 2',&
!!$ & desc2%get_local_rows(), desc%get_local_rows(),&
!!$ & desc2%get_local_cols(),desc%get_local_cols()
!!$ flush(0)
if (desc2%get_local_cols()>desc%get_local_cols()) then
call psb_geasb(wk%vx2l,desc2,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vy2l,desc2,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vtx,desc2,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vty,desc2,info,&
& scratch=.true.,mold=vmold)
allocate(wk%wv(nwv),stat=info)
do i=1,nwv
call psb_geasb(wk%wv(i),desc2,info,&
& scratch=.true.,mold=vmold)
end do
else
!!$ write(0,*) 'Check on wrk_alloc 1.5 ',&
!!$ & desc%get_local_rows(),&
!!$ & desc%get_local_cols()
call psb_geasb(wk%vx2l,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vy2l,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vtx,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vty,desc,info,&
& scratch=.true.,mold=vmold)
allocate(wk%wv(nwv),stat=info)
do i=1,nwv
call psb_geasb(wk%wv(i),desc,info,&
& scratch=.true.,mold=vmold)
end do
end if
else
!!$ write(0,*) 'Check on wrk_alloc 1 ',&
!!$ & desc%get_local_rows(),&
!!$ & desc%get_local_cols()
call psb_geasb(wk%vx2l,desc,info,&
call psb_geasb(wk%vx2l,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vy2l,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vtx,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vty,desc,info,&
& scratch=.true.,mold=vmold)
allocate(wk%wv(nwv),stat=info)
do i=1,nwv
call psb_geasb(wk%wv(i),desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vy2l,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vtx,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vty,desc,info,&
& scratch=.true.,mold=vmold)
allocate(wk%wv(nwv),stat=info)
do i=1,nwv
call psb_geasb(wk%wv(i),desc,info,&
& scratch=.true.,mold=vmold)
end do
end if
end do
end subroutine z_wrk_alloc
subroutine z_wrk_free(wk,info)
@@ -938,24 +821,4 @@ contains
end if
end function z_wrk_sizeof
subroutine z_remap_data_clone(rmp, remap_out, info)
use psb_base_mod
implicit none
! Arguments
class(amg_z_remap_data_type), target, intent(inout) :: rmp
class(amg_z_remap_data_type), target, intent(inout) :: remap_out
integer(psb_ipk_), intent(out) :: info
!
integer(psb_ipk_) :: i
info = psb_success_
call rmp%ac_pre_remap%clone(remap_out%ac_pre_remap,info)
if (info == psb_success_) &
& call rmp%desc_ac_pre_remap%clone(remap_out%desc_ac_pre_remap,info)
remap_out%idest = rmp%idest
call psb_safe_ab_cpy(rmp%isrc,remap_out%isrc,info)
call psb_safe_ab_cpy(rmp%nrsrc,remap_out%nrsrc,info)
end subroutine z_remap_data_clone
end module amg_z_onelev_mod
amgprec/amg_z_prec_type.f90
+10 -9
View File
@@ -738,15 +738,16 @@ contains
character(len=*), intent(in), optional :: prefix, head
logical, optional, intent(in) :: smoother, solver,ac, rp, tprol, global_num
integer(psb_ipk_) :: i, j, il1, iln, lev
type(psb_ctxt_type) :: ctxt
type(psb_ctxt_type) :: icontxt
integer(psb_ipk_) :: iam, np, iproc_
character(len=80) :: prefix_
character(len=120) :: fname ! len should be at least 20 more than
! len of prefix_
info = 0
ctxt = prec%ctxt
call psb_info(ctxt,iam,np)
icontxt = prec%ctxt
call psb_info(icontxt,iam,np)
iln = size(prec%precv)
if (present(istart)) then
il1 = max(1,istart)
@@ -811,13 +812,13 @@ contains
integer(psb_ipk_), intent(out) :: info
! Local vars
integer(psb_ipk_) :: i, j, ln, lev
type(psb_ctxt_type) :: ctxt
type(psb_ctxt_type) :: icontxt
integer(psb_ipk_) :: iam, np
info = psb_success_
select type(pout => precout)
class is (amg_zprec_type)
pout%ctxt = prec%ctxt
pout%ctxt = prec%ctxt
pout%ag_data = prec%ag_data
pout%outer_sweeps = prec%outer_sweeps
if (allocated(prec%precv)) then
@@ -833,8 +834,8 @@ contains
if (info == psb_success_) then
pout%precv(lev)%base_a => pout%precv(lev)%ac
pout%precv(lev)%base_desc => pout%precv(lev)%desc_ac
pout%precv(lev)%linmap%p_desc_U => pout%precv(lev-1)%base_desc
pout%precv(lev)%linmap%p_desc_V => pout%precv(lev)%base_desc
pout%precv(lev)%map%p_desc_U => pout%precv(lev-1)%base_desc
pout%precv(lev)%map%p_desc_V => pout%precv(lev)%base_desc
end if
end do
end if
@@ -874,8 +875,8 @@ contains
do i=2, size(b%precv)
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%linmap%p_desc_U => b%precv(i-1)%base_desc
b%precv(i)%linmap%p_desc_V => b%precv(i)%base_desc
b%precv(i)%map%p_desc_U => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_V => b%precv(i)%base_desc
end do
else
amgprec/impl/amg_c_hierarchy_bld.f90
+6 -31
View File
@@ -334,7 +334,7 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info)
if (i==2) then
sizeratio = desc_a%get_global_rows()/sizeratio
else
sizeratio = sum(prec%precv(i-1)%linmap%naggr)/sizeratio
sizeratio = sum(prec%precv(i-1)%map%naggr)/sizeratio
end if
prec%precv(i)%szratio = sizeratio
@@ -353,7 +353,7 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info)
end if
end if
if (all(nlaggr == prec%precv(i-1)%linmap%naggr)) then
if (all(nlaggr == prec%precv(i-1)%map%naggr)) then
newsz=i-1
if (me == 0) then
write(debug_unit,*) trim(name),&
@@ -388,8 +388,8 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info)
! We are going back and revisit a previous leve;
! recover the aggregation.
!
ilaggr = prec%precv(newsz)%linmap%iaggr
nlaggr = prec%precv(newsz)%linmap%naggr
ilaggr = prec%precv(newsz)%map%iaggr
nlaggr = prec%precv(newsz)%map%naggr
call prec%precv(newsz)%tprol%clone(op_prol,info)
end if
if (do_timings) call psb_tic(idx_matasb)
@@ -450,36 +450,11 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info)
do i=2, iszv
prec%precv(i)%base_a => prec%precv(i)%ac
prec%precv(i)%base_desc => prec%precv(i)%desc_ac
prec%precv(i)%linmap%p_desc_U => prec%precv(i-1)%base_desc
prec%precv(i)%linmap%p_desc_V => prec%precv(i)%base_desc
prec%precv(i)%map%p_desc_U => prec%precv(i-1)%base_desc
prec%precv(i)%map%p_desc_V => prec%precv(i)%base_desc
end do
end if
!write(0,*) 'Should we remap? '
if (amg_get_do_remap().and.(np>=4)) then
write(0,*) 'Going for remapping '
if (.true.) then
associate(lv=>prec%precv(iszv), rmp => prec%precv(iszv)%remap_data)
call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info)
call lv%ac%clone(rmp%ac_pre_remap,info)
if (np >= 8) then
call psb_remap(np/4,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
& rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
else
call psb_remap(np/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
& rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
end if
write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',&
& lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr)
lv%linmap%naggr(:) = rmp%naggr(:)
lv%linmap%p_desc_V => rmp%desc_ac_pre_remap
lv%base_a => lv%ac
lv%base_desc => lv%desc_ac
end associate
end if
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Internal hierarchy build' )
amgprec/impl/amg_c_hierarchy_rebld.f90
+3 -3
View File
@@ -127,9 +127,9 @@ subroutine amg_c_hierarchy_rebld(a,desc_a,prec,info)
do i=2, iszv
call prec%precv(i-1)%base_a%cp_to(acsr)
p_desc_a => prec%precv(i-1)%base_desc
call prec%precv(i)%linmap%mat_V2U%cp_to(coo_prol)
call prec%precv(i)%linmap%mat_U2V%cp_to(coo_restr)
call amg_rap(acsr,p_desc_a,prec%precv(i)%linmap%naggr,&
call prec%precv(i)%map%mat_V2U%cp_to(coo_prol)
call prec%precv(i)%map%mat_U2V%cp_to(coo_restr)
call amg_rap(acsr,p_desc_a,prec%precv(i)%map%naggr,&
& prec%precv(i)%parms,prec%precv(i)%ac,&
& coo_prol,prec%precv(i)%desc_ac,coo_restr,info)
amgprec/impl/amg_c_smoothers_bld.f90
-6
View File
@@ -117,10 +117,6 @@ subroutine amg_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
info = psb_success_
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (me <0) then
!!$ write(0,*) 'out of CTXT, should not do anything '
goto 9998
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
@@ -293,7 +289,6 @@ subroutine amg_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
!
! build the base preconditioner at level i
!
!!$ write(0,*) me,' Building at level ',i
call prec%precv(i)%bld(info,amold=amold,vmold=vmold,imold=imold,ilv=i)
if (info /= psb_success_) then
@@ -309,7 +304,6 @@ subroutine amg_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& write(debug_unit,*) me,' ',trim(name),&
& 'Exiting with',iszv,' levels'
9998 continue
call psb_erractionrestore(err_act)
return
amgprec/impl/amg_ccprecset.F90
+455 -304
View File
File diff suppressed because it is too large Load Diff
amgprec/impl/amg_cmlprec_aply.f90
+193 -207
View File
@@ -393,39 +393,38 @@ contains
if(debug_level > 1) then
write(debug_unit,*) me,' Start inner_ml_aply at level ',level, info
end if
if (me >= 0) then
select case(p%precv(level)%parms%ml_cycle)
case(amg_no_ml_)
!
! No preconditioning, should not really get here
!
call psb_errpush(psb_err_internal_error_,name,&
& a_err='amg_no_ml_ in mlprc_aply?')
goto 9999
case(amg_add_ml_)
call amg_c_inner_add(p, level, trans, work)
case(amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_)
call amg_c_inner_mult(p, level, trans, work)
case(amg_kcycle_ml_, amg_kcyclesym_ml_)
call amg_c_inner_k_cycle(p, level, trans, work)
case default
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='invalid ml_cycle',&
& i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
goto 9999
end select
if(debug_level > 1) then
write(debug_unit,*) me,' End inner_ml_aply at level ',level
end if
select case(p%precv(level)%parms%ml_cycle)
case(amg_no_ml_)
!
! No preconditioning, should not really get here
!
call psb_errpush(psb_err_internal_error_,name,&
& a_err='amg_no_ml_ in mlprc_aply?')
goto 9999
case(amg_add_ml_)
call amg_c_inner_add(p, level, trans, work)
case(amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_)
call amg_c_inner_mult(p, level, trans, work)
case(amg_kcycle_ml_, amg_kcyclesym_ml_)
call amg_c_inner_k_cycle(p, level, trans, work)
case default
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='invalid ml_cycle',&
& i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
goto 9999
end select
if(debug_level > 1) then
write(debug_unit,*) me,' End inner_ml_aply at level ',level
end if
call psb_erractionrestore(err_act)
@@ -493,30 +492,28 @@ contains
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv)
if (me >= 0) then
if (allocated(p%precv(level)%sm2a)) then
call psb_geaxpby(cone,vx2l,czero,vy2l,base_desc,info)
sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post)
do k=1, sweeps
call p%precv(level)%sm%apply(cone,&
& vy2l,czero,vty,&
& base_desc, trans,&
& ione,work,wv,info,init='Z')
call p%precv(level)%sm2a%apply(cone,&
& vty,czero,vy2l,&
& base_desc, trans,&
& ione,work,wv,info,init='Z')
end do
else
sweeps = p%precv(level)%parms%sweeps_pre
if (allocated(p%precv(level)%sm2a)) then
call psb_geaxpby(cone,vx2l,czero,vy2l,base_desc,info)
sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post)
do k=1, sweeps
call p%precv(level)%sm%apply(cone,&
& vx2l,czero,vy2l,&
& vy2l,czero,vty,&
& base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
& ione,work,wv,info,init='Z')
call p%precv(level)%sm2a%apply(cone,&
& vty,czero,vy2l,&
& base_desc, trans,&
& ione,work,wv,info,init='Z')
end do
else
sweeps = p%precv(level)%parms%sweeps_pre
call p%precv(level)%sm%apply(cone,&
& vx2l,czero,vy2l,&
& base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@@ -526,7 +523,7 @@ contains
if (level < nlev) then
! Apply the restriction
call p%precv(level+1)%map_rstr(cone,vx2l,&
call p%precv(level+1)%map%map_U2V(cone,vx2l,&
& czero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -546,7 +543,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map_prol(cone,&
call p%precv(level+1)%map%map_V2U(cone,&
& p%precv(level+1)%wrk%vy2l, cone,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -605,6 +602,7 @@ contains
end if
ctxt = p%precv(level)%base_desc%get_context()
call psb_info(ctxt, me, np)
if(debug_level > 1) then
write(debug_unit,*) me,' inner_mult at level ',level
end if
@@ -625,25 +623,22 @@ contains
!
if (pre) then
if (me >=0) then
!!$ write(0,*) me,'Applying smoother pre ', level
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& vx2l,czero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
& vx2l,czero,vy2l, base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during PRE smoother_apply')
goto 9999
end if
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& vx2l,czero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
& vx2l,czero,vy2l, base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during PRE smoother_apply')
goto 9999
end if
endif
!
@@ -662,7 +657,7 @@ contains
& a_err='Error during residue')
goto 9999
end if
call p%precv(level+1)%map_rstr(cone,vty,&
call p%precv(level+1)%map%map_U2V(cone,vty,&
& czero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -673,7 +668,7 @@ contains
end if
else
! Shortcut: just transfer x2l.
call p%precv(level+1)%map_rstr(cone,vx2l,&
call p%precv(level+1)%map%map_U2V(cone,vx2l,&
& czero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -689,7 +684,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map_prol(cone,&
call p%precv(level+1)%map%map_V2U(cone,&
& p%precv(level+1)%wrk%vy2l,cone,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -701,15 +696,13 @@ contains
if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then
if (me >=0) then
call psb_geaxpby(cone,vx2l, czero,vty,&
& base_desc,info)
if (info == psb_success_) call psb_spmm(-cone,base_a,&
& vy2l,cone,vty,&
& base_desc,info,work=work,trans=trans)
end if
call psb_geaxpby(cone,vx2l, czero,vty,&
& base_desc,info)
if (info == psb_success_) call psb_spmm(-cone,base_a,&
& vy2l,cone,vty,&
& base_desc,info,work=work,trans=trans)
if (info == psb_success_) &
& call p%precv(level+1)%map_rstr(cone,vty,&
& call p%precv(level+1)%map%map_U2V(cone,vty,&
& czero,p%precv(level+1)%wrk%vx2l,info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
if (info /= psb_success_) then
@@ -720,7 +713,7 @@ contains
call inner_ml_aply(level+1,p,trans,work,info)
if (info == psb_success_) call p%precv(level+1)%map_prol(cone, &
if (info == psb_success_) call p%precv(level+1)%map%map_V2U(cone, &
& p%precv(level+1)%wrk%vy2l,cone,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -735,33 +728,31 @@ contains
if (post) then
if (me >=0) then
call psb_geaxpby(cone,vx2l,&
& czero,vty,&
& base_desc,info)
if (info == psb_success_) call psb_spmm(-cone,base_a,&
& vy2l, cone,vty,base_desc,info,&
& work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
!
! Apply the second smoother
!
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
& vty,cone,vy2l, base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& vty,cone,vy2l, base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
call psb_geaxpby(cone,vx2l,&
& czero,vty,&
& base_desc,info)
if (info == psb_success_) call psb_spmm(-cone,base_a,&
& vy2l, cone,vty,base_desc,info,&
& work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
!
! Apply the second smoother
!
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
& vty,cone,vy2l, base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& vty,cone,vy2l, base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
@@ -773,14 +764,11 @@ contains
endif
else if (level == nlev) then
!!$ write(0,*) me,'Applying smoother at top level ',psb_errstatus_fatal()
if (me >=0) then
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& vx2l,czero,vy2l,base_desc, trans,&
& sweeps,work,wv,info)
end if
!!$ write(0,*) me,' Done applying smoother at top level ',psb_errstatus_fatal()
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& vx2l,czero,vy2l,base_desc, trans,&
& sweeps,work,wv,info)
else
@@ -790,7 +778,7 @@ contains
goto 9999
end if
end associate
9998 continue
call psb_erractionrestore(err_act)
return
@@ -841,73 +829,72 @@ contains
end if
ctxt = p%precv(level)%base_desc%get_context()
call psb_info(ctxt, me, np)
if(debug_level > 1) then
write(debug_unit,*) me,name,' start at level ',level
end if
if ((level<1).or.(level>nlev)) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Invalid LEVEL>NLEV')
goto 9999
end if
!K cycle
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv(8:))
if (level == nlev) then
if (me >= 0) then
!
! Apply smoother
!
!
! Apply smoother
!
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& vx2l,czero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else if (level < nlev) then
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& vx2l,czero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
& vx2l,czero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
else if (level < nlev) then
if (me >= 0) then
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& vx2l,czero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
& vx2l,czero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during 2-PRE smoother_apply')
goto 9999
end if
!
! Compute the residual and call recursively
!
call psb_geaxpby(cone,vx2l,&
& czero,vty,&
& base_desc,info)
if (info == psb_success_) call psb_spmm(-cone,base_a,&
& vy2l,cone,vty,base_desc,info,work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during 2-PRE smoother_apply')
goto 9999
end if
!
! Compute the residual and call recursively
!
call psb_geaxpby(cone,vx2l,&
& czero,vty,&
& base_desc,info)
if (info == psb_success_) call psb_spmm(-cone,base_a,&
& vy2l,cone,vty,base_desc,info,work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
! Apply the restriction
call p%precv(level + 1)%map_rstr(cone,vty,&
call p%precv(level + 1)%map%map_U2V(cone,vty,&
& czero,p%precv(level + 1)%wrk%vx2l,&
&info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -943,7 +930,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map_prol(cone,&
call p%precv(level+1)%map%map_V2U(cone,&
& p%precv(level+1)%wrk%vy2l,cone,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -953,42 +940,40 @@ contains
& a_err='Error during prolongation')
goto 9999
end if
if (me >= 0) then
!
! Compute the residual
!
call psb_geaxpby(cone,vx2l,&
& czero,vty,base_desc,info)
call psb_spmm(-cone,base_a,vy2l,&
& cone,vty,base_desc,info,&
& work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
!
! Apply the smoother
!
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
& vty,cone,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& vty,cone,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during POST smoother_apply')
goto 9999
end if
!
! Compute the residual
!
call psb_geaxpby(cone,vx2l,&
& czero,vty,base_desc,info)
call psb_spmm(-cone,base_a,vy2l,&
& cone,vty,base_desc,info,&
& work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
!
! Apply the smoother
!
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
& vty,cone,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& vty,cone,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during POST smoother_apply')
goto 9999
end if
else
info = psb_err_internal_error_
@@ -1005,7 +990,8 @@ contains
return
end subroutine amg_c_inner_k_cycle
recursive subroutine amg_cinneritkcycle(p, level, trans, work, innersolv)
use psb_base_mod
use amg_prec_mod
@@ -1437,7 +1423,7 @@ contains
if (level < nlev) then
! Apply the restriction
call p%precv(level+1)%map_rstr(cone,mlwrk(level)%x2l,&
call p%precv(level+1)%map%map_U2V(cone,mlwrk(level)%x2l,&
& czero,mlwrk(level+1)%x2l,&
& info,work=work)
mlwrk(level+1)%y2l(:) = czero
@@ -1457,7 +1443,7 @@ contains
!
! Apply the prolongator and add correction.
!
call p%precv(level+1)%map_prol(cone,&
call p%precv(level+1)%map%map_V2U(cone,&
& mlwrk(level+1)%y2l,cone,mlwrk(level)%y2l,&
& info,work=work)
if (info /= psb_success_) then
@@ -1578,7 +1564,7 @@ contains
& a_err='Error during residue')
goto 9999
end if
call p%precv(level+1)%map_rstr(cone,mlwrk(level)%ty,&
call p%precv(level+1)%map%map_U2V(cone,mlwrk(level)%ty,&
& czero,mlwrk(level+1)%x2l,info,work=work)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@@ -1587,7 +1573,7 @@ contains
end if
else
! Shortcut: just transfer x2l.
call p%precv(level+1)%map_rstr(cone,mlwrk(level)%x2l,&
call p%precv(level+1)%map%map_U2V(cone,mlwrk(level)%x2l,&
& czero,mlwrk(level+1)%x2l,info,work=work)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@@ -1616,7 +1602,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map_prol(cone,mlwrk(level+1)%y2l,&
call p%precv(level+1)%map%map_V2U(cone,mlwrk(level+1)%y2l,&
& cone,mlwrk(level)%y2l,info,work=work)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
amgprec/impl/amg_d_hierarchy_bld.f90
+6 -31
View File
@@ -334,7 +334,7 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info)
if (i==2) then
sizeratio = desc_a%get_global_rows()/sizeratio
else
sizeratio = sum(prec%precv(i-1)%linmap%naggr)/sizeratio
sizeratio = sum(prec%precv(i-1)%map%naggr)/sizeratio
end if
prec%precv(i)%szratio = sizeratio
@@ -353,7 +353,7 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info)
end if
end if
if (all(nlaggr == prec%precv(i-1)%linmap%naggr)) then
if (all(nlaggr == prec%precv(i-1)%map%naggr)) then
newsz=i-1
if (me == 0) then
write(debug_unit,*) trim(name),&
@@ -388,8 +388,8 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info)
! We are going back and revisit a previous leve;
! recover the aggregation.
!
ilaggr = prec%precv(newsz)%linmap%iaggr
nlaggr = prec%precv(newsz)%linmap%naggr
ilaggr = prec%precv(newsz)%map%iaggr
nlaggr = prec%precv(newsz)%map%naggr
call prec%precv(newsz)%tprol%clone(op_prol,info)
end if
if (do_timings) call psb_tic(idx_matasb)
@@ -450,36 +450,11 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info)
do i=2, iszv
prec%precv(i)%base_a => prec%precv(i)%ac
prec%precv(i)%base_desc => prec%precv(i)%desc_ac
prec%precv(i)%linmap%p_desc_U => prec%precv(i-1)%base_desc
prec%precv(i)%linmap%p_desc_V => prec%precv(i)%base_desc
prec%precv(i)%map%p_desc_U => prec%precv(i-1)%base_desc
prec%precv(i)%map%p_desc_V => prec%precv(i)%base_desc
end do
end if
!write(0,*) 'Should we remap? '
if (amg_get_do_remap().and.(np>=4)) then
write(0,*) 'Going for remapping '
if (.true.) then
associate(lv=>prec%precv(iszv), rmp => prec%precv(iszv)%remap_data)
call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info)
call lv%ac%clone(rmp%ac_pre_remap,info)
if (np >= 8) then
call psb_remap(np/4,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
& rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
else
call psb_remap(np/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
& rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
end if
write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',&
& lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr)
lv%linmap%naggr(:) = rmp%naggr(:)
lv%linmap%p_desc_V => rmp%desc_ac_pre_remap
lv%base_a => lv%ac
lv%base_desc => lv%desc_ac
end associate
end if
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Internal hierarchy build' )
amgprec/impl/amg_d_hierarchy_rebld.f90
+3 -3
View File
@@ -127,9 +127,9 @@ subroutine amg_d_hierarchy_rebld(a,desc_a,prec,info)
do i=2, iszv
call prec%precv(i-1)%base_a%cp_to(acsr)
p_desc_a => prec%precv(i-1)%base_desc
call prec%precv(i)%linmap%mat_V2U%cp_to(coo_prol)
call prec%precv(i)%linmap%mat_U2V%cp_to(coo_restr)
call amg_rap(acsr,p_desc_a,prec%precv(i)%linmap%naggr,&
call prec%precv(i)%map%mat_V2U%cp_to(coo_prol)
call prec%precv(i)%map%mat_U2V%cp_to(coo_restr)
call amg_rap(acsr,p_desc_a,prec%precv(i)%map%naggr,&
& prec%precv(i)%parms,prec%precv(i)%ac,&
& coo_prol,prec%precv(i)%desc_ac,coo_restr,info)
amgprec/impl/amg_d_smoothers_bld.f90
-6
View File
@@ -117,10 +117,6 @@ subroutine amg_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
info = psb_success_
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (me <0) then
!!$ write(0,*) 'out of CTXT, should not do anything '
goto 9998
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
@@ -293,7 +289,6 @@ subroutine amg_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
!
! build the base preconditioner at level i
!
!!$ write(0,*) me,' Building at level ',i
call prec%precv(i)%bld(info,amold=amold,vmold=vmold,imold=imold,ilv=i)
if (info /= psb_success_) then
@@ -309,7 +304,6 @@ subroutine amg_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& write(debug_unit,*) me,' ',trim(name),&
& 'Exiting with',iszv,' levels'
9998 continue
call psb_erractionrestore(err_act)
return
amgprec/impl/amg_dcprecset.F90
+510 -332
View File
File diff suppressed because it is too large Load Diff
amgprec/impl/amg_dmlprec_aply.f90
+193 -207
View File
@@ -393,39 +393,38 @@ contains
if(debug_level > 1) then
write(debug_unit,*) me,' Start inner_ml_aply at level ',level, info
end if
if (me >= 0) then
select case(p%precv(level)%parms%ml_cycle)
case(amg_no_ml_)
!
! No preconditioning, should not really get here
!
call psb_errpush(psb_err_internal_error_,name,&
& a_err='amg_no_ml_ in mlprc_aply?')
goto 9999
case(amg_add_ml_)
call amg_d_inner_add(p, level, trans, work)
case(amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_)
call amg_d_inner_mult(p, level, trans, work)
case(amg_kcycle_ml_, amg_kcyclesym_ml_)
call amg_d_inner_k_cycle(p, level, trans, work)
case default
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='invalid ml_cycle',&
& i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
goto 9999
end select
if(debug_level > 1) then
write(debug_unit,*) me,' End inner_ml_aply at level ',level
end if
select case(p%precv(level)%parms%ml_cycle)
case(amg_no_ml_)
!
! No preconditioning, should not really get here
!
call psb_errpush(psb_err_internal_error_,name,&
& a_err='amg_no_ml_ in mlprc_aply?')
goto 9999
case(amg_add_ml_)
call amg_d_inner_add(p, level, trans, work)
case(amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_)
call amg_d_inner_mult(p, level, trans, work)
case(amg_kcycle_ml_, amg_kcyclesym_ml_)
call amg_d_inner_k_cycle(p, level, trans, work)
case default
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='invalid ml_cycle',&
& i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
goto 9999
end select
if(debug_level > 1) then
write(debug_unit,*) me,' End inner_ml_aply at level ',level
end if
call psb_erractionrestore(err_act)
@@ -493,30 +492,28 @@ contains
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv)
if (me >= 0) then
if (allocated(p%precv(level)%sm2a)) then
call psb_geaxpby(done,vx2l,dzero,vy2l,base_desc,info)
sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post)
do k=1, sweeps
call p%precv(level)%sm%apply(done,&
& vy2l,dzero,vty,&
& base_desc, trans,&
& ione,work,wv,info,init='Z')
call p%precv(level)%sm2a%apply(done,&
& vty,dzero,vy2l,&
& base_desc, trans,&
& ione,work,wv,info,init='Z')
end do
else
sweeps = p%precv(level)%parms%sweeps_pre
if (allocated(p%precv(level)%sm2a)) then
call psb_geaxpby(done,vx2l,dzero,vy2l,base_desc,info)
sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post)
do k=1, sweeps
call p%precv(level)%sm%apply(done,&
& vx2l,dzero,vy2l,&
& vy2l,dzero,vty,&
& base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
& ione,work,wv,info,init='Z')
call p%precv(level)%sm2a%apply(done,&
& vty,dzero,vy2l,&
& base_desc, trans,&
& ione,work,wv,info,init='Z')
end do
else
sweeps = p%precv(level)%parms%sweeps_pre
call p%precv(level)%sm%apply(done,&
& vx2l,dzero,vy2l,&
& base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@@ -526,7 +523,7 @@ contains
if (level < nlev) then
! Apply the restriction
call p%precv(level+1)%map_rstr(done,vx2l,&
call p%precv(level+1)%map%map_U2V(done,vx2l,&
& dzero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -546,7 +543,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map_prol(done,&
call p%precv(level+1)%map%map_V2U(done,&
& p%precv(level+1)%wrk%vy2l, done,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -605,6 +602,7 @@ contains
end if
ctxt = p%precv(level)%base_desc%get_context()
call psb_info(ctxt, me, np)
if(debug_level > 1) then
write(debug_unit,*) me,' inner_mult at level ',level
end if
@@ -625,25 +623,22 @@ contains
!
if (pre) then
if (me >=0) then
!!$ write(0,*) me,'Applying smoother pre ', level
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
& vx2l,dzero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
& vx2l,dzero,vy2l, base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during PRE smoother_apply')
goto 9999
end if
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
& vx2l,dzero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
& vx2l,dzero,vy2l, base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during PRE smoother_apply')
goto 9999
end if
endif
!
@@ -662,7 +657,7 @@ contains
& a_err='Error during residue')
goto 9999
end if
call p%precv(level+1)%map_rstr(done,vty,&
call p%precv(level+1)%map%map_U2V(done,vty,&
& dzero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -673,7 +668,7 @@ contains
end if
else
! Shortcut: just transfer x2l.
call p%precv(level+1)%map_rstr(done,vx2l,&
call p%precv(level+1)%map%map_U2V(done,vx2l,&
& dzero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -689,7 +684,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map_prol(done,&
call p%precv(level+1)%map%map_V2U(done,&
& p%precv(level+1)%wrk%vy2l,done,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -701,15 +696,13 @@ contains
if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then
if (me >=0) then
call psb_geaxpby(done,vx2l, dzero,vty,&
& base_desc,info)
if (info == psb_success_) call psb_spmm(-done,base_a,&
& vy2l,done,vty,&
& base_desc,info,work=work,trans=trans)
end if
call psb_geaxpby(done,vx2l, dzero,vty,&
& base_desc,info)
if (info == psb_success_) call psb_spmm(-done,base_a,&
& vy2l,done,vty,&
& base_desc,info,work=work,trans=trans)
if (info == psb_success_) &
& call p%precv(level+1)%map_rstr(done,vty,&
& call p%precv(level+1)%map%map_U2V(done,vty,&
& dzero,p%precv(level+1)%wrk%vx2l,info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
if (info /= psb_success_) then
@@ -720,7 +713,7 @@ contains
call inner_ml_aply(level+1,p,trans,work,info)
if (info == psb_success_) call p%precv(level+1)%map_prol(done, &
if (info == psb_success_) call p%precv(level+1)%map%map_V2U(done, &
& p%precv(level+1)%wrk%vy2l,done,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -735,33 +728,31 @@ contains
if (post) then
if (me >=0) then
call psb_geaxpby(done,vx2l,&
& dzero,vty,&
& base_desc,info)
if (info == psb_success_) call psb_spmm(-done,base_a,&
& vy2l, done,vty,base_desc,info,&
& work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
!
! Apply the second smoother
!
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
& vty,done,vy2l, base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
& vty,done,vy2l, base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
call psb_geaxpby(done,vx2l,&
& dzero,vty,&
& base_desc,info)
if (info == psb_success_) call psb_spmm(-done,base_a,&
& vy2l, done,vty,base_desc,info,&
& work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
!
! Apply the second smoother
!
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
& vty,done,vy2l, base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
& vty,done,vy2l, base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
@@ -773,14 +764,11 @@ contains
endif
else if (level == nlev) then
!!$ write(0,*) me,'Applying smoother at top level ',psb_errstatus_fatal()
if (me >=0) then
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
& vx2l,dzero,vy2l,base_desc, trans,&
& sweeps,work,wv,info)
end if
!!$ write(0,*) me,' Done applying smoother at top level ',psb_errstatus_fatal()
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
& vx2l,dzero,vy2l,base_desc, trans,&
& sweeps,work,wv,info)
else
@@ -790,7 +778,7 @@ contains
goto 9999
end if
end associate
9998 continue
call psb_erractionrestore(err_act)
return
@@ -841,73 +829,72 @@ contains
end if
ctxt = p%precv(level)%base_desc%get_context()
call psb_info(ctxt, me, np)
if(debug_level > 1) then
write(debug_unit,*) me,name,' start at level ',level
end if
if ((level<1).or.(level>nlev)) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Invalid LEVEL>NLEV')
goto 9999
end if
!K cycle
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv(8:))
if (level == nlev) then
if (me >= 0) then
!
! Apply smoother
!
!
! Apply smoother
!
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
& vx2l,dzero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else if (level < nlev) then
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
& vx2l,dzero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
& vx2l,dzero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
else if (level < nlev) then
if (me >= 0) then
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
& vx2l,dzero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
& vx2l,dzero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during 2-PRE smoother_apply')
goto 9999
end if
!
! Compute the residual and call recursively
!
call psb_geaxpby(done,vx2l,&
& dzero,vty,&
& base_desc,info)
if (info == psb_success_) call psb_spmm(-done,base_a,&
& vy2l,done,vty,base_desc,info,work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during 2-PRE smoother_apply')
goto 9999
end if
!
! Compute the residual and call recursively
!
call psb_geaxpby(done,vx2l,&
& dzero,vty,&
& base_desc,info)
if (info == psb_success_) call psb_spmm(-done,base_a,&
& vy2l,done,vty,base_desc,info,work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
! Apply the restriction
call p%precv(level + 1)%map_rstr(done,vty,&
call p%precv(level + 1)%map%map_U2V(done,vty,&
& dzero,p%precv(level + 1)%wrk%vx2l,&
&info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -943,7 +930,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map_prol(done,&
call p%precv(level+1)%map%map_V2U(done,&
& p%precv(level+1)%wrk%vy2l,done,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -953,42 +940,40 @@ contains
& a_err='Error during prolongation')
goto 9999
end if
if (me >= 0) then
!
! Compute the residual
!
call psb_geaxpby(done,vx2l,&
& dzero,vty,base_desc,info)
call psb_spmm(-done,base_a,vy2l,&
& done,vty,base_desc,info,&
& work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
!
! Apply the smoother
!
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
& vty,done,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
& vty,done,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during POST smoother_apply')
goto 9999
end if
!
! Compute the residual
!
call psb_geaxpby(done,vx2l,&
& dzero,vty,base_desc,info)
call psb_spmm(-done,base_a,vy2l,&
& done,vty,base_desc,info,&
& work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
!
! Apply the smoother
!
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
& vty,done,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
& vty,done,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during POST smoother_apply')
goto 9999
end if
else
info = psb_err_internal_error_
@@ -1005,7 +990,8 @@ contains
return
end subroutine amg_d_inner_k_cycle
recursive subroutine amg_dinneritkcycle(p, level, trans, work, innersolv)
use psb_base_mod
use amg_prec_mod
@@ -1437,7 +1423,7 @@ contains
if (level < nlev) then
! Apply the restriction
call p%precv(level+1)%map_rstr(done,mlwrk(level)%x2l,&
call p%precv(level+1)%map%map_U2V(done,mlwrk(level)%x2l,&
& dzero,mlwrk(level+1)%x2l,&
& info,work=work)
mlwrk(level+1)%y2l(:) = dzero
@@ -1457,7 +1443,7 @@ contains
!
! Apply the prolongator and add correction.
!
call p%precv(level+1)%map_prol(done,&
call p%precv(level+1)%map%map_V2U(done,&
& mlwrk(level+1)%y2l,done,mlwrk(level)%y2l,&
& info,work=work)
if (info /= psb_success_) then
@@ -1578,7 +1564,7 @@ contains
& a_err='Error during residue')
goto 9999
end if
call p%precv(level+1)%map_rstr(done,mlwrk(level)%ty,&
call p%precv(level+1)%map%map_U2V(done,mlwrk(level)%ty,&
& dzero,mlwrk(level+1)%x2l,info,work=work)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@@ -1587,7 +1573,7 @@ contains
end if
else
! Shortcut: just transfer x2l.
call p%precv(level+1)%map_rstr(done,mlwrk(level)%x2l,&
call p%precv(level+1)%map%map_U2V(done,mlwrk(level)%x2l,&
& dzero,mlwrk(level+1)%x2l,info,work=work)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@@ -1616,7 +1602,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map_prol(done,mlwrk(level+1)%y2l,&
call p%precv(level+1)%map%map_V2U(done,mlwrk(level+1)%y2l,&
& done,mlwrk(level)%y2l,info,work=work)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
amgprec/impl/amg_s_hierarchy_bld.f90
+6 -31
View File
@@ -334,7 +334,7 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info)
if (i==2) then
sizeratio = desc_a%get_global_rows()/sizeratio
else
sizeratio = sum(prec%precv(i-1)%linmap%naggr)/sizeratio
sizeratio = sum(prec%precv(i-1)%map%naggr)/sizeratio
end if
prec%precv(i)%szratio = sizeratio
@@ -353,7 +353,7 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info)
end if
end if
if (all(nlaggr == prec%precv(i-1)%linmap%naggr)) then
if (all(nlaggr == prec%precv(i-1)%map%naggr)) then
newsz=i-1
if (me == 0) then
write(debug_unit,*) trim(name),&
@@ -388,8 +388,8 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info)
! We are going back and revisit a previous leve;
! recover the aggregation.
!
ilaggr = prec%precv(newsz)%linmap%iaggr
nlaggr = prec%precv(newsz)%linmap%naggr
ilaggr = prec%precv(newsz)%map%iaggr
nlaggr = prec%precv(newsz)%map%naggr
call prec%precv(newsz)%tprol%clone(op_prol,info)
end if
if (do_timings) call psb_tic(idx_matasb)
@@ -450,36 +450,11 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info)
do i=2, iszv
prec%precv(i)%base_a => prec%precv(i)%ac
prec%precv(i)%base_desc => prec%precv(i)%desc_ac
prec%precv(i)%linmap%p_desc_U => prec%precv(i-1)%base_desc
prec%precv(i)%linmap%p_desc_V => prec%precv(i)%base_desc
prec%precv(i)%map%p_desc_U => prec%precv(i-1)%base_desc
prec%precv(i)%map%p_desc_V => prec%precv(i)%base_desc
end do
end if
!write(0,*) 'Should we remap? '
if (amg_get_do_remap().and.(np>=4)) then
write(0,*) 'Going for remapping '
if (.true.) then
associate(lv=>prec%precv(iszv), rmp => prec%precv(iszv)%remap_data)
call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info)
call lv%ac%clone(rmp%ac_pre_remap,info)
if (np >= 8) then
call psb_remap(np/4,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
& rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
else
call psb_remap(np/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
& rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
end if
write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',&
& lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr)
lv%linmap%naggr(:) = rmp%naggr(:)
lv%linmap%p_desc_V => rmp%desc_ac_pre_remap
lv%base_a => lv%ac
lv%base_desc => lv%desc_ac
end associate
end if
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Internal hierarchy build' )
amgprec/impl/amg_s_hierarchy_rebld.f90
+3 -3
View File
@@ -127,9 +127,9 @@ subroutine amg_s_hierarchy_rebld(a,desc_a,prec,info)
do i=2, iszv
call prec%precv(i-1)%base_a%cp_to(acsr)
p_desc_a => prec%precv(i-1)%base_desc
call prec%precv(i)%linmap%mat_V2U%cp_to(coo_prol)
call prec%precv(i)%linmap%mat_U2V%cp_to(coo_restr)
call amg_rap(acsr,p_desc_a,prec%precv(i)%linmap%naggr,&
call prec%precv(i)%map%mat_V2U%cp_to(coo_prol)
call prec%precv(i)%map%mat_U2V%cp_to(coo_restr)
call amg_rap(acsr,p_desc_a,prec%precv(i)%map%naggr,&
& prec%precv(i)%parms,prec%precv(i)%ac,&
& coo_prol,prec%precv(i)%desc_ac,coo_restr,info)
amgprec/impl/amg_s_smoothers_bld.f90
-6
View File
@@ -117,10 +117,6 @@ subroutine amg_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
info = psb_success_
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (me <0) then
!!$ write(0,*) 'out of CTXT, should not do anything '
goto 9998
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
@@ -293,7 +289,6 @@ subroutine amg_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
!
! build the base preconditioner at level i
!
!!$ write(0,*) me,' Building at level ',i
call prec%precv(i)%bld(info,amold=amold,vmold=vmold,imold=imold,ilv=i)
if (info /= psb_success_) then
@@ -309,7 +304,6 @@ subroutine amg_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& write(debug_unit,*) me,' ',trim(name),&
& 'Exiting with',iszv,' levels'
9998 continue
call psb_erractionrestore(err_act)
return
amgprec/impl/amg_scprecset.F90
+455 -304
View File
File diff suppressed because it is too large Load Diff
amgprec/impl/amg_smlprec_aply.f90
+193 -207
View File
@@ -393,39 +393,38 @@ contains
if(debug_level > 1) then
write(debug_unit,*) me,' Start inner_ml_aply at level ',level, info
end if
if (me >= 0) then
select case(p%precv(level)%parms%ml_cycle)
case(amg_no_ml_)
!
! No preconditioning, should not really get here
!
call psb_errpush(psb_err_internal_error_,name,&
& a_err='amg_no_ml_ in mlprc_aply?')
goto 9999
case(amg_add_ml_)
call amg_s_inner_add(p, level, trans, work)
case(amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_)
call amg_s_inner_mult(p, level, trans, work)
case(amg_kcycle_ml_, amg_kcyclesym_ml_)
call amg_s_inner_k_cycle(p, level, trans, work)
case default
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='invalid ml_cycle',&
& i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
goto 9999
end select
if(debug_level > 1) then
write(debug_unit,*) me,' End inner_ml_aply at level ',level
end if
select case(p%precv(level)%parms%ml_cycle)
case(amg_no_ml_)
!
! No preconditioning, should not really get here
!
call psb_errpush(psb_err_internal_error_,name,&
& a_err='amg_no_ml_ in mlprc_aply?')
goto 9999
case(amg_add_ml_)
call amg_s_inner_add(p, level, trans, work)
case(amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_)
call amg_s_inner_mult(p, level, trans, work)
case(amg_kcycle_ml_, amg_kcyclesym_ml_)
call amg_s_inner_k_cycle(p, level, trans, work)
case default
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='invalid ml_cycle',&
& i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
goto 9999
end select
if(debug_level > 1) then
write(debug_unit,*) me,' End inner_ml_aply at level ',level
end if
call psb_erractionrestore(err_act)
@@ -493,30 +492,28 @@ contains
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv)
if (me >= 0) then
if (allocated(p%precv(level)%sm2a)) then
call psb_geaxpby(sone,vx2l,szero,vy2l,base_desc,info)
sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post)
do k=1, sweeps
call p%precv(level)%sm%apply(sone,&
& vy2l,szero,vty,&
& base_desc, trans,&
& ione,work,wv,info,init='Z')
call p%precv(level)%sm2a%apply(sone,&
& vty,szero,vy2l,&
& base_desc, trans,&
& ione,work,wv,info,init='Z')
end do
else
sweeps = p%precv(level)%parms%sweeps_pre
if (allocated(p%precv(level)%sm2a)) then
call psb_geaxpby(sone,vx2l,szero,vy2l,base_desc,info)
sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post)
do k=1, sweeps
call p%precv(level)%sm%apply(sone,&
& vx2l,szero,vy2l,&
& vy2l,szero,vty,&
& base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
& ione,work,wv,info,init='Z')
call p%precv(level)%sm2a%apply(sone,&
& vty,szero,vy2l,&
& base_desc, trans,&
& ione,work,wv,info,init='Z')
end do
else
sweeps = p%precv(level)%parms%sweeps_pre
call p%precv(level)%sm%apply(sone,&
& vx2l,szero,vy2l,&
& base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@@ -526,7 +523,7 @@ contains
if (level < nlev) then
! Apply the restriction
call p%precv(level+1)%map_rstr(sone,vx2l,&
call p%precv(level+1)%map%map_U2V(sone,vx2l,&
& szero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -546,7 +543,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map_prol(sone,&
call p%precv(level+1)%map%map_V2U(sone,&
& p%precv(level+1)%wrk%vy2l, sone,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -605,6 +602,7 @@ contains
end if
ctxt = p%precv(level)%base_desc%get_context()
call psb_info(ctxt, me, np)
if(debug_level > 1) then
write(debug_unit,*) me,' inner_mult at level ',level
end if
@@ -625,25 +623,22 @@ contains
!
if (pre) then
if (me >=0) then
!!$ write(0,*) me,'Applying smoother pre ', level
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& vx2l,szero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
& vx2l,szero,vy2l, base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during PRE smoother_apply')
goto 9999
end if
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& vx2l,szero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
& vx2l,szero,vy2l, base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during PRE smoother_apply')
goto 9999
end if
endif
!
@@ -662,7 +657,7 @@ contains
& a_err='Error during residue')
goto 9999
end if
call p%precv(level+1)%map_rstr(sone,vty,&
call p%precv(level+1)%map%map_U2V(sone,vty,&
& szero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -673,7 +668,7 @@ contains
end if
else
! Shortcut: just transfer x2l.
call p%precv(level+1)%map_rstr(sone,vx2l,&
call p%precv(level+1)%map%map_U2V(sone,vx2l,&
& szero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -689,7 +684,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map_prol(sone,&
call p%precv(level+1)%map%map_V2U(sone,&
& p%precv(level+1)%wrk%vy2l,sone,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -701,15 +696,13 @@ contains
if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then
if (me >=0) then
call psb_geaxpby(sone,vx2l, szero,vty,&
& base_desc,info)
if (info == psb_success_) call psb_spmm(-sone,base_a,&
& vy2l,sone,vty,&
& base_desc,info,work=work,trans=trans)
end if
call psb_geaxpby(sone,vx2l, szero,vty,&
& base_desc,info)
if (info == psb_success_) call psb_spmm(-sone,base_a,&
& vy2l,sone,vty,&
& base_desc,info,work=work,trans=trans)
if (info == psb_success_) &
& call p%precv(level+1)%map_rstr(sone,vty,&
& call p%precv(level+1)%map%map_U2V(sone,vty,&
& szero,p%precv(level+1)%wrk%vx2l,info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
if (info /= psb_success_) then
@@ -720,7 +713,7 @@ contains
call inner_ml_aply(level+1,p,trans,work,info)
if (info == psb_success_) call p%precv(level+1)%map_prol(sone, &
if (info == psb_success_) call p%precv(level+1)%map%map_V2U(sone, &
& p%precv(level+1)%wrk%vy2l,sone,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -735,33 +728,31 @@ contains
if (post) then
if (me >=0) then
call psb_geaxpby(sone,vx2l,&
& szero,vty,&
& base_desc,info)
if (info == psb_success_) call psb_spmm(-sone,base_a,&
& vy2l, sone,vty,base_desc,info,&
& work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
!
! Apply the second smoother
!
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
& vty,sone,vy2l, base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& vty,sone,vy2l, base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
call psb_geaxpby(sone,vx2l,&
& szero,vty,&
& base_desc,info)
if (info == psb_success_) call psb_spmm(-sone,base_a,&
& vy2l, sone,vty,base_desc,info,&
& work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
!
! Apply the second smoother
!
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
& vty,sone,vy2l, base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& vty,sone,vy2l, base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
@@ -773,14 +764,11 @@ contains
endif
else if (level == nlev) then
!!$ write(0,*) me,'Applying smoother at top level ',psb_errstatus_fatal()
if (me >=0) then
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& vx2l,szero,vy2l,base_desc, trans,&
& sweeps,work,wv,info)
end if
!!$ write(0,*) me,' Done applying smoother at top level ',psb_errstatus_fatal()
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& vx2l,szero,vy2l,base_desc, trans,&
& sweeps,work,wv,info)
else
@@ -790,7 +778,7 @@ contains
goto 9999
end if
end associate
9998 continue
call psb_erractionrestore(err_act)
return
@@ -841,73 +829,72 @@ contains
end if
ctxt = p%precv(level)%base_desc%get_context()
call psb_info(ctxt, me, np)
if(debug_level > 1) then
write(debug_unit,*) me,name,' start at level ',level
end if
if ((level<1).or.(level>nlev)) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Invalid LEVEL>NLEV')
goto 9999
end if
!K cycle
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv(8:))
if (level == nlev) then
if (me >= 0) then
!
! Apply smoother
!
!
! Apply smoother
!
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& vx2l,szero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else if (level < nlev) then
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& vx2l,szero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
& vx2l,szero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
else if (level < nlev) then
if (me >= 0) then
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& vx2l,szero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
& vx2l,szero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during 2-PRE smoother_apply')
goto 9999
end if
!
! Compute the residual and call recursively
!
call psb_geaxpby(sone,vx2l,&
& szero,vty,&
& base_desc,info)
if (info == psb_success_) call psb_spmm(-sone,base_a,&
& vy2l,sone,vty,base_desc,info,work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during 2-PRE smoother_apply')
goto 9999
end if
!
! Compute the residual and call recursively
!
call psb_geaxpby(sone,vx2l,&
& szero,vty,&
& base_desc,info)
if (info == psb_success_) call psb_spmm(-sone,base_a,&
& vy2l,sone,vty,base_desc,info,work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
! Apply the restriction
call p%precv(level + 1)%map_rstr(sone,vty,&
call p%precv(level + 1)%map%map_U2V(sone,vty,&
& szero,p%precv(level + 1)%wrk%vx2l,&
&info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -943,7 +930,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map_prol(sone,&
call p%precv(level+1)%map%map_V2U(sone,&
& p%precv(level+1)%wrk%vy2l,sone,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -953,42 +940,40 @@ contains
& a_err='Error during prolongation')
goto 9999
end if
if (me >= 0) then
!
! Compute the residual
!
call psb_geaxpby(sone,vx2l,&
& szero,vty,base_desc,info)
call psb_spmm(-sone,base_a,vy2l,&
& sone,vty,base_desc,info,&
& work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
!
! Apply the smoother
!
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
& vty,sone,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& vty,sone,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during POST smoother_apply')
goto 9999
end if
!
! Compute the residual
!
call psb_geaxpby(sone,vx2l,&
& szero,vty,base_desc,info)
call psb_spmm(-sone,base_a,vy2l,&
& sone,vty,base_desc,info,&
& work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
!
! Apply the smoother
!
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
& vty,sone,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& vty,sone,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during POST smoother_apply')
goto 9999
end if
else
info = psb_err_internal_error_
@@ -1005,7 +990,8 @@ contains
return
end subroutine amg_s_inner_k_cycle
recursive subroutine amg_sinneritkcycle(p, level, trans, work, innersolv)
use psb_base_mod
use amg_prec_mod
@@ -1437,7 +1423,7 @@ contains
if (level < nlev) then
! Apply the restriction
call p%precv(level+1)%map_rstr(sone,mlwrk(level)%x2l,&
call p%precv(level+1)%map%map_U2V(sone,mlwrk(level)%x2l,&
& szero,mlwrk(level+1)%x2l,&
& info,work=work)
mlwrk(level+1)%y2l(:) = szero
@@ -1457,7 +1443,7 @@ contains
!
! Apply the prolongator and add correction.
!
call p%precv(level+1)%map_prol(sone,&
call p%precv(level+1)%map%map_V2U(sone,&
& mlwrk(level+1)%y2l,sone,mlwrk(level)%y2l,&
& info,work=work)
if (info /= psb_success_) then
@@ -1578,7 +1564,7 @@ contains
& a_err='Error during residue')
goto 9999
end if
call p%precv(level+1)%map_rstr(sone,mlwrk(level)%ty,&
call p%precv(level+1)%map%map_U2V(sone,mlwrk(level)%ty,&
& szero,mlwrk(level+1)%x2l,info,work=work)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@@ -1587,7 +1573,7 @@ contains
end if
else
! Shortcut: just transfer x2l.
call p%precv(level+1)%map_rstr(sone,mlwrk(level)%x2l,&
call p%precv(level+1)%map%map_U2V(sone,mlwrk(level)%x2l,&
& szero,mlwrk(level+1)%x2l,info,work=work)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@@ -1616,7 +1602,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map_prol(sone,mlwrk(level+1)%y2l,&
call p%precv(level+1)%map%map_V2U(sone,mlwrk(level+1)%y2l,&
& sone,mlwrk(level)%y2l,info,work=work)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
amgprec/impl/amg_z_hierarchy_bld.f90
+6 -31
View File
@@ -334,7 +334,7 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info)
if (i==2) then
sizeratio = desc_a%get_global_rows()/sizeratio
else
sizeratio = sum(prec%precv(i-1)%linmap%naggr)/sizeratio
sizeratio = sum(prec%precv(i-1)%map%naggr)/sizeratio
end if
prec%precv(i)%szratio = sizeratio
@@ -353,7 +353,7 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info)
end if
end if
if (all(nlaggr == prec%precv(i-1)%linmap%naggr)) then
if (all(nlaggr == prec%precv(i-1)%map%naggr)) then
newsz=i-1
if (me == 0) then
write(debug_unit,*) trim(name),&
@@ -388,8 +388,8 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info)
! We are going back and revisit a previous leve;
! recover the aggregation.
!
ilaggr = prec%precv(newsz)%linmap%iaggr
nlaggr = prec%precv(newsz)%linmap%naggr
ilaggr = prec%precv(newsz)%map%iaggr
nlaggr = prec%precv(newsz)%map%naggr
call prec%precv(newsz)%tprol%clone(op_prol,info)
end if
if (do_timings) call psb_tic(idx_matasb)
@@ -450,36 +450,11 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info)
do i=2, iszv
prec%precv(i)%base_a => prec%precv(i)%ac
prec%precv(i)%base_desc => prec%precv(i)%desc_ac
prec%precv(i)%linmap%p_desc_U => prec%precv(i-1)%base_desc
prec%precv(i)%linmap%p_desc_V => prec%precv(i)%base_desc
prec%precv(i)%map%p_desc_U => prec%precv(i-1)%base_desc
prec%precv(i)%map%p_desc_V => prec%precv(i)%base_desc
end do
end if
!write(0,*) 'Should we remap? '
if (amg_get_do_remap().and.(np>=4)) then
write(0,*) 'Going for remapping '
if (.true.) then
associate(lv=>prec%precv(iszv), rmp => prec%precv(iszv)%remap_data)
call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info)
call lv%ac%clone(rmp%ac_pre_remap,info)
if (np >= 8) then
call psb_remap(np/4,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
& rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
else
call psb_remap(np/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
& rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
end if
write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',&
& lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr)
lv%linmap%naggr(:) = rmp%naggr(:)
lv%linmap%p_desc_V => rmp%desc_ac_pre_remap
lv%base_a => lv%ac
lv%base_desc => lv%desc_ac
end associate
end if
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Internal hierarchy build' )
amgprec/impl/amg_z_hierarchy_rebld.f90
+3 -3
View File
@@ -127,9 +127,9 @@ subroutine amg_z_hierarchy_rebld(a,desc_a,prec,info)
do i=2, iszv
call prec%precv(i-1)%base_a%cp_to(acsr)
p_desc_a => prec%precv(i-1)%base_desc
call prec%precv(i)%linmap%mat_V2U%cp_to(coo_prol)
call prec%precv(i)%linmap%mat_U2V%cp_to(coo_restr)
call amg_rap(acsr,p_desc_a,prec%precv(i)%linmap%naggr,&
call prec%precv(i)%map%mat_V2U%cp_to(coo_prol)
call prec%precv(i)%map%mat_U2V%cp_to(coo_restr)
call amg_rap(acsr,p_desc_a,prec%precv(i)%map%naggr,&
& prec%precv(i)%parms,prec%precv(i)%ac,&
& coo_prol,prec%precv(i)%desc_ac,coo_restr,info)
amgprec/impl/amg_z_smoothers_bld.f90
-6
View File
@@ -117,10 +117,6 @@ subroutine amg_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
info = psb_success_
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (me <0) then
!!$ write(0,*) 'out of CTXT, should not do anything '
goto 9998
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
@@ -293,7 +289,6 @@ subroutine amg_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
!
! build the base preconditioner at level i
!
!!$ write(0,*) me,' Building at level ',i
call prec%precv(i)%bld(info,amold=amold,vmold=vmold,imold=imold,ilv=i)
if (info /= psb_success_) then
@@ -309,7 +304,6 @@ subroutine amg_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& write(debug_unit,*) me,' ',trim(name),&
& 'Exiting with',iszv,' levels'
9998 continue
call psb_erractionrestore(err_act)
return
amgprec/impl/amg_zcprecset.F90
+510 -332
View File
File diff suppressed because it is too large Load Diff
amgprec/impl/amg_zmlprec_aply.f90
+193 -207
View File
@@ -393,39 +393,38 @@ contains
if(debug_level > 1) then
write(debug_unit,*) me,' Start inner_ml_aply at level ',level, info
end if
if (me >= 0) then
select case(p%precv(level)%parms%ml_cycle)
case(amg_no_ml_)
!
! No preconditioning, should not really get here
!
call psb_errpush(psb_err_internal_error_,name,&
& a_err='amg_no_ml_ in mlprc_aply?')
goto 9999
case(amg_add_ml_)
call amg_z_inner_add(p, level, trans, work)
case(amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_)
call amg_z_inner_mult(p, level, trans, work)
case(amg_kcycle_ml_, amg_kcyclesym_ml_)
call amg_z_inner_k_cycle(p, level, trans, work)
case default
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='invalid ml_cycle',&
& i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
goto 9999
end select
if(debug_level > 1) then
write(debug_unit,*) me,' End inner_ml_aply at level ',level
end if
select case(p%precv(level)%parms%ml_cycle)
case(amg_no_ml_)
!
! No preconditioning, should not really get here
!
call psb_errpush(psb_err_internal_error_,name,&
& a_err='amg_no_ml_ in mlprc_aply?')
goto 9999
case(amg_add_ml_)
call amg_z_inner_add(p, level, trans, work)
case(amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_)
call amg_z_inner_mult(p, level, trans, work)
case(amg_kcycle_ml_, amg_kcyclesym_ml_)
call amg_z_inner_k_cycle(p, level, trans, work)
case default
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='invalid ml_cycle',&
& i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
goto 9999
end select
if(debug_level > 1) then
write(debug_unit,*) me,' End inner_ml_aply at level ',level
end if
call psb_erractionrestore(err_act)
@@ -493,30 +492,28 @@ contains
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv)
if (me >= 0) then
if (allocated(p%precv(level)%sm2a)) then
call psb_geaxpby(zone,vx2l,zzero,vy2l,base_desc,info)
sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post)
do k=1, sweeps
call p%precv(level)%sm%apply(zone,&
& vy2l,zzero,vty,&
& base_desc, trans,&
& ione,work,wv,info,init='Z')
call p%precv(level)%sm2a%apply(zone,&
& vty,zzero,vy2l,&
& base_desc, trans,&
& ione,work,wv,info,init='Z')
end do
else
sweeps = p%precv(level)%parms%sweeps_pre
if (allocated(p%precv(level)%sm2a)) then
call psb_geaxpby(zone,vx2l,zzero,vy2l,base_desc,info)
sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post)
do k=1, sweeps
call p%precv(level)%sm%apply(zone,&
& vx2l,zzero,vy2l,&
& vy2l,zzero,vty,&
& base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
& ione,work,wv,info,init='Z')
call p%precv(level)%sm2a%apply(zone,&
& vty,zzero,vy2l,&
& base_desc, trans,&
& ione,work,wv,info,init='Z')
end do
else
sweeps = p%precv(level)%parms%sweeps_pre
call p%precv(level)%sm%apply(zone,&
& vx2l,zzero,vy2l,&
& base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@@ -526,7 +523,7 @@ contains
if (level < nlev) then
! Apply the restriction
call p%precv(level+1)%map_rstr(zone,vx2l,&
call p%precv(level+1)%map%map_U2V(zone,vx2l,&
& zzero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -546,7 +543,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map_prol(zone,&
call p%precv(level+1)%map%map_V2U(zone,&
& p%precv(level+1)%wrk%vy2l, zone,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -605,6 +602,7 @@ contains
end if
ctxt = p%precv(level)%base_desc%get_context()
call psb_info(ctxt, me, np)
if(debug_level > 1) then
write(debug_unit,*) me,' inner_mult at level ',level
end if
@@ -625,25 +623,22 @@ contains
!
if (pre) then
if (me >=0) then
!!$ write(0,*) me,'Applying smoother pre ', level
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
& vx2l,zzero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
& vx2l,zzero,vy2l, base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during PRE smoother_apply')
goto 9999
end if
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
& vx2l,zzero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
& vx2l,zzero,vy2l, base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during PRE smoother_apply')
goto 9999
end if
endif
!
@@ -662,7 +657,7 @@ contains
& a_err='Error during residue')
goto 9999
end if
call p%precv(level+1)%map_rstr(zone,vty,&
call p%precv(level+1)%map%map_U2V(zone,vty,&
& zzero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -673,7 +668,7 @@ contains
end if
else
! Shortcut: just transfer x2l.
call p%precv(level+1)%map_rstr(zone,vx2l,&
call p%precv(level+1)%map%map_U2V(zone,vx2l,&
& zzero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -689,7 +684,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map_prol(zone,&
call p%precv(level+1)%map%map_V2U(zone,&
& p%precv(level+1)%wrk%vy2l,zone,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -701,15 +696,13 @@ contains
if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then
if (me >=0) then
call psb_geaxpby(zone,vx2l, zzero,vty,&
& base_desc,info)
if (info == psb_success_) call psb_spmm(-zone,base_a,&
& vy2l,zone,vty,&
& base_desc,info,work=work,trans=trans)
end if
call psb_geaxpby(zone,vx2l, zzero,vty,&
& base_desc,info)
if (info == psb_success_) call psb_spmm(-zone,base_a,&
& vy2l,zone,vty,&
& base_desc,info,work=work,trans=trans)
if (info == psb_success_) &
& call p%precv(level+1)%map_rstr(zone,vty,&
& call p%precv(level+1)%map%map_U2V(zone,vty,&
& zzero,p%precv(level+1)%wrk%vx2l,info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
if (info /= psb_success_) then
@@ -720,7 +713,7 @@ contains
call inner_ml_aply(level+1,p,trans,work,info)
if (info == psb_success_) call p%precv(level+1)%map_prol(zone, &
if (info == psb_success_) call p%precv(level+1)%map%map_V2U(zone, &
& p%precv(level+1)%wrk%vy2l,zone,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -735,33 +728,31 @@ contains
if (post) then
if (me >=0) then
call psb_geaxpby(zone,vx2l,&
& zzero,vty,&
& base_desc,info)
if (info == psb_success_) call psb_spmm(-zone,base_a,&
& vy2l, zone,vty,base_desc,info,&
& work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
!
! Apply the second smoother
!
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
& vty,zone,vy2l, base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
& vty,zone,vy2l, base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
call psb_geaxpby(zone,vx2l,&
& zzero,vty,&
& base_desc,info)
if (info == psb_success_) call psb_spmm(-zone,base_a,&
& vy2l, zone,vty,base_desc,info,&
& work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
!
! Apply the second smoother
!
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
& vty,zone,vy2l, base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
& vty,zone,vy2l, base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
@@ -773,14 +764,11 @@ contains
endif
else if (level == nlev) then
!!$ write(0,*) me,'Applying smoother at top level ',psb_errstatus_fatal()
if (me >=0) then
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
& vx2l,zzero,vy2l,base_desc, trans,&
& sweeps,work,wv,info)
end if
!!$ write(0,*) me,' Done applying smoother at top level ',psb_errstatus_fatal()
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
& vx2l,zzero,vy2l,base_desc, trans,&
& sweeps,work,wv,info)
else
@@ -790,7 +778,7 @@ contains
goto 9999
end if
end associate
9998 continue
call psb_erractionrestore(err_act)
return
@@ -841,73 +829,72 @@ contains
end if
ctxt = p%precv(level)%base_desc%get_context()
call psb_info(ctxt, me, np)
if(debug_level > 1) then
write(debug_unit,*) me,name,' start at level ',level
end if
if ((level<1).or.(level>nlev)) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Invalid LEVEL>NLEV')
goto 9999
end if
!K cycle
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv(8:))
if (level == nlev) then
if (me >= 0) then
!
! Apply smoother
!
!
! Apply smoother
!
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
& vx2l,zzero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else if (level < nlev) then
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
& vx2l,zzero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
& vx2l,zzero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
else if (level < nlev) then
if (me >= 0) then
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
& vx2l,zzero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
& vx2l,zzero,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during 2-PRE smoother_apply')
goto 9999
end if
!
! Compute the residual and call recursively
!
call psb_geaxpby(zone,vx2l,&
& zzero,vty,&
& base_desc,info)
if (info == psb_success_) call psb_spmm(-zone,base_a,&
& vy2l,zone,vty,base_desc,info,work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during 2-PRE smoother_apply')
goto 9999
end if
!
! Compute the residual and call recursively
!
call psb_geaxpby(zone,vx2l,&
& zzero,vty,&
& base_desc,info)
if (info == psb_success_) call psb_spmm(-zone,base_a,&
& vy2l,zone,vty,base_desc,info,work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
! Apply the restriction
call p%precv(level + 1)%map_rstr(zone,vty,&
call p%precv(level + 1)%map%map_U2V(zone,vty,&
& zzero,p%precv(level + 1)%wrk%vx2l,&
&info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -943,7 +930,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map_prol(zone,&
call p%precv(level+1)%map%map_V2U(zone,&
& p%precv(level+1)%wrk%vy2l,zone,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -953,42 +940,40 @@ contains
& a_err='Error during prolongation')
goto 9999
end if
if (me >= 0) then
!
! Compute the residual
!
call psb_geaxpby(zone,vx2l,&
& zzero,vty,base_desc,info)
call psb_spmm(-zone,base_a,vy2l,&
& zone,vty,base_desc,info,&
& work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
!
! Apply the smoother
!
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
& vty,zone,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
& vty,zone,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during POST smoother_apply')
goto 9999
end if
!
! Compute the residual
!
call psb_geaxpby(zone,vx2l,&
& zzero,vty,base_desc,info)
call psb_spmm(-zone,base_a,vy2l,&
& zone,vty,base_desc,info,&
& work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
!
! Apply the smoother
!
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
& vty,zone,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
& vty,zone,vy2l,base_desc, trans,&
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during POST smoother_apply')
goto 9999
end if
else
info = psb_err_internal_error_
@@ -1005,7 +990,8 @@ contains
return
end subroutine amg_z_inner_k_cycle
recursive subroutine amg_zinneritkcycle(p, level, trans, work, innersolv)
use psb_base_mod
use amg_prec_mod
@@ -1437,7 +1423,7 @@ contains
if (level < nlev) then
! Apply the restriction
call p%precv(level+1)%map_rstr(zone,mlwrk(level)%x2l,&
call p%precv(level+1)%map%map_U2V(zone,mlwrk(level)%x2l,&
& zzero,mlwrk(level+1)%x2l,&
& info,work=work)
mlwrk(level+1)%y2l(:) = zzero
@@ -1457,7 +1443,7 @@ contains
!
! Apply the prolongator and add correction.
!
call p%precv(level+1)%map_prol(zone,&
call p%precv(level+1)%map%map_V2U(zone,&
& mlwrk(level+1)%y2l,zone,mlwrk(level)%y2l,&
& info,work=work)
if (info /= psb_success_) then
@@ -1578,7 +1564,7 @@ contains
& a_err='Error during residue')
goto 9999
end if
call p%precv(level+1)%map_rstr(zone,mlwrk(level)%ty,&
call p%precv(level+1)%map%map_U2V(zone,mlwrk(level)%ty,&
& zzero,mlwrk(level+1)%x2l,info,work=work)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@@ -1587,7 +1573,7 @@ contains
end if
else
! Shortcut: just transfer x2l.
call p%precv(level+1)%map_rstr(zone,mlwrk(level)%x2l,&
call p%precv(level+1)%map%map_U2V(zone,mlwrk(level)%x2l,&
& zzero,mlwrk(level+1)%x2l,info,work=work)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@@ -1616,7 +1602,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map_prol(zone,mlwrk(level+1)%y2l,&
call p%precv(level+1)%map%map_V2U(zone,mlwrk(level+1)%y2l,&
& zone,mlwrk(level)%y2l,info,work=work)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
amgprec/impl/level/Makefile
+1 -9
View File
@@ -21,8 +21,6 @@ amg_c_base_onelev_mat_asb.o \
amg_c_base_onelev_setag.o \
amg_c_base_onelev_setsm.o \
amg_c_base_onelev_setsv.o \
amg_c_base_onelev_map_rstr.o \
amg_c_base_onelev_map_prol.o \
amg_d_base_onelev_build.o \
amg_d_base_onelev_check.o \
amg_d_base_onelev_cnv.o \
@@ -36,8 +34,6 @@ amg_d_base_onelev_mat_asb.o \
amg_d_base_onelev_setag.o \
amg_d_base_onelev_setsm.o \
amg_d_base_onelev_setsv.o \
amg_d_base_onelev_map_rstr.o \
amg_d_base_onelev_map_prol.o \
amg_s_base_onelev_build.o \
amg_s_base_onelev_check.o \
amg_s_base_onelev_cnv.o \
@@ -51,8 +47,6 @@ amg_s_base_onelev_mat_asb.o \
amg_s_base_onelev_setag.o \
amg_s_base_onelev_setsm.o \
amg_s_base_onelev_setsv.o \
amg_s_base_onelev_map_rstr.o \
amg_s_base_onelev_map_prol.o \
amg_z_base_onelev_build.o \
amg_z_base_onelev_check.o \
amg_z_base_onelev_cnv.o \
@@ -65,9 +59,7 @@ amg_z_base_onelev_free.o \
amg_z_base_onelev_mat_asb.o \
amg_z_base_onelev_setag.o \
amg_z_base_onelev_setsm.o \
amg_z_base_onelev_setsv.o \
amg_z_base_onelev_map_rstr.o \
amg_z_base_onelev_map_prol.o
amg_z_base_onelev_setsv.o
LIBNAME=libamg_prec.a
amgprec/impl/level/amg_c_base_onelev_build.f90
+64 -73
View File
@@ -71,81 +71,72 @@ subroutine amg_c_base_onelev_build(lv,info,amold,vmold,imold,ilv)
ctxt = lv%base_desc%get_ctxt()
call psb_info(ctxt,me,np)
!
! At top level(s) I may be using
! a context with less processes
!
if (me < 0) then
!!$ write(0,*) 'onelevbld: I am excluded from this one '
else
!!$ write(0,*) me,' Going to build smoothers at this level '
if (.not.allocated(lv%sm)) then
!! Error: should have called amg_dprecinit
info=3111
call psb_errpush(info,name)
goto 9999
if (.not.allocated(lv%sm)) then
!! Error: should have called amg_dprecinit
info=3111
call psb_errpush(info,name)
goto 9999
end if
if (.not.allocated(lv%sm%sv)) then
!! Error: should have called amg_dprecinit
info=3111
call psb_errpush(info,name)
goto 9999
end if
lv%ac_nz_loc = lv%ac%get_nzeros()
lv%ac_nz_tot = lv%ac_nz_loc
select case(lv%parms%coarse_mat)
case(amg_distr_mat_)
call psb_sum(ctxt,lv%ac_nz_tot)
case(amg_repl_mat_)
! Do nothing
case default
! Should never get here
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Wrong lv%parms')
goto 9999
end select
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
call amg_check_def(lv%parms%sweeps_pre,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call amg_check_def(lv%parms%sweeps_post,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call lv%sm%build(lv%base_a,lv%base_desc,info)
if (info == 0) then
if (allocated(lv%sm2a)) then
call lv%sm2a%build(lv%base_a,lv%base_desc,info)
lv%sm2 => lv%sm2a
else
lv%sm2 => lv%sm
end if
if (.not.allocated(lv%sm%sv)) then
!! Error: should have called amg_dprecinit
info=3111
call psb_errpush(info,name)
goto 9999
end if
lv%ac_nz_loc = lv%ac%get_nzeros()
lv%ac_nz_tot = lv%ac_nz_loc
select case(lv%parms%coarse_mat)
case(amg_distr_mat_)
call psb_sum(ctxt,lv%ac_nz_tot)
case(amg_repl_mat_)
! Do nothing
case default
! Should never get here
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Wrong lv%parms')
goto 9999
end select
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
call amg_check_def(lv%parms%sweeps_pre,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call amg_check_def(lv%parms%sweeps_post,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call lv%sm%build(lv%base_a,lv%base_desc,info)
if (info == 0) then
if (allocated(lv%sm2a)) then
call lv%sm2a%build(lv%base_a,lv%base_desc,info)
lv%sm2 => lv%sm2a
else
lv%sm2 => lv%sm
end if
end if
if (info /=0 ) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Smoother bld error')
goto 9999
end if
if (lv%sm%sv%is_global()) then
if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then
lv%parms%sweeps_pre = 1
lv%parms%sweeps_post = 1
if (me == 0) then
write(debug_unit,*)
if (present(ilv)) then
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
& '" at level ',ilv
write(debug_unit,*) ' is configured as a global solver '
else
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
& '" is configured as a global solver '
end if
write(debug_unit,*) ' Pre and post sweeps at this level reset to 1'
end if
if (info /=0 ) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Smoother bld error')
goto 9999
end if
if (lv%sm%sv%is_global()) then
if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then
lv%parms%sweeps_pre = 1
lv%parms%sweeps_post = 1
if (me == 0) then
write(debug_unit,*)
if (present(ilv)) then
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
& '" at level ',ilv
write(debug_unit,*) ' is configured as a global solver '
else
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
& '" is configured as a global solver '
end if
write(debug_unit,*) ' Pre and post sweeps at this level reset to 1'
end if
end if
end if
amgprec/impl/level/amg_c_base_onelev_cnv.f90
+1 -1
View File
@@ -62,6 +62,6 @@ subroutine amg_c_base_onelev_cnv(lv,info,amold,vmold,imold)
& call lv%ac%cscnv(info,mold=amold)
if (info == psb_success_ .and. lv%desc_ac%is_ok() &
& .and. present(imold)) call lv%desc_ac%cnv(imold)
if (info == psb_success_) call lv%linmap%cnv(info,mold=amold,imold=imold)
if (info == psb_success_) call lv%map%cnv(info,mold=amold,imold=imold)
end if
end subroutine amg_c_base_onelev_cnv
amgprec/impl/level/amg_c_base_onelev_csetc.F90
+44 -56
View File
@@ -1,15 +1,15 @@
!
!
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
!
! (C) Copyright 2020
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
!
! (C) Copyright 2020
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
@@ -21,7 +21,7 @@
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
@@ -33,10 +33,10 @@
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
!
!
subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
use psb_base_mod
use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_csetc
use amg_c_base_aggregator_mod
@@ -49,9 +49,6 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
use amg_c_ilu_solver
use amg_c_id_solver
use amg_c_gs_solver
use amg_c_ainv_solver
use amg_c_invk_solver
use amg_c_invt_solver
#if defined(HAVE_SLU_)
use amg_c_slu_solver
#endif
@@ -62,16 +59,16 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
Implicit None
! Arguments
class(amg_c_onelev_type), intent(inout) :: lv
character(len=*), intent(in) :: what
class(amg_c_onelev_type), intent(inout) :: lv
character(len=*), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
integer(psb_ipk_), intent(in), optional :: idx
! Local
! Local
integer(psb_ipk_) :: ipos_, err_act
character(len=20) :: name='c_base_onelev_csetc'
integer(psb_ipk_) :: ival
integer(psb_ipk_) :: ival
type(amg_c_base_smoother_type) :: amg_c_base_smoother_mold
type(amg_c_jac_smoother_type) :: amg_c_jac_smoother_mold
type(amg_c_l1_jac_smoother_type) :: amg_c_l1_jac_smoother_mold
@@ -82,16 +79,13 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
type(amg_c_id_solver_type) :: amg_c_id_solver_mold
type(amg_c_gs_solver_type) :: amg_c_gs_solver_mold
type(amg_c_bwgs_solver_type) :: amg_c_bwgs_solver_mold
type(amg_c_ainv_solver_type) :: amg_c_ainv_solver_mold
type(amg_c_invk_solver_type) :: amg_c_invk_solver_mold
type(amg_c_invt_solver_type) :: amg_c_invt_solver_mold
#if defined(HAVE_SLU_)
type(amg_c_slu_solver_type) :: amg_c_slu_solver_mold
#endif
#if defined(HAVE_MUMPS_)
type(amg_c_mumps_solver_type) :: amg_c_mumps_solver_mold
#endif
call psb_erractionsave(err_act)
@@ -112,14 +106,14 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
else
ipos_ = amg_smooth_both_
end if
select case (psb_toupper(trim(what)))
case ('SMOOTHER_TYPE')
select case (psb_toupper(trim(val)))
case ('NOPREC','NONE')
call lv%set(amg_c_base_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(amg_c_id_solver_mold,info,pos=pos)
case ('JAC','JACOBI')
call lv%set(amg_c_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(amg_c_diag_solver_mold,info,pos=pos)
@@ -127,11 +121,11 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
case ('L1-JACOBI')
call lv%set(amg_c_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(amg_c_l1_diag_solver_mold,info,pos=pos)
case ('BJAC')
call lv%set(amg_c_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
case ('L1-BJAC')
call lv%set(amg_c_l1_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
@@ -160,73 +154,67 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
case ('L1-BWGS')
call lv%set(amg_c_l1_jac_smoother_mold,info,pos='pre')
if (info == 0) call lv%set(amg_c_bwgs_solver_mold,info,pos='pre')
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
case ('L1-FBGS')
call lv%set(amg_c_l1_jac_smoother_mold,info,pos='pre')
if (info == 0) call lv%set(amg_c_gs_solver_mold,info,pos='pre')
call lv%set(amg_c_l1_jac_smoother_mold,info,pos='post')
if (info == 0) call lv%set(amg_c_bwgs_solver_mold,info,pos='post')
case default
!
! Do nothing and hope for the best :)
! Do nothing and hope for the best :)
!
end select
if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then
if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then
if (allocated(lv%sm)) call lv%sm%default()
end if
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then
if (allocated(lv%sm2a)) call lv%sm2a%default()
end if
case('SUB_SOLVE')
select case (psb_toupper(trim(val)))
case ('NONE','NOPREC','FACT_NONE')
call lv%set(amg_c_id_solver_mold,info,pos=pos)
case ('DIAG')
call lv%set(amg_c_diag_solver_mold,info,pos=pos)
case ('L1-DIAG')
call lv%set(amg_c_l1_diag_solver_mold,info,pos=pos)
case ('GS','FGS','FWGS')
call lv%set(amg_c_gs_solver_mold,info,pos=pos)
case ('BGS','BWGS')
call lv%set(amg_c_bwgs_solver_mold,info,pos=pos)
case ('AINV')
call lv%set(amg_c_ainv_solver_mold,info,pos=pos)
case ('INVK')
call lv%set(amg_c_invk_solver_mold,info,pos=pos)
case ('INVT')
call lv%set(amg_c_invt_solver_mold,info,pos=pos)
case ('ILU','ILUT','MILU')
call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
if (info == 0) then
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
call lv%sm%sv%set('SUB_SOLVE',val,info)
end if
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
end if
end if
#ifdef HAVE_SLU_
case ('SLU')
case ('SLU')
call lv%set(amg_c_slu_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_MUMPS_
case ('MUMPS')
case ('MUMPS')
call lv%set(amg_c_mumps_solver_mold,info,pos=pos)
#endif
case default
!
! Do nothing and hope for the best :)
! Do nothing and hope for the best :)
!
end select
case ('ML_CYCLE')
lv%parms%ml_cycle = amg_stringval(val)
@@ -241,7 +229,7 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
return
end if
end if
select case(ival)
case(amg_dec_aggr_)
allocate(amg_c_dec_aggregator_type :: lv%aggr, stat=info)
@@ -251,7 +239,7 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
info = psb_err_internal_error_
end select
if (info == psb_success_) call lv%aggr%default()
case ('AGGR_ORD')
lv%parms%aggr_ord = amg_stringval(val)
@@ -278,13 +266,13 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
lv%parms%coarse_solve = amg_stringval(val)
case default
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
if (allocated(lv%sm)) then
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info,idx=idx)
end if
end if
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
if (allocated(lv%sm2a)) then
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info,idx=idx)
end if
end if
amgprec/impl/level/amg_c_base_onelev_descr.f90
+3 -3
View File
@@ -89,11 +89,11 @@ subroutine amg_c_base_onelev_descr(lv,il,nl,ilmin,info,iout)
call lv%parms%descr(iout_,info,coarse=coarse)
if (nl > 1) then
if (allocated(lv%linmap%naggr)) then
if (allocated(lv%map%naggr)) then
write(iout_,*) ' Coarse Matrix: Global size: ', &
& sum((1_psb_lpk_*lv%linmap%naggr(:))),' Nonzeros: ',lv%ac_nz_tot
& sum((1_psb_lpk_*lv%map%naggr(:))),' Nonzeros: ',lv%ac_nz_tot
write(iout_,*) ' Local matrix sizes: ', &
& lv%linmap%naggr(:)
& lv%map%naggr(:)
write(iout_,*) ' Aggregation ratio: ', &
& lv%szratio
end if
amgprec/impl/level/amg_c_base_onelev_dump.f90
+7 -7
View File
@@ -108,17 +108,17 @@ subroutine amg_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
call lv%ac%print(fname,head=head,iv=ivr)
end if
if (rp_) then
ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.)
ivc = lv%linmap%p_desc_V%get_global_indices(owned=.false.)
ivr = lv%map%p_desc_U%get_global_indices(owned=.false.)
ivc = lv%map%p_desc_V%get_global_indices(owned=.false.)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
call lv%linmap%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr)
call lv%map%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
call lv%linmap%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc)
call lv%map%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc)
end if
if (tprol_) then
! Tentative prolongator is stored with column indices already
! in global numbering, so only IVR is needed.
ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.)
ivr = lv%map%p_desc_U%get_global_indices(owned=.false.)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
!
! This is not implemented yet.
@@ -133,9 +133,9 @@ subroutine amg_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
end if
if (rp_) then
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
call lv%linmap%mat_U2V%print(fname,head=head)
call lv%map%mat_U2V%print(fname,head=head)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
call lv%linmap%mat_V2U%print(fname,head=head)
call lv%map%mat_V2U%print(fname,head=head)
end if
if (tprol_) then
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
amgprec/impl/level/amg_c_base_onelev_free.f90
+1 -1
View File
@@ -63,7 +63,7 @@ subroutine amg_c_base_onelev_free(lv,info)
call lv%ac%free()
if (lv%desc_ac%is_ok()) &
& call lv%desc_ac%free(info)
call lv%linmap%free(info)
call lv%map%free(info)
! This is a pointer to something else, must not free it here.
nullify(lv%base_a)
amgprec/impl/level/amg_c_base_onelev_map_prol.F90
-135
View File
@@ -1,135 +0,0 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
!
! (C) Copyright 2020
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
subroutine amg_c_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
use psb_base_mod
use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_map_prol_v
implicit none
class(amg_c_onelev_type), target, intent(inout) :: lv
complex(psb_spk_), intent(in) :: alpha, beta
type(psb_c_vect_type), intent(inout) :: vect_u, vect_v
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional :: work(:)
type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty
!!$ write(0,*) 'New map_prol',lv%remap_data%ac_pre_remap%is_asb()
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
!!$ write(0,*) 'Remap handling '
block
type(psb_ctxt_type) :: ctxt, nctxt
integer(psb_ipk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp
integer(psb_ipk_) :: me, np, rme, rnp
complex(psb_spk_), allocatable :: rsnd(:), rrcv(:)
type(psb_c_vect_type) :: tv
ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
call psb_info(ctxt,me,np)
!!$ write(0,*) 'Old context ',me,np,psb_errstatus_fatal()
nctxt = lv%desc_ac%get_ctxt()
call psb_info(nctxt,rme,rnp)
!!$ write(0,*) 'New context ',rme,rnp,psb_errstatus_fatal()
idest = lv%remap_data%idest
associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
!!$ write(0,*) 'Should apply maps, then receive data from ',idest,' to ',me,psb_errstatus_fatal()
nsrc = size(isrc)
nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
nrc = lv%remap_data%desc_ac_pre_remap%get_local_cols()
if (rme >=0) then
allocate(rrcv(sum(nrsrc)))
rrcv = vect_v%get_vect()
!!$ write(0,*) me,rme,' Size check ',size(rrcv),lv%desc_ac%get_local_rows(),psb_errstatus_fatal()
kp = 0
do i = 1,size(isrc)
ip = isrc(i)
nrl = nrsrc(i)
!!$ write(0,*) me,' Sending to ',ip,nrl,kp+1,kp+nrl
call psb_snd(ctxt,rrcv(kp+1:kp+nrl),ip)
kp = kp + nrl
end do
end if
nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
!!$ write(0,*) me, ' Allocated ',nrl,info,psb_errstatus_fatal()
call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info)
!!$ write(0,*) me,' Size of TV ',nrl,tv%get_nrows(),info
!!$ write(0,*) me,' Receiving from ',idest,nrl,psb_errstatus_fatal()
call psb_realloc(nrc,rsnd,info)
call psb_rcv(ctxt,rsnd(1:nrl),idest)
call tv%set_vect(rsnd)
call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,&
& work=work,vtx=vtx,vty=vty)
end associate
!!$ write(0,*) me, ' Prolongator with remap done '
!!$ flush(0)
!!$ call psb_barrier(ctxt)
end block
else
! Default transfer
call lv%linmap%map_V2U(alpha,vect_v,beta,vect_u,info,&
& work=work,vtx=vtx,vty=vty)
end if
end subroutine amg_c_base_onelev_map_prol_v
subroutine amg_c_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
use psb_base_mod
use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_map_prol_a
implicit none
class(amg_c_onelev_type), target, intent(inout) :: lv
complex(psb_spk_), intent(in) :: alpha, beta
complex(psb_spk_), intent(inout) :: u(:)
complex(psb_spk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional :: work(:)
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
write(0,*) 'Remap handling not implemented yet '
else
! Default transfer
call lv%linmap%map_V2U(alpha,v,beta,u,info,&
& work=work)
end if
end subroutine amg_c_base_onelev_map_prol_a
amgprec/impl/level/amg_c_base_onelev_map_rstr.F90
-129
View File
@@ -1,129 +0,0 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
!
! (C) Copyright 2020
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
subroutine amg_c_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
& work,vtx,vty)
use psb_base_mod
use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_map_rstr_v
implicit none
class(amg_c_onelev_type), target, intent(inout) :: lv
complex(psb_spk_), intent(in) :: alpha, beta
type(psb_c_vect_type), intent(inout) :: vect_u, vect_v
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional :: work(:)
type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty
!!$ write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
!!$ write(0,*) 'Remap handling not implemented yet '
block
type(psb_ctxt_type) :: ctxt, nctxt
integer(psb_ipk_) :: i,j,ip, idest, nsrc, nrl, kp
integer(psb_ipk_) :: me, np, rme, rnp
complex(psb_spk_), allocatable :: rsnd(:), rrcv(:)
type(psb_c_vect_type) :: tv
ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
call psb_info(ctxt,me,np)
nctxt = lv%desc_ac%get_ctxt()
call psb_info(nctxt,rme,rnp)
!!$ write(0,*) 'New context ',rme,rnp
idest = lv%remap_data%idest
associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
!!$ write(0,*) 'Should apply maps, then send data from ',me,' to ',idest
!!$ if (rme >= 0) write(0,*) rme, ' Receiving data from ',isrc(:)
nsrc = size(isrc)
nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info)
!!$ write(0,*) me,' Size of TV ',tv%get_nrows()
call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,&
& work=work,vtx=vtx,vty=vty)
rsnd = tv%get_vect()
call psb_snd(ctxt,rsnd(1:nrl),idest)
if (rme >=0) then
allocate(rrcv(sum(nrsrc)))
!!$ write(0,*) me,rme,' Size check ',size(rrcv)!,lv%desc_ac%get_local_rows()
kp = 0
do i = 1,size(isrc)
ip = isrc(i)
nrl = nrsrc(i)
!!$ write(0,*) me,' Receiving from ',ip,nrl,kp+1,kp+nrl,size(rrcv)
call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip)
kp = kp + nrl
end do
call vect_v%set_vect(rrcv)
end if
end associate
!!$ write(0,*) me, ' Restrictor with remap done '
end block
else
! Default transfer
call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,&
& work=work,vtx=vtx,vty=vty)
end if
end subroutine amg_c_base_onelev_map_rstr_v
subroutine amg_c_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
use psb_base_mod
use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_map_rstr_a
implicit none
class(amg_c_onelev_type), target, intent(inout) :: lv
complex(psb_spk_), intent(in) :: alpha, beta
complex(psb_spk_), intent(inout) :: u(:)
complex(psb_spk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional :: work(:)
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
write(0,*) 'Remap handling not implemented yet '
else
! Default transfer
call lv%linmap%map_U2V(alpha,u,beta,v,info,&
& work=work)
end if
end subroutine amg_c_base_onelev_map_rstr_a
amgprec/impl/level/amg_c_base_onelev_mat_asb.f90
+2 -2
View File
@@ -53,7 +53,7 @@
! 2. Call amg_Xaggrmat_asb to compute prolongator/restrictor/AC
! 3. According to the choice of DIST/REPL for AC, build a descriptor DESC_AC,
! and adjust the column numbering of AC/OP_PROL/OP_RESTR
! 4. Pack restrictor and prolongator into p%linmap
! 4. Pack restrictor and prolongator into p%map
! 5. Fix base_a and base_desc pointers.
!
!
@@ -158,7 +158,7 @@ subroutine amg_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call lv%aggr%bld_map(desc_a, lv%desc_ac,&
& ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
& ilaggr,nlaggr,op_restr,op_prol,lv%map,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld')
goto 9999
amgprec/impl/level/amg_d_base_onelev_build.f90
+64 -73
View File
@@ -71,81 +71,72 @@ subroutine amg_d_base_onelev_build(lv,info,amold,vmold,imold,ilv)
ctxt = lv%base_desc%get_ctxt()
call psb_info(ctxt,me,np)
!
! At top level(s) I may be using
! a context with less processes
!
if (me < 0) then
!!$ write(0,*) 'onelevbld: I am excluded from this one '
else
!!$ write(0,*) me,' Going to build smoothers at this level '
if (.not.allocated(lv%sm)) then
!! Error: should have called amg_dprecinit
info=3111
call psb_errpush(info,name)
goto 9999
if (.not.allocated(lv%sm)) then
!! Error: should have called amg_dprecinit
info=3111
call psb_errpush(info,name)
goto 9999
end if
if (.not.allocated(lv%sm%sv)) then
!! Error: should have called amg_dprecinit
info=3111
call psb_errpush(info,name)
goto 9999
end if
lv%ac_nz_loc = lv%ac%get_nzeros()
lv%ac_nz_tot = lv%ac_nz_loc
select case(lv%parms%coarse_mat)
case(amg_distr_mat_)
call psb_sum(ctxt,lv%ac_nz_tot)
case(amg_repl_mat_)
! Do nothing
case default
! Should never get here
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Wrong lv%parms')
goto 9999
end select
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
call amg_check_def(lv%parms%sweeps_pre,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call amg_check_def(lv%parms%sweeps_post,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call lv%sm%build(lv%base_a,lv%base_desc,info)
if (info == 0) then
if (allocated(lv%sm2a)) then
call lv%sm2a%build(lv%base_a,lv%base_desc,info)
lv%sm2 => lv%sm2a
else
lv%sm2 => lv%sm
end if
if (.not.allocated(lv%sm%sv)) then
!! Error: should have called amg_dprecinit
info=3111
call psb_errpush(info,name)
goto 9999
end if
lv%ac_nz_loc = lv%ac%get_nzeros()
lv%ac_nz_tot = lv%ac_nz_loc
select case(lv%parms%coarse_mat)
case(amg_distr_mat_)
call psb_sum(ctxt,lv%ac_nz_tot)
case(amg_repl_mat_)
! Do nothing
case default
! Should never get here
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Wrong lv%parms')
goto 9999
end select
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
call amg_check_def(lv%parms%sweeps_pre,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call amg_check_def(lv%parms%sweeps_post,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call lv%sm%build(lv%base_a,lv%base_desc,info)
if (info == 0) then
if (allocated(lv%sm2a)) then
call lv%sm2a%build(lv%base_a,lv%base_desc,info)
lv%sm2 => lv%sm2a
else
lv%sm2 => lv%sm
end if
end if
if (info /=0 ) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Smoother bld error')
goto 9999
end if
if (lv%sm%sv%is_global()) then
if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then
lv%parms%sweeps_pre = 1
lv%parms%sweeps_post = 1
if (me == 0) then
write(debug_unit,*)
if (present(ilv)) then
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
& '" at level ',ilv
write(debug_unit,*) ' is configured as a global solver '
else
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
& '" is configured as a global solver '
end if
write(debug_unit,*) ' Pre and post sweeps at this level reset to 1'
end if
if (info /=0 ) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Smoother bld error')
goto 9999
end if
if (lv%sm%sv%is_global()) then
if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then
lv%parms%sweeps_pre = 1
lv%parms%sweeps_post = 1
if (me == 0) then
write(debug_unit,*)
if (present(ilv)) then
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
& '" at level ',ilv
write(debug_unit,*) ' is configured as a global solver '
else
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
& '" is configured as a global solver '
end if
write(debug_unit,*) ' Pre and post sweeps at this level reset to 1'
end if
end if
end if
amgprec/impl/level/amg_d_base_onelev_cnv.f90
+1 -1
View File
@@ -62,6 +62,6 @@ subroutine amg_d_base_onelev_cnv(lv,info,amold,vmold,imold)
& call lv%ac%cscnv(info,mold=amold)
if (info == psb_success_ .and. lv%desc_ac%is_ok() &
& .and. present(imold)) call lv%desc_ac%cnv(imold)
if (info == psb_success_) call lv%linmap%cnv(info,mold=amold,imold=imold)
if (info == psb_success_) call lv%map%cnv(info,mold=amold,imold=imold)
end if
end subroutine amg_d_base_onelev_cnv
amgprec/impl/level/amg_d_base_onelev_csetc.F90
+44 -56
View File
@@ -1,15 +1,15 @@
!
!
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
!
! (C) Copyright 2020
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
!
! (C) Copyright 2020
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
@@ -21,7 +21,7 @@
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
@@ -33,10 +33,10 @@
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
!
!
subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
use psb_base_mod
use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_csetc
use amg_d_base_aggregator_mod
@@ -49,9 +49,6 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
use amg_d_ilu_solver
use amg_d_id_solver
use amg_d_gs_solver
use amg_d_ainv_solver
use amg_d_invk_solver
use amg_d_invt_solver
#if defined(HAVE_UMF_)
use amg_d_umf_solver
#endif
@@ -68,16 +65,16 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
Implicit None
! Arguments
class(amg_d_onelev_type), intent(inout) :: lv
character(len=*), intent(in) :: what
class(amg_d_onelev_type), intent(inout) :: lv
character(len=*), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
integer(psb_ipk_), intent(in), optional :: idx
! Local
! Local
integer(psb_ipk_) :: ipos_, err_act
character(len=20) :: name='d_base_onelev_csetc'
integer(psb_ipk_) :: ival
integer(psb_ipk_) :: ival
type(amg_d_base_smoother_type) :: amg_d_base_smoother_mold
type(amg_d_jac_smoother_type) :: amg_d_jac_smoother_mold
type(amg_d_l1_jac_smoother_type) :: amg_d_l1_jac_smoother_mold
@@ -88,9 +85,6 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
type(amg_d_id_solver_type) :: amg_d_id_solver_mold
type(amg_d_gs_solver_type) :: amg_d_gs_solver_mold
type(amg_d_bwgs_solver_type) :: amg_d_bwgs_solver_mold
type(amg_d_ainv_solver_type) :: amg_d_ainv_solver_mold
type(amg_d_invk_solver_type) :: amg_d_invk_solver_mold
type(amg_d_invt_solver_type) :: amg_d_invt_solver_mold
#if defined(HAVE_UMF_)
type(amg_d_umf_solver_type) :: amg_d_umf_solver_mold
#endif
@@ -103,7 +97,7 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
#if defined(HAVE_MUMPS_)
type(amg_d_mumps_solver_type) :: amg_d_mumps_solver_mold
#endif
call psb_erractionsave(err_act)
@@ -124,14 +118,14 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
else
ipos_ = amg_smooth_both_
end if
select case (psb_toupper(trim(what)))
case ('SMOOTHER_TYPE')
select case (psb_toupper(trim(val)))
case ('NOPREC','NONE')
call lv%set(amg_d_base_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(amg_d_id_solver_mold,info,pos=pos)
case ('JAC','JACOBI')
call lv%set(amg_d_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(amg_d_diag_solver_mold,info,pos=pos)
@@ -139,11 +133,11 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
case ('L1-JACOBI')
call lv%set(amg_d_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos)
case ('BJAC')
call lv%set(amg_d_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
case ('L1-BJAC')
call lv%set(amg_d_l1_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
@@ -172,65 +166,59 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
case ('L1-BWGS')
call lv%set(amg_d_l1_jac_smoother_mold,info,pos='pre')
if (info == 0) call lv%set(amg_d_bwgs_solver_mold,info,pos='pre')
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
case ('L1-FBGS')
call lv%set(amg_d_l1_jac_smoother_mold,info,pos='pre')
if (info == 0) call lv%set(amg_d_gs_solver_mold,info,pos='pre')
call lv%set(amg_d_l1_jac_smoother_mold,info,pos='post')
if (info == 0) call lv%set(amg_d_bwgs_solver_mold,info,pos='post')
case default
!
! Do nothing and hope for the best :)
! Do nothing and hope for the best :)
!
end select
if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then
if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then
if (allocated(lv%sm)) call lv%sm%default()
end if
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then
if (allocated(lv%sm2a)) call lv%sm2a%default()
end if
case('SUB_SOLVE')
select case (psb_toupper(trim(val)))
case ('NONE','NOPREC','FACT_NONE')
call lv%set(amg_d_id_solver_mold,info,pos=pos)
case ('DIAG')
call lv%set(amg_d_diag_solver_mold,info,pos=pos)
case ('L1-DIAG')
call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos)
case ('GS','FGS','FWGS')
call lv%set(amg_d_gs_solver_mold,info,pos=pos)
case ('BGS','BWGS')
call lv%set(amg_d_bwgs_solver_mold,info,pos=pos)
case ('AINV')
call lv%set(amg_d_ainv_solver_mold,info,pos=pos)
case ('INVK')
call lv%set(amg_d_invk_solver_mold,info,pos=pos)
case ('INVT')
call lv%set(amg_d_invt_solver_mold,info,pos=pos)
case ('ILU','ILUT','MILU')
call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
if (info == 0) then
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
call lv%sm%sv%set('SUB_SOLVE',val,info)
end if
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
end if
end if
#ifdef HAVE_SLU_
case ('SLU')
case ('SLU')
call lv%set(amg_d_slu_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_MUMPS_
case ('MUMPS')
case ('MUMPS')
call lv%set(amg_d_mumps_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_SLUDIST_
@@ -243,10 +231,10 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
#endif
case default
!
! Do nothing and hope for the best :)
! Do nothing and hope for the best :)
!
end select
case ('ML_CYCLE')
lv%parms%ml_cycle = amg_stringval(val)
@@ -261,7 +249,7 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
return
end if
end if
select case(ival)
case(amg_dec_aggr_)
allocate(amg_d_dec_aggregator_type :: lv%aggr, stat=info)
@@ -271,7 +259,7 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
info = psb_err_internal_error_
end select
if (info == psb_success_) call lv%aggr%default()
case ('AGGR_ORD')
lv%parms%aggr_ord = amg_stringval(val)
@@ -298,13 +286,13 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
lv%parms%coarse_solve = amg_stringval(val)
case default
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
if (allocated(lv%sm)) then
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info,idx=idx)
end if
end if
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
if (allocated(lv%sm2a)) then
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info,idx=idx)
end if
end if
amgprec/impl/level/amg_d_base_onelev_descr.f90
+3 -3
View File
@@ -89,11 +89,11 @@ subroutine amg_d_base_onelev_descr(lv,il,nl,ilmin,info,iout)
call lv%parms%descr(iout_,info,coarse=coarse)
if (nl > 1) then
if (allocated(lv%linmap%naggr)) then
if (allocated(lv%map%naggr)) then
write(iout_,*) ' Coarse Matrix: Global size: ', &
& sum((1_psb_lpk_*lv%linmap%naggr(:))),' Nonzeros: ',lv%ac_nz_tot
& sum((1_psb_lpk_*lv%map%naggr(:))),' Nonzeros: ',lv%ac_nz_tot
write(iout_,*) ' Local matrix sizes: ', &
& lv%linmap%naggr(:)
& lv%map%naggr(:)
write(iout_,*) ' Aggregation ratio: ', &
& lv%szratio
end if
amgprec/impl/level/amg_d_base_onelev_dump.f90
+7 -7
View File
@@ -108,17 +108,17 @@ subroutine amg_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
call lv%ac%print(fname,head=head,iv=ivr)
end if
if (rp_) then
ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.)
ivc = lv%linmap%p_desc_V%get_global_indices(owned=.false.)
ivr = lv%map%p_desc_U%get_global_indices(owned=.false.)
ivc = lv%map%p_desc_V%get_global_indices(owned=.false.)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
call lv%linmap%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr)
call lv%map%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
call lv%linmap%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc)
call lv%map%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc)
end if
if (tprol_) then
! Tentative prolongator is stored with column indices already
! in global numbering, so only IVR is needed.
ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.)
ivr = lv%map%p_desc_U%get_global_indices(owned=.false.)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
!
! This is not implemented yet.
@@ -133,9 +133,9 @@ subroutine amg_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
end if
if (rp_) then
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
call lv%linmap%mat_U2V%print(fname,head=head)
call lv%map%mat_U2V%print(fname,head=head)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
call lv%linmap%mat_V2U%print(fname,head=head)
call lv%map%mat_V2U%print(fname,head=head)
end if
if (tprol_) then
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
amgprec/impl/level/amg_d_base_onelev_free.f90
+1 -1
View File
@@ -63,7 +63,7 @@ subroutine amg_d_base_onelev_free(lv,info)
call lv%ac%free()
if (lv%desc_ac%is_ok()) &
& call lv%desc_ac%free(info)
call lv%linmap%free(info)
call lv%map%free(info)
! This is a pointer to something else, must not free it here.
nullify(lv%base_a)
amgprec/impl/level/amg_d_base_onelev_map_prol.F90
-135
View File
@@ -1,135 +0,0 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
!
! (C) Copyright 2020
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
subroutine amg_d_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
use psb_base_mod
use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_map_prol_v
implicit none
class(amg_d_onelev_type), target, intent(inout) :: lv
real(psb_dpk_), intent(in) :: alpha, beta
type(psb_d_vect_type), intent(inout) :: vect_u, vect_v
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional :: work(:)
type(psb_d_vect_type), optional, target, intent(inout) :: vtx,vty
!!$ write(0,*) 'New map_prol',lv%remap_data%ac_pre_remap%is_asb()
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
!!$ write(0,*) 'Remap handling '
block
type(psb_ctxt_type) :: ctxt, nctxt
integer(psb_ipk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp
integer(psb_ipk_) :: me, np, rme, rnp
real(psb_dpk_), allocatable :: rsnd(:), rrcv(:)
type(psb_d_vect_type) :: tv
ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
call psb_info(ctxt,me,np)
!!$ write(0,*) 'Old context ',me,np,psb_errstatus_fatal()
nctxt = lv%desc_ac%get_ctxt()
call psb_info(nctxt,rme,rnp)
!!$ write(0,*) 'New context ',rme,rnp,psb_errstatus_fatal()
idest = lv%remap_data%idest
associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
!!$ write(0,*) 'Should apply maps, then receive data from ',idest,' to ',me,psb_errstatus_fatal()
nsrc = size(isrc)
nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
nrc = lv%remap_data%desc_ac_pre_remap%get_local_cols()
if (rme >=0) then
allocate(rrcv(sum(nrsrc)))
rrcv = vect_v%get_vect()
!!$ write(0,*) me,rme,' Size check ',size(rrcv),lv%desc_ac%get_local_rows(),psb_errstatus_fatal()
kp = 0
do i = 1,size(isrc)
ip = isrc(i)
nrl = nrsrc(i)
!!$ write(0,*) me,' Sending to ',ip,nrl,kp+1,kp+nrl
call psb_snd(ctxt,rrcv(kp+1:kp+nrl),ip)
kp = kp + nrl
end do
end if
nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
!!$ write(0,*) me, ' Allocated ',nrl,info,psb_errstatus_fatal()
call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info)
!!$ write(0,*) me,' Size of TV ',nrl,tv%get_nrows(),info
!!$ write(0,*) me,' Receiving from ',idest,nrl,psb_errstatus_fatal()
call psb_realloc(nrc,rsnd,info)
call psb_rcv(ctxt,rsnd(1:nrl),idest)
call tv%set_vect(rsnd)
call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,&
& work=work,vtx=vtx,vty=vty)
end associate
!!$ write(0,*) me, ' Prolongator with remap done '
!!$ flush(0)
!!$ call psb_barrier(ctxt)
end block
else
! Default transfer
call lv%linmap%map_V2U(alpha,vect_v,beta,vect_u,info,&
& work=work,vtx=vtx,vty=vty)
end if
end subroutine amg_d_base_onelev_map_prol_v
subroutine amg_d_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
use psb_base_mod
use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_map_prol_a
implicit none
class(amg_d_onelev_type), target, intent(inout) :: lv
real(psb_dpk_), intent(in) :: alpha, beta
real(psb_dpk_), intent(inout) :: u(:)
real(psb_dpk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional :: work(:)
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
write(0,*) 'Remap handling not implemented yet '
else
! Default transfer
call lv%linmap%map_V2U(alpha,v,beta,u,info,&
& work=work)
end if
end subroutine amg_d_base_onelev_map_prol_a
amgprec/impl/level/amg_d_base_onelev_map_rstr.F90
-129
View File
@@ -1,129 +0,0 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
!
! (C) Copyright 2020
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
& work,vtx,vty)
use psb_base_mod
use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_map_rstr_v
implicit none
class(amg_d_onelev_type), target, intent(inout) :: lv
real(psb_dpk_), intent(in) :: alpha, beta
type(psb_d_vect_type), intent(inout) :: vect_u, vect_v
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional :: work(:)
type(psb_d_vect_type), optional, target, intent(inout) :: vtx,vty
!!$ write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
!!$ write(0,*) 'Remap handling not implemented yet '
block
type(psb_ctxt_type) :: ctxt, nctxt
integer(psb_ipk_) :: i,j,ip, idest, nsrc, nrl, kp
integer(psb_ipk_) :: me, np, rme, rnp
real(psb_dpk_), allocatable :: rsnd(:), rrcv(:)
type(psb_d_vect_type) :: tv
ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
call psb_info(ctxt,me,np)
nctxt = lv%desc_ac%get_ctxt()
call psb_info(nctxt,rme,rnp)
!!$ write(0,*) 'New context ',rme,rnp
idest = lv%remap_data%idest
associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
!!$ write(0,*) 'Should apply maps, then send data from ',me,' to ',idest
!!$ if (rme >= 0) write(0,*) rme, ' Receiving data from ',isrc(:)
nsrc = size(isrc)
nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info)
!!$ write(0,*) me,' Size of TV ',tv%get_nrows()
call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,&
& work=work,vtx=vtx,vty=vty)
rsnd = tv%get_vect()
call psb_snd(ctxt,rsnd(1:nrl),idest)
if (rme >=0) then
allocate(rrcv(sum(nrsrc)))
!!$ write(0,*) me,rme,' Size check ',size(rrcv)!,lv%desc_ac%get_local_rows()
kp = 0
do i = 1,size(isrc)
ip = isrc(i)
nrl = nrsrc(i)
!!$ write(0,*) me,' Receiving from ',ip,nrl,kp+1,kp+nrl,size(rrcv)
call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip)
kp = kp + nrl
end do
call vect_v%set_vect(rrcv)
end if
end associate
!!$ write(0,*) me, ' Restrictor with remap done '
end block
else
! Default transfer
call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,&
& work=work,vtx=vtx,vty=vty)
end if
end subroutine amg_d_base_onelev_map_rstr_v
subroutine amg_d_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
use psb_base_mod
use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_map_rstr_a
implicit none
class(amg_d_onelev_type), target, intent(inout) :: lv
real(psb_dpk_), intent(in) :: alpha, beta
real(psb_dpk_), intent(inout) :: u(:)
real(psb_dpk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional :: work(:)
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
write(0,*) 'Remap handling not implemented yet '
else
! Default transfer
call lv%linmap%map_U2V(alpha,u,beta,v,info,&
& work=work)
end if
end subroutine amg_d_base_onelev_map_rstr_a
amgprec/impl/level/amg_d_base_onelev_mat_asb.f90
+2 -2
View File
@@ -53,7 +53,7 @@
! 2. Call amg_Xaggrmat_asb to compute prolongator/restrictor/AC
! 3. According to the choice of DIST/REPL for AC, build a descriptor DESC_AC,
! and adjust the column numbering of AC/OP_PROL/OP_RESTR
! 4. Pack restrictor and prolongator into p%linmap
! 4. Pack restrictor and prolongator into p%map
! 5. Fix base_a and base_desc pointers.
!
!
@@ -158,7 +158,7 @@ subroutine amg_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call lv%aggr%bld_map(desc_a, lv%desc_ac,&
& ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
& ilaggr,nlaggr,op_restr,op_prol,lv%map,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld')
goto 9999
amgprec/impl/level/amg_s_base_onelev_build.f90
+64 -73
View File
@@ -71,81 +71,72 @@ subroutine amg_s_base_onelev_build(lv,info,amold,vmold,imold,ilv)
ctxt = lv%base_desc%get_ctxt()
call psb_info(ctxt,me,np)
!
! At top level(s) I may be using
! a context with less processes
!
if (me < 0) then
!!$ write(0,*) 'onelevbld: I am excluded from this one '
else
!!$ write(0,*) me,' Going to build smoothers at this level '
if (.not.allocated(lv%sm)) then
!! Error: should have called amg_dprecinit
info=3111
call psb_errpush(info,name)
goto 9999
if (.not.allocated(lv%sm)) then
!! Error: should have called amg_dprecinit
info=3111
call psb_errpush(info,name)
goto 9999
end if
if (.not.allocated(lv%sm%sv)) then
!! Error: should have called amg_dprecinit
info=3111
call psb_errpush(info,name)
goto 9999
end if
lv%ac_nz_loc = lv%ac%get_nzeros()
lv%ac_nz_tot = lv%ac_nz_loc
select case(lv%parms%coarse_mat)
case(amg_distr_mat_)
call psb_sum(ctxt,lv%ac_nz_tot)
case(amg_repl_mat_)
! Do nothing
case default
! Should never get here
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Wrong lv%parms')
goto 9999
end select
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
call amg_check_def(lv%parms%sweeps_pre,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call amg_check_def(lv%parms%sweeps_post,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call lv%sm%build(lv%base_a,lv%base_desc,info)
if (info == 0) then
if (allocated(lv%sm2a)) then
call lv%sm2a%build(lv%base_a,lv%base_desc,info)
lv%sm2 => lv%sm2a
else
lv%sm2 => lv%sm
end if
if (.not.allocated(lv%sm%sv)) then
!! Error: should have called amg_dprecinit
info=3111
call psb_errpush(info,name)
goto 9999
end if
lv%ac_nz_loc = lv%ac%get_nzeros()
lv%ac_nz_tot = lv%ac_nz_loc
select case(lv%parms%coarse_mat)
case(amg_distr_mat_)
call psb_sum(ctxt,lv%ac_nz_tot)
case(amg_repl_mat_)
! Do nothing
case default
! Should never get here
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Wrong lv%parms')
goto 9999
end select
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
call amg_check_def(lv%parms%sweeps_pre,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call amg_check_def(lv%parms%sweeps_post,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call lv%sm%build(lv%base_a,lv%base_desc,info)
if (info == 0) then
if (allocated(lv%sm2a)) then
call lv%sm2a%build(lv%base_a,lv%base_desc,info)
lv%sm2 => lv%sm2a
else
lv%sm2 => lv%sm
end if
end if
if (info /=0 ) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Smoother bld error')
goto 9999
end if
if (lv%sm%sv%is_global()) then
if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then
lv%parms%sweeps_pre = 1
lv%parms%sweeps_post = 1
if (me == 0) then
write(debug_unit,*)
if (present(ilv)) then
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
& '" at level ',ilv
write(debug_unit,*) ' is configured as a global solver '
else
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
& '" is configured as a global solver '
end if
write(debug_unit,*) ' Pre and post sweeps at this level reset to 1'
end if
if (info /=0 ) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Smoother bld error')
goto 9999
end if
if (lv%sm%sv%is_global()) then
if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then
lv%parms%sweeps_pre = 1
lv%parms%sweeps_post = 1
if (me == 0) then
write(debug_unit,*)
if (present(ilv)) then
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
& '" at level ',ilv
write(debug_unit,*) ' is configured as a global solver '
else
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
& '" is configured as a global solver '
end if
write(debug_unit,*) ' Pre and post sweeps at this level reset to 1'
end if
end if
end if
amgprec/impl/level/amg_s_base_onelev_cnv.f90
+1 -1
View File
@@ -62,6 +62,6 @@ subroutine amg_s_base_onelev_cnv(lv,info,amold,vmold,imold)
& call lv%ac%cscnv(info,mold=amold)
if (info == psb_success_ .and. lv%desc_ac%is_ok() &
& .and. present(imold)) call lv%desc_ac%cnv(imold)
if (info == psb_success_) call lv%linmap%cnv(info,mold=amold,imold=imold)
if (info == psb_success_) call lv%map%cnv(info,mold=amold,imold=imold)
end if
end subroutine amg_s_base_onelev_cnv
amgprec/impl/level/amg_s_base_onelev_csetc.F90
+44 -56
View File
@@ -1,15 +1,15 @@
!
!
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
!
! (C) Copyright 2020
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
!
! (C) Copyright 2020
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
@@ -21,7 +21,7 @@
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
@@ -33,10 +33,10 @@
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
!
!
subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
use psb_base_mod
use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_csetc
use amg_s_base_aggregator_mod
@@ -49,9 +49,6 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
use amg_s_ilu_solver
use amg_s_id_solver
use amg_s_gs_solver
use amg_s_ainv_solver
use amg_s_invk_solver
use amg_s_invt_solver
#if defined(HAVE_SLU_)
use amg_s_slu_solver
#endif
@@ -62,16 +59,16 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
Implicit None
! Arguments
class(amg_s_onelev_type), intent(inout) :: lv
character(len=*), intent(in) :: what
class(amg_s_onelev_type), intent(inout) :: lv
character(len=*), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
integer(psb_ipk_), intent(in), optional :: idx
! Local
! Local
integer(psb_ipk_) :: ipos_, err_act
character(len=20) :: name='s_base_onelev_csetc'
integer(psb_ipk_) :: ival
integer(psb_ipk_) :: ival
type(amg_s_base_smoother_type) :: amg_s_base_smoother_mold
type(amg_s_jac_smoother_type) :: amg_s_jac_smoother_mold
type(amg_s_l1_jac_smoother_type) :: amg_s_l1_jac_smoother_mold
@@ -82,16 +79,13 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
type(amg_s_id_solver_type) :: amg_s_id_solver_mold
type(amg_s_gs_solver_type) :: amg_s_gs_solver_mold
type(amg_s_bwgs_solver_type) :: amg_s_bwgs_solver_mold
type(amg_s_ainv_solver_type) :: amg_s_ainv_solver_mold
type(amg_s_invk_solver_type) :: amg_s_invk_solver_mold
type(amg_s_invt_solver_type) :: amg_s_invt_solver_mold
#if defined(HAVE_SLU_)
type(amg_s_slu_solver_type) :: amg_s_slu_solver_mold
#endif
#if defined(HAVE_MUMPS_)
type(amg_s_mumps_solver_type) :: amg_s_mumps_solver_mold
#endif
call psb_erractionsave(err_act)
@@ -112,14 +106,14 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
else
ipos_ = amg_smooth_both_
end if
select case (psb_toupper(trim(what)))
case ('SMOOTHER_TYPE')
select case (psb_toupper(trim(val)))
case ('NOPREC','NONE')
call lv%set(amg_s_base_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(amg_s_id_solver_mold,info,pos=pos)
case ('JAC','JACOBI')
call lv%set(amg_s_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(amg_s_diag_solver_mold,info,pos=pos)
@@ -127,11 +121,11 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
case ('L1-JACOBI')
call lv%set(amg_s_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(amg_s_l1_diag_solver_mold,info,pos=pos)
case ('BJAC')
call lv%set(amg_s_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(amg_s_ilu_solver_mold,info,pos=pos)
case ('L1-BJAC')
call lv%set(amg_s_l1_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(amg_s_ilu_solver_mold,info,pos=pos)
@@ -160,73 +154,67 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
case ('L1-BWGS')
call lv%set(amg_s_l1_jac_smoother_mold,info,pos='pre')
if (info == 0) call lv%set(amg_s_bwgs_solver_mold,info,pos='pre')
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
case ('L1-FBGS')
call lv%set(amg_s_l1_jac_smoother_mold,info,pos='pre')
if (info == 0) call lv%set(amg_s_gs_solver_mold,info,pos='pre')
call lv%set(amg_s_l1_jac_smoother_mold,info,pos='post')
if (info == 0) call lv%set(amg_s_bwgs_solver_mold,info,pos='post')
case default
!
! Do nothing and hope for the best :)
! Do nothing and hope for the best :)
!
end select
if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then
if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then
if (allocated(lv%sm)) call lv%sm%default()
end if
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then
if (allocated(lv%sm2a)) call lv%sm2a%default()
end if
case('SUB_SOLVE')
select case (psb_toupper(trim(val)))
case ('NONE','NOPREC','FACT_NONE')
call lv%set(amg_s_id_solver_mold,info,pos=pos)
case ('DIAG')
call lv%set(amg_s_diag_solver_mold,info,pos=pos)
case ('L1-DIAG')
call lv%set(amg_s_l1_diag_solver_mold,info,pos=pos)
case ('GS','FGS','FWGS')
call lv%set(amg_s_gs_solver_mold,info,pos=pos)
case ('BGS','BWGS')
call lv%set(amg_s_bwgs_solver_mold,info,pos=pos)
case ('AINV')
call lv%set(amg_s_ainv_solver_mold,info,pos=pos)
case ('INVK')
call lv%set(amg_s_invk_solver_mold,info,pos=pos)
case ('INVT')
call lv%set(amg_s_invt_solver_mold,info,pos=pos)
case ('ILU','ILUT','MILU')
call lv%set(amg_s_ilu_solver_mold,info,pos=pos)
if (info == 0) then
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
call lv%sm%sv%set('SUB_SOLVE',val,info)
end if
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
end if
end if
#ifdef HAVE_SLU_
case ('SLU')
case ('SLU')
call lv%set(amg_s_slu_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_MUMPS_
case ('MUMPS')
case ('MUMPS')
call lv%set(amg_s_mumps_solver_mold,info,pos=pos)
#endif
case default
!
! Do nothing and hope for the best :)
! Do nothing and hope for the best :)
!
end select
case ('ML_CYCLE')
lv%parms%ml_cycle = amg_stringval(val)
@@ -241,7 +229,7 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
return
end if
end if
select case(ival)
case(amg_dec_aggr_)
allocate(amg_s_dec_aggregator_type :: lv%aggr, stat=info)
@@ -251,7 +239,7 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
info = psb_err_internal_error_
end select
if (info == psb_success_) call lv%aggr%default()
case ('AGGR_ORD')
lv%parms%aggr_ord = amg_stringval(val)
@@ -278,13 +266,13 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
lv%parms%coarse_solve = amg_stringval(val)
case default
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
if (allocated(lv%sm)) then
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info,idx=idx)
end if
end if
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
if (allocated(lv%sm2a)) then
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info,idx=idx)
end if
end if
amgprec/impl/level/amg_s_base_onelev_descr.f90
+3 -3
View File
@@ -89,11 +89,11 @@ subroutine amg_s_base_onelev_descr(lv,il,nl,ilmin,info,iout)
call lv%parms%descr(iout_,info,coarse=coarse)
if (nl > 1) then
if (allocated(lv%linmap%naggr)) then
if (allocated(lv%map%naggr)) then
write(iout_,*) ' Coarse Matrix: Global size: ', &
& sum((1_psb_lpk_*lv%linmap%naggr(:))),' Nonzeros: ',lv%ac_nz_tot
& sum((1_psb_lpk_*lv%map%naggr(:))),' Nonzeros: ',lv%ac_nz_tot
write(iout_,*) ' Local matrix sizes: ', &
& lv%linmap%naggr(:)
& lv%map%naggr(:)
write(iout_,*) ' Aggregation ratio: ', &
& lv%szratio
end if
amgprec/impl/level/amg_s_base_onelev_dump.f90
+7 -7
View File
@@ -108,17 +108,17 @@ subroutine amg_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
call lv%ac%print(fname,head=head,iv=ivr)
end if
if (rp_) then
ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.)
ivc = lv%linmap%p_desc_V%get_global_indices(owned=.false.)
ivr = lv%map%p_desc_U%get_global_indices(owned=.false.)
ivc = lv%map%p_desc_V%get_global_indices(owned=.false.)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
call lv%linmap%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr)
call lv%map%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
call lv%linmap%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc)
call lv%map%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc)
end if
if (tprol_) then
! Tentative prolongator is stored with column indices already
! in global numbering, so only IVR is needed.
ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.)
ivr = lv%map%p_desc_U%get_global_indices(owned=.false.)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
!
! This is not implemented yet.
@@ -133,9 +133,9 @@ subroutine amg_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
end if
if (rp_) then
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
call lv%linmap%mat_U2V%print(fname,head=head)
call lv%map%mat_U2V%print(fname,head=head)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
call lv%linmap%mat_V2U%print(fname,head=head)
call lv%map%mat_V2U%print(fname,head=head)
end if
if (tprol_) then
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
amgprec/impl/level/amg_s_base_onelev_free.f90
+1 -1
View File
@@ -63,7 +63,7 @@ subroutine amg_s_base_onelev_free(lv,info)
call lv%ac%free()
if (lv%desc_ac%is_ok()) &
& call lv%desc_ac%free(info)
call lv%linmap%free(info)
call lv%map%free(info)
! This is a pointer to something else, must not free it here.
nullify(lv%base_a)
amgprec/impl/level/amg_s_base_onelev_map_prol.F90
-135
View File
@@ -1,135 +0,0 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
!
! (C) Copyright 2020
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
subroutine amg_s_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
use psb_base_mod
use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_map_prol_v
implicit none
class(amg_s_onelev_type), target, intent(inout) :: lv
real(psb_spk_), intent(in) :: alpha, beta
type(psb_s_vect_type), intent(inout) :: vect_u, vect_v
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional :: work(:)
type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty
!!$ write(0,*) 'New map_prol',lv%remap_data%ac_pre_remap%is_asb()
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
!!$ write(0,*) 'Remap handling '
block
type(psb_ctxt_type) :: ctxt, nctxt
integer(psb_ipk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp
integer(psb_ipk_) :: me, np, rme, rnp
real(psb_spk_), allocatable :: rsnd(:), rrcv(:)
type(psb_s_vect_type) :: tv
ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
call psb_info(ctxt,me,np)
!!$ write(0,*) 'Old context ',me,np,psb_errstatus_fatal()
nctxt = lv%desc_ac%get_ctxt()
call psb_info(nctxt,rme,rnp)
!!$ write(0,*) 'New context ',rme,rnp,psb_errstatus_fatal()
idest = lv%remap_data%idest
associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
!!$ write(0,*) 'Should apply maps, then receive data from ',idest,' to ',me,psb_errstatus_fatal()
nsrc = size(isrc)
nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
nrc = lv%remap_data%desc_ac_pre_remap%get_local_cols()
if (rme >=0) then
allocate(rrcv(sum(nrsrc)))
rrcv = vect_v%get_vect()
!!$ write(0,*) me,rme,' Size check ',size(rrcv),lv%desc_ac%get_local_rows(),psb_errstatus_fatal()
kp = 0
do i = 1,size(isrc)
ip = isrc(i)
nrl = nrsrc(i)
!!$ write(0,*) me,' Sending to ',ip,nrl,kp+1,kp+nrl
call psb_snd(ctxt,rrcv(kp+1:kp+nrl),ip)
kp = kp + nrl
end do
end if
nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
!!$ write(0,*) me, ' Allocated ',nrl,info,psb_errstatus_fatal()
call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info)
!!$ write(0,*) me,' Size of TV ',nrl,tv%get_nrows(),info
!!$ write(0,*) me,' Receiving from ',idest,nrl,psb_errstatus_fatal()
call psb_realloc(nrc,rsnd,info)
call psb_rcv(ctxt,rsnd(1:nrl),idest)
call tv%set_vect(rsnd)
call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,&
& work=work,vtx=vtx,vty=vty)
end associate
!!$ write(0,*) me, ' Prolongator with remap done '
!!$ flush(0)
!!$ call psb_barrier(ctxt)
end block
else
! Default transfer
call lv%linmap%map_V2U(alpha,vect_v,beta,vect_u,info,&
& work=work,vtx=vtx,vty=vty)
end if
end subroutine amg_s_base_onelev_map_prol_v
subroutine amg_s_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
use psb_base_mod
use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_map_prol_a
implicit none
class(amg_s_onelev_type), target, intent(inout) :: lv
real(psb_spk_), intent(in) :: alpha, beta
real(psb_spk_), intent(inout) :: u(:)
real(psb_spk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional :: work(:)
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
write(0,*) 'Remap handling not implemented yet '
else
! Default transfer
call lv%linmap%map_V2U(alpha,v,beta,u,info,&
& work=work)
end if
end subroutine amg_s_base_onelev_map_prol_a
amgprec/impl/level/amg_s_base_onelev_map_rstr.F90
-129
View File
@@ -1,129 +0,0 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
!
! (C) Copyright 2020
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
subroutine amg_s_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
& work,vtx,vty)
use psb_base_mod
use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_map_rstr_v
implicit none
class(amg_s_onelev_type), target, intent(inout) :: lv
real(psb_spk_), intent(in) :: alpha, beta
type(psb_s_vect_type), intent(inout) :: vect_u, vect_v
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional :: work(:)
type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty
!!$ write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
!!$ write(0,*) 'Remap handling not implemented yet '
block
type(psb_ctxt_type) :: ctxt, nctxt
integer(psb_ipk_) :: i,j,ip, idest, nsrc, nrl, kp
integer(psb_ipk_) :: me, np, rme, rnp
real(psb_spk_), allocatable :: rsnd(:), rrcv(:)
type(psb_s_vect_type) :: tv
ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
call psb_info(ctxt,me,np)
nctxt = lv%desc_ac%get_ctxt()
call psb_info(nctxt,rme,rnp)
!!$ write(0,*) 'New context ',rme,rnp
idest = lv%remap_data%idest
associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
!!$ write(0,*) 'Should apply maps, then send data from ',me,' to ',idest
!!$ if (rme >= 0) write(0,*) rme, ' Receiving data from ',isrc(:)
nsrc = size(isrc)
nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info)
!!$ write(0,*) me,' Size of TV ',tv%get_nrows()
call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,&
& work=work,vtx=vtx,vty=vty)
rsnd = tv%get_vect()
call psb_snd(ctxt,rsnd(1:nrl),idest)
if (rme >=0) then
allocate(rrcv(sum(nrsrc)))
!!$ write(0,*) me,rme,' Size check ',size(rrcv)!,lv%desc_ac%get_local_rows()
kp = 0
do i = 1,size(isrc)
ip = isrc(i)
nrl = nrsrc(i)
!!$ write(0,*) me,' Receiving from ',ip,nrl,kp+1,kp+nrl,size(rrcv)
call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip)
kp = kp + nrl
end do
call vect_v%set_vect(rrcv)
end if
end associate
!!$ write(0,*) me, ' Restrictor with remap done '
end block
else
! Default transfer
call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,&
& work=work,vtx=vtx,vty=vty)
end if
end subroutine amg_s_base_onelev_map_rstr_v
subroutine amg_s_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
use psb_base_mod
use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_map_rstr_a
implicit none
class(amg_s_onelev_type), target, intent(inout) :: lv
real(psb_spk_), intent(in) :: alpha, beta
real(psb_spk_), intent(inout) :: u(:)
real(psb_spk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional :: work(:)
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
write(0,*) 'Remap handling not implemented yet '
else
! Default transfer
call lv%linmap%map_U2V(alpha,u,beta,v,info,&
& work=work)
end if
end subroutine amg_s_base_onelev_map_rstr_a
amgprec/impl/level/amg_s_base_onelev_mat_asb.f90
+2 -2
View File
@@ -53,7 +53,7 @@
! 2. Call amg_Xaggrmat_asb to compute prolongator/restrictor/AC
! 3. According to the choice of DIST/REPL for AC, build a descriptor DESC_AC,
! and adjust the column numbering of AC/OP_PROL/OP_RESTR
! 4. Pack restrictor and prolongator into p%linmap
! 4. Pack restrictor and prolongator into p%map
! 5. Fix base_a and base_desc pointers.
!
!
@@ -158,7 +158,7 @@ subroutine amg_s_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call lv%aggr%bld_map(desc_a, lv%desc_ac,&
& ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
& ilaggr,nlaggr,op_restr,op_prol,lv%map,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld')
goto 9999
amgprec/impl/level/amg_z_base_onelev_build.f90
+64 -73
View File
@@ -71,81 +71,72 @@ subroutine amg_z_base_onelev_build(lv,info,amold,vmold,imold,ilv)
ctxt = lv%base_desc%get_ctxt()
call psb_info(ctxt,me,np)
!
! At top level(s) I may be using
! a context with less processes
!
if (me < 0) then
!!$ write(0,*) 'onelevbld: I am excluded from this one '
else
!!$ write(0,*) me,' Going to build smoothers at this level '
if (.not.allocated(lv%sm)) then
!! Error: should have called amg_dprecinit
info=3111
call psb_errpush(info,name)
goto 9999
if (.not.allocated(lv%sm)) then
!! Error: should have called amg_dprecinit
info=3111
call psb_errpush(info,name)
goto 9999
end if
if (.not.allocated(lv%sm%sv)) then
!! Error: should have called amg_dprecinit
info=3111
call psb_errpush(info,name)
goto 9999
end if
lv%ac_nz_loc = lv%ac%get_nzeros()
lv%ac_nz_tot = lv%ac_nz_loc
select case(lv%parms%coarse_mat)
case(amg_distr_mat_)
call psb_sum(ctxt,lv%ac_nz_tot)
case(amg_repl_mat_)
! Do nothing
case default
! Should never get here
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Wrong lv%parms')
goto 9999
end select
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
call amg_check_def(lv%parms%sweeps_pre,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call amg_check_def(lv%parms%sweeps_post,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call lv%sm%build(lv%base_a,lv%base_desc,info)
if (info == 0) then
if (allocated(lv%sm2a)) then
call lv%sm2a%build(lv%base_a,lv%base_desc,info)
lv%sm2 => lv%sm2a
else
lv%sm2 => lv%sm
end if
if (.not.allocated(lv%sm%sv)) then
!! Error: should have called amg_dprecinit
info=3111
call psb_errpush(info,name)
goto 9999
end if
lv%ac_nz_loc = lv%ac%get_nzeros()
lv%ac_nz_tot = lv%ac_nz_loc
select case(lv%parms%coarse_mat)
case(amg_distr_mat_)
call psb_sum(ctxt,lv%ac_nz_tot)
case(amg_repl_mat_)
! Do nothing
case default
! Should never get here
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Wrong lv%parms')
goto 9999
end select
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
call amg_check_def(lv%parms%sweeps_pre,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call amg_check_def(lv%parms%sweeps_post,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call lv%sm%build(lv%base_a,lv%base_desc,info)
if (info == 0) then
if (allocated(lv%sm2a)) then
call lv%sm2a%build(lv%base_a,lv%base_desc,info)
lv%sm2 => lv%sm2a
else
lv%sm2 => lv%sm
end if
end if
if (info /=0 ) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Smoother bld error')
goto 9999
end if
if (lv%sm%sv%is_global()) then
if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then
lv%parms%sweeps_pre = 1
lv%parms%sweeps_post = 1
if (me == 0) then
write(debug_unit,*)
if (present(ilv)) then
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
& '" at level ',ilv
write(debug_unit,*) ' is configured as a global solver '
else
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
& '" is configured as a global solver '
end if
write(debug_unit,*) ' Pre and post sweeps at this level reset to 1'
end if
if (info /=0 ) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Smoother bld error')
goto 9999
end if
if (lv%sm%sv%is_global()) then
if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then
lv%parms%sweeps_pre = 1
lv%parms%sweeps_post = 1
if (me == 0) then
write(debug_unit,*)
if (present(ilv)) then
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
& '" at level ',ilv
write(debug_unit,*) ' is configured as a global solver '
else
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
& '" is configured as a global solver '
end if
write(debug_unit,*) ' Pre and post sweeps at this level reset to 1'
end if
end if
end if
amgprec/impl/level/amg_z_base_onelev_cnv.f90
+1 -1
View File
@@ -62,6 +62,6 @@ subroutine amg_z_base_onelev_cnv(lv,info,amold,vmold,imold)
& call lv%ac%cscnv(info,mold=amold)
if (info == psb_success_ .and. lv%desc_ac%is_ok() &
& .and. present(imold)) call lv%desc_ac%cnv(imold)
if (info == psb_success_) call lv%linmap%cnv(info,mold=amold,imold=imold)
if (info == psb_success_) call lv%map%cnv(info,mold=amold,imold=imold)
end if
end subroutine amg_z_base_onelev_cnv
amgprec/impl/level/amg_z_base_onelev_csetc.F90
+44 -56
View File
@@ -1,15 +1,15 @@
!
!
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
!
! (C) Copyright 2020
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
!
! (C) Copyright 2020
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
@@ -21,7 +21,7 @@
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
@@ -33,10 +33,10 @@
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
!
!
subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
use psb_base_mod
use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_csetc
use amg_z_base_aggregator_mod
@@ -49,9 +49,6 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
use amg_z_ilu_solver
use amg_z_id_solver
use amg_z_gs_solver
use amg_z_ainv_solver
use amg_z_invk_solver
use amg_z_invt_solver
#if defined(HAVE_UMF_)
use amg_z_umf_solver
#endif
@@ -68,16 +65,16 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
Implicit None
! Arguments
class(amg_z_onelev_type), intent(inout) :: lv
character(len=*), intent(in) :: what
class(amg_z_onelev_type), intent(inout) :: lv
character(len=*), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
integer(psb_ipk_), intent(in), optional :: idx
! Local
! Local
integer(psb_ipk_) :: ipos_, err_act
character(len=20) :: name='z_base_onelev_csetc'
integer(psb_ipk_) :: ival
integer(psb_ipk_) :: ival
type(amg_z_base_smoother_type) :: amg_z_base_smoother_mold
type(amg_z_jac_smoother_type) :: amg_z_jac_smoother_mold
type(amg_z_l1_jac_smoother_type) :: amg_z_l1_jac_smoother_mold
@@ -88,9 +85,6 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
type(amg_z_id_solver_type) :: amg_z_id_solver_mold
type(amg_z_gs_solver_type) :: amg_z_gs_solver_mold
type(amg_z_bwgs_solver_type) :: amg_z_bwgs_solver_mold
type(amg_z_ainv_solver_type) :: amg_z_ainv_solver_mold
type(amg_z_invk_solver_type) :: amg_z_invk_solver_mold
type(amg_z_invt_solver_type) :: amg_z_invt_solver_mold
#if defined(HAVE_UMF_)
type(amg_z_umf_solver_type) :: amg_z_umf_solver_mold
#endif
@@ -103,7 +97,7 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
#if defined(HAVE_MUMPS_)
type(amg_z_mumps_solver_type) :: amg_z_mumps_solver_mold
#endif
call psb_erractionsave(err_act)
@@ -124,14 +118,14 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
else
ipos_ = amg_smooth_both_
end if
select case (psb_toupper(trim(what)))
case ('SMOOTHER_TYPE')
select case (psb_toupper(trim(val)))
case ('NOPREC','NONE')
call lv%set(amg_z_base_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(amg_z_id_solver_mold,info,pos=pos)
case ('JAC','JACOBI')
call lv%set(amg_z_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(amg_z_diag_solver_mold,info,pos=pos)
@@ -139,11 +133,11 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
case ('L1-JACOBI')
call lv%set(amg_z_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(amg_z_l1_diag_solver_mold,info,pos=pos)
case ('BJAC')
call lv%set(amg_z_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(amg_z_ilu_solver_mold,info,pos=pos)
case ('L1-BJAC')
call lv%set(amg_z_l1_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(amg_z_ilu_solver_mold,info,pos=pos)
@@ -172,65 +166,59 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
case ('L1-BWGS')
call lv%set(amg_z_l1_jac_smoother_mold,info,pos='pre')
if (info == 0) call lv%set(amg_z_bwgs_solver_mold,info,pos='pre')
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
case ('L1-FBGS')
call lv%set(amg_z_l1_jac_smoother_mold,info,pos='pre')
if (info == 0) call lv%set(amg_z_gs_solver_mold,info,pos='pre')
call lv%set(amg_z_l1_jac_smoother_mold,info,pos='post')
if (info == 0) call lv%set(amg_z_bwgs_solver_mold,info,pos='post')
case default
!
! Do nothing and hope for the best :)
! Do nothing and hope for the best :)
!
end select
if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then
if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then
if (allocated(lv%sm)) call lv%sm%default()
end if
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then
if (allocated(lv%sm2a)) call lv%sm2a%default()
end if
case('SUB_SOLVE')
select case (psb_toupper(trim(val)))
case ('NONE','NOPREC','FACT_NONE')
call lv%set(amg_z_id_solver_mold,info,pos=pos)
case ('DIAG')
call lv%set(amg_z_diag_solver_mold,info,pos=pos)
case ('L1-DIAG')
call lv%set(amg_z_l1_diag_solver_mold,info,pos=pos)
case ('GS','FGS','FWGS')
call lv%set(amg_z_gs_solver_mold,info,pos=pos)
case ('BGS','BWGS')
call lv%set(amg_z_bwgs_solver_mold,info,pos=pos)
case ('AINV')
call lv%set(amg_z_ainv_solver_mold,info,pos=pos)
case ('INVK')
call lv%set(amg_z_invk_solver_mold,info,pos=pos)
case ('INVT')
call lv%set(amg_z_invt_solver_mold,info,pos=pos)
case ('ILU','ILUT','MILU')
call lv%set(amg_z_ilu_solver_mold,info,pos=pos)
if (info == 0) then
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
call lv%sm%sv%set('SUB_SOLVE',val,info)
end if
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
end if
end if
#ifdef HAVE_SLU_
case ('SLU')
case ('SLU')
call lv%set(amg_z_slu_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_MUMPS_
case ('MUMPS')
case ('MUMPS')
call lv%set(amg_z_mumps_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_SLUDIST_
@@ -243,10 +231,10 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
#endif
case default
!
! Do nothing and hope for the best :)
! Do nothing and hope for the best :)
!
end select
case ('ML_CYCLE')
lv%parms%ml_cycle = amg_stringval(val)
@@ -261,7 +249,7 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
return
end if
end if
select case(ival)
case(amg_dec_aggr_)
allocate(amg_z_dec_aggregator_type :: lv%aggr, stat=info)
@@ -271,7 +259,7 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
info = psb_err_internal_error_
end select
if (info == psb_success_) call lv%aggr%default()
case ('AGGR_ORD')
lv%parms%aggr_ord = amg_stringval(val)
@@ -298,13 +286,13 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
lv%parms%coarse_solve = amg_stringval(val)
case default
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
if (allocated(lv%sm)) then
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info,idx=idx)
end if
end if
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
if (allocated(lv%sm2a)) then
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info,idx=idx)
end if
end if
amgprec/impl/level/amg_z_base_onelev_descr.f90
+3 -3
View File
@@ -89,11 +89,11 @@ subroutine amg_z_base_onelev_descr(lv,il,nl,ilmin,info,iout)
call lv%parms%descr(iout_,info,coarse=coarse)
if (nl > 1) then
if (allocated(lv%linmap%naggr)) then
if (allocated(lv%map%naggr)) then
write(iout_,*) ' Coarse Matrix: Global size: ', &
& sum((1_psb_lpk_*lv%linmap%naggr(:))),' Nonzeros: ',lv%ac_nz_tot
& sum((1_psb_lpk_*lv%map%naggr(:))),' Nonzeros: ',lv%ac_nz_tot
write(iout_,*) ' Local matrix sizes: ', &
& lv%linmap%naggr(:)
& lv%map%naggr(:)
write(iout_,*) ' Aggregation ratio: ', &
& lv%szratio
end if
amgprec/impl/level/amg_z_base_onelev_dump.f90
+7 -7
View File
@@ -108,17 +108,17 @@ subroutine amg_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
call lv%ac%print(fname,head=head,iv=ivr)
end if
if (rp_) then
ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.)
ivc = lv%linmap%p_desc_V%get_global_indices(owned=.false.)
ivr = lv%map%p_desc_U%get_global_indices(owned=.false.)
ivc = lv%map%p_desc_V%get_global_indices(owned=.false.)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
call lv%linmap%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr)
call lv%map%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
call lv%linmap%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc)
call lv%map%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc)
end if
if (tprol_) then
! Tentative prolongator is stored with column indices already
! in global numbering, so only IVR is needed.
ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.)
ivr = lv%map%p_desc_U%get_global_indices(owned=.false.)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
!
! This is not implemented yet.
@@ -133,9 +133,9 @@ subroutine amg_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
end if
if (rp_) then
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
call lv%linmap%mat_U2V%print(fname,head=head)
call lv%map%mat_U2V%print(fname,head=head)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
call lv%linmap%mat_V2U%print(fname,head=head)
call lv%map%mat_V2U%print(fname,head=head)
end if
if (tprol_) then
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
amgprec/impl/level/amg_z_base_onelev_free.f90
+1 -1
View File
@@ -63,7 +63,7 @@ subroutine amg_z_base_onelev_free(lv,info)
call lv%ac%free()
if (lv%desc_ac%is_ok()) &
& call lv%desc_ac%free(info)
call lv%linmap%free(info)
call lv%map%free(info)
! This is a pointer to something else, must not free it here.
nullify(lv%base_a)
amgprec/impl/level/amg_z_base_onelev_map_prol.F90
-135
View File
@@ -1,135 +0,0 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
!
! (C) Copyright 2020
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
subroutine amg_z_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
use psb_base_mod
use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_map_prol_v
implicit none
class(amg_z_onelev_type), target, intent(inout) :: lv
complex(psb_dpk_), intent(in) :: alpha, beta
type(psb_z_vect_type), intent(inout) :: vect_u, vect_v
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional :: work(:)
type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty
!!$ write(0,*) 'New map_prol',lv%remap_data%ac_pre_remap%is_asb()
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
!!$ write(0,*) 'Remap handling '
block
type(psb_ctxt_type) :: ctxt, nctxt
integer(psb_ipk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp
integer(psb_ipk_) :: me, np, rme, rnp
complex(psb_dpk_), allocatable :: rsnd(:), rrcv(:)
type(psb_z_vect_type) :: tv
ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
call psb_info(ctxt,me,np)
!!$ write(0,*) 'Old context ',me,np,psb_errstatus_fatal()
nctxt = lv%desc_ac%get_ctxt()
call psb_info(nctxt,rme,rnp)
!!$ write(0,*) 'New context ',rme,rnp,psb_errstatus_fatal()
idest = lv%remap_data%idest
associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
!!$ write(0,*) 'Should apply maps, then receive data from ',idest,' to ',me,psb_errstatus_fatal()
nsrc = size(isrc)
nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
nrc = lv%remap_data%desc_ac_pre_remap%get_local_cols()
if (rme >=0) then
allocate(rrcv(sum(nrsrc)))
rrcv = vect_v%get_vect()
!!$ write(0,*) me,rme,' Size check ',size(rrcv),lv%desc_ac%get_local_rows(),psb_errstatus_fatal()
kp = 0
do i = 1,size(isrc)
ip = isrc(i)
nrl = nrsrc(i)
!!$ write(0,*) me,' Sending to ',ip,nrl,kp+1,kp+nrl
call psb_snd(ctxt,rrcv(kp+1:kp+nrl),ip)
kp = kp + nrl
end do
end if
nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
!!$ write(0,*) me, ' Allocated ',nrl,info,psb_errstatus_fatal()
call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info)
!!$ write(0,*) me,' Size of TV ',nrl,tv%get_nrows(),info
!!$ write(0,*) me,' Receiving from ',idest,nrl,psb_errstatus_fatal()
call psb_realloc(nrc,rsnd,info)
call psb_rcv(ctxt,rsnd(1:nrl),idest)
call tv%set_vect(rsnd)
call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,&
& work=work,vtx=vtx,vty=vty)
end associate
!!$ write(0,*) me, ' Prolongator with remap done '
!!$ flush(0)
!!$ call psb_barrier(ctxt)
end block
else
! Default transfer
call lv%linmap%map_V2U(alpha,vect_v,beta,vect_u,info,&
& work=work,vtx=vtx,vty=vty)
end if
end subroutine amg_z_base_onelev_map_prol_v
subroutine amg_z_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
use psb_base_mod
use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_map_prol_a
implicit none
class(amg_z_onelev_type), target, intent(inout) :: lv
complex(psb_dpk_), intent(in) :: alpha, beta
complex(psb_dpk_), intent(inout) :: u(:)
complex(psb_dpk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional :: work(:)
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
write(0,*) 'Remap handling not implemented yet '
else
! Default transfer
call lv%linmap%map_V2U(alpha,v,beta,u,info,&
& work=work)
end if
end subroutine amg_z_base_onelev_map_prol_a
amgprec/impl/level/amg_z_base_onelev_map_rstr.F90
-129
View File
@@ -1,129 +0,0 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
!
! (C) Copyright 2020
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
subroutine amg_z_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
& work,vtx,vty)
use psb_base_mod
use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_map_rstr_v
implicit none
class(amg_z_onelev_type), target, intent(inout) :: lv
complex(psb_dpk_), intent(in) :: alpha, beta
type(psb_z_vect_type), intent(inout) :: vect_u, vect_v
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional :: work(:)
type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty
!!$ write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
!!$ write(0,*) 'Remap handling not implemented yet '
block
type(psb_ctxt_type) :: ctxt, nctxt
integer(psb_ipk_) :: i,j,ip, idest, nsrc, nrl, kp
integer(psb_ipk_) :: me, np, rme, rnp
complex(psb_dpk_), allocatable :: rsnd(:), rrcv(:)
type(psb_z_vect_type) :: tv
ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
call psb_info(ctxt,me,np)
nctxt = lv%desc_ac%get_ctxt()
call psb_info(nctxt,rme,rnp)
!!$ write(0,*) 'New context ',rme,rnp
idest = lv%remap_data%idest
associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
!!$ write(0,*) 'Should apply maps, then send data from ',me,' to ',idest
!!$ if (rme >= 0) write(0,*) rme, ' Receiving data from ',isrc(:)
nsrc = size(isrc)
nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info)
!!$ write(0,*) me,' Size of TV ',tv%get_nrows()
call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,&
& work=work,vtx=vtx,vty=vty)
rsnd = tv%get_vect()
call psb_snd(ctxt,rsnd(1:nrl),idest)
if (rme >=0) then
allocate(rrcv(sum(nrsrc)))
!!$ write(0,*) me,rme,' Size check ',size(rrcv)!,lv%desc_ac%get_local_rows()
kp = 0
do i = 1,size(isrc)
ip = isrc(i)
nrl = nrsrc(i)
!!$ write(0,*) me,' Receiving from ',ip,nrl,kp+1,kp+nrl,size(rrcv)
call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip)
kp = kp + nrl
end do
call vect_v%set_vect(rrcv)
end if
end associate
!!$ write(0,*) me, ' Restrictor with remap done '
end block
else
! Default transfer
call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,&
& work=work,vtx=vtx,vty=vty)
end if
end subroutine amg_z_base_onelev_map_rstr_v
subroutine amg_z_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
use psb_base_mod
use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_map_rstr_a
implicit none
class(amg_z_onelev_type), target, intent(inout) :: lv
complex(psb_dpk_), intent(in) :: alpha, beta
complex(psb_dpk_), intent(inout) :: u(:)
complex(psb_dpk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional :: work(:)
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
write(0,*) 'Remap handling not implemented yet '
else
! Default transfer
call lv%linmap%map_U2V(alpha,u,beta,v,info,&
& work=work)
end if
end subroutine amg_z_base_onelev_map_rstr_a
amgprec/impl/level/amg_z_base_onelev_mat_asb.f90
+2 -2
View File
@@ -53,7 +53,7 @@
! 2. Call amg_Xaggrmat_asb to compute prolongator/restrictor/AC
! 3. According to the choice of DIST/REPL for AC, build a descriptor DESC_AC,
! and adjust the column numbering of AC/OP_PROL/OP_RESTR
! 4. Pack restrictor and prolongator into p%linmap
! 4. Pack restrictor and prolongator into p%map
! 5. Fix base_a and base_desc pointers.
!
!
@@ -158,7 +158,7 @@ subroutine amg_z_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call lv%aggr%bld_map(desc_a, lv%desc_ac,&
& ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
& ilaggr,nlaggr,op_restr,op_prol,lv%map,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld')
goto 9999
amgprec/impl/solver/Makefile
+5 -1
View File
@@ -300,7 +300,11 @@ amg_z_invk_solver_check.o \
amg_z_invk_solver_clone.o \
amg_z_invk_solver_cseti.o \
amg_z_invk_solver_descr.o \
amg_z_invk_solver_seti.o
amg_z_invk_solver_seti.o \
amg_d_rkr_solver_impl.o \
amg_s_rkr_solver_impl.o \
amg_c_rkr_solver_impl.o \
amg_z_rkr_solver_impl.o
LIBNAME=libamg_prec.a
amgprec/impl/solver/amg_c_ainv_solver_descr.f90
+1
View File
@@ -48,6 +48,7 @@ subroutine amg_c_ainv_solver_descr(sv,info,iout,coarse)
! Local variables
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ictxt, me, np
character(len=20), parameter :: name='amg_c_ainv_solver_descr'
integer(psb_ipk_) :: iout_
amgprec/impl/solver/amg_c_invk_solver_descr.f90
+2
View File
@@ -48,6 +48,8 @@ subroutine amg_c_invk_solver_descr(sv,info,iout,coarse)
! Local variables
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: me, np
type(psb_ctxt_type) :: ctxt
character(len=20), parameter :: name='amg_c_invk_solver_descr'
integer(psb_ipk_) :: iout_
amgprec/impl/solver/amg_c_invt_solver_descr.f90
+1
View File
@@ -48,6 +48,7 @@ subroutine amg_c_invt_solver_descr(sv,info,iout,coarse)
! Local variables
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ictxt, me, np
character(len=20), parameter :: name='amg_c_invt_solver_descr'
integer(psb_ipk_) :: iout_
amgprec/impl/solver/amg_d_ainv_solver_descr.f90
+1
View File
@@ -48,6 +48,7 @@ subroutine amg_d_ainv_solver_descr(sv,info,iout,coarse)
! Local variables
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ictxt, me, np
character(len=20), parameter :: name='amg_d_ainv_solver_descr'
integer(psb_ipk_) :: iout_
amgprec/impl/solver/amg_d_invk_solver_descr.f90
+2
View File
@@ -48,6 +48,8 @@ subroutine amg_d_invk_solver_descr(sv,info,iout,coarse)
! Local variables
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: me, np
type(psb_ctxt_type) :: ctxt
character(len=20), parameter :: name='amg_d_invk_solver_descr'
integer(psb_ipk_) :: iout_
amgprec/impl/solver/amg_d_invt_solver_descr.f90
+1
View File
@@ -48,6 +48,7 @@ subroutine amg_d_invt_solver_descr(sv,info,iout,coarse)
! Local variables
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ictxt, me, np
character(len=20), parameter :: name='amg_d_invt_solver_descr'
integer(psb_ipk_) :: iout_
amgprec/impl/solver/amg_s_ainv_solver_descr.f90
+1
View File
@@ -48,6 +48,7 @@ subroutine amg_s_ainv_solver_descr(sv,info,iout,coarse)
! Local variables
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ictxt, me, np
character(len=20), parameter :: name='amg_s_ainv_solver_descr'
integer(psb_ipk_) :: iout_
amgprec/impl/solver/amg_s_invk_solver_descr.f90
+2
View File
@@ -48,6 +48,8 @@ subroutine amg_s_invk_solver_descr(sv,info,iout,coarse)
! Local variables
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: me, np
type(psb_ctxt_type) :: ctxt
character(len=20), parameter :: name='amg_s_invk_solver_descr'
integer(psb_ipk_) :: iout_
amgprec/impl/solver/amg_s_invt_solver_descr.f90
+1
View File
@@ -48,6 +48,7 @@ subroutine amg_s_invt_solver_descr(sv,info,iout,coarse)
! Local variables
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ictxt, me, np
character(len=20), parameter :: name='amg_s_invt_solver_descr'
integer(psb_ipk_) :: iout_
amgprec/impl/solver/amg_z_ainv_solver_descr.f90
+1
View File
@@ -48,6 +48,7 @@ subroutine amg_z_ainv_solver_descr(sv,info,iout,coarse)
! Local variables
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ictxt, me, np
character(len=20), parameter :: name='amg_z_ainv_solver_descr'
integer(psb_ipk_) :: iout_
amgprec/impl/solver/amg_z_invk_solver_descr.f90
+2
View File
@@ -48,6 +48,8 @@ subroutine amg_z_invk_solver_descr(sv,info,iout,coarse)
! Local variables
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: me, np
type(psb_ctxt_type) :: ctxt
character(len=20), parameter :: name='amg_z_invk_solver_descr'
integer(psb_ipk_) :: iout_
amgprec/impl/solver/amg_z_invt_solver_descr.f90
+1
View File
@@ -48,6 +48,7 @@ subroutine amg_z_invt_solver_descr(sv,info,iout,coarse)
! Local variables
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ictxt, me, np
character(len=20), parameter :: name='amg_z_invt_solver_descr'
integer(psb_ipk_) :: iout_
tests/pdegen/Makefile
+1 -1
View File
@@ -43,7 +43,7 @@ check: all
clean:
/bin/rm -f data_input.o *.o *$(.mod)\
/bin/rm -f data_input.o amg_d_pde3d.o amg_s_pde3d.o amg_d_pde2d.o amg_s_pde2d.o *$(.mod)\
$(EXEDIR)/mld_d_pde3d $(EXEDIR)/mld_s_pde3d $(EXEDIR)/mld_d_pde2d $(EXEDIR)/mld_s_pde2d
verycleanlib:
tests/pdegen/amg_d_pde2d.f90
+119 -17
View File
@@ -73,6 +73,10 @@ program amg_d_pde2d
use amg_d_pde2d_exp_mod
use amg_d_pde2d_box_mod
use amg_d_genpde_mod
use amg_ainv_mod
use amg_d_ilu_solver
use amg_d_rkr_solver
implicit none
! input parameters
@@ -112,6 +116,10 @@ program amg_d_pde2d
type(solverdata) :: s_choice
! preconditioner data
type(amg_d_invt_solver_type) :: invtsv
type(amg_d_invk_solver_type) :: invksv
type(amg_d_ainv_solver_type) :: ainvsv
type(amg_d_rkr_solver_type) :: rkr_slv
type precdata
! preconditioner type
@@ -168,10 +176,22 @@ program amg_d_pde2d
! (repl. mat.)
character(len=16) :: csbsolve ! coarsest-lev local subsolver: ILU, ILUT,
! MILU, UMF, MUMPS, SLU
character(len=16) :: cvariant ! AINV variant: LLK, etc
character(len=16) :: ckryl ! Krylov method for RKR, ignored otherwise
! MILU, UMF, MUMPS, SLU
integer(psb_ipk_) :: cfill ! fill-in for incomplete LU factorization
real(psb_dpk_) :: cthres ! threshold for ILUT factorization
integer(psb_ipk_) :: cinvfill ! Inverse fill-in for INVK
integer(psb_ipk_) :: cjswp ! sweeps for GS or JAC coarsest-lev subsolver
real(psb_dpk_) :: cthres ! threshold for ILUT factorization
integer(psb_ipk_) :: crkiter ! Max iterations for RKR, ignored otherwise
real(psb_dpk_) :: crkeps ! eps for RKR, ignored otherwise
integer(psb_ipk_) :: crktrace ! ITRACE for RKR, ignored otherwise
character(len=16) :: checkres ! Check the BJAC residual
character(len=16) :: printres ! Print the BJAC residual
integer(psb_ipk_) :: checkiter ! ITRACE for residual check
integer(psb_ipk_) :: printiter ! ITRACE for residual print
real(psb_dpk_) :: tol ! Tolerance for exit from BJAC
logical :: dump ! dump on file
end type precdata
type(precdata) :: p_choice
@@ -306,11 +326,11 @@ program amg_d_pde2d
call prec%set('sub_prol', p_choice%prol, info)
select case(trim(psb_toupper(p_choice%solve)))
case('INVK')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set(invksv, info)
case('INVT')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set(invtsv, info)
case('AINV')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set(ainvsv, info)
call prec%set('ainv_alg', p_choice%variant, info)
case default
call prec%set('sub_solve', p_choice%solve, info)
@@ -333,12 +353,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(invksv, info, pos='post')
case('INVT')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set(invtsv, info, pos='post')
case('AINV')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set('ainv_alg', p_choice%variant, info)
call prec%set(ainvsv, info, pos='post')
call prec%set('ainv_alg', p_choice%variant2, info, pos='post')
case default
call prec%set('sub_solve', p_choice%solve2, info, pos='post')
end select
@@ -349,13 +369,72 @@ program amg_d_pde2d
end select
end if
call prec%set('coarse_solve', p_choice%csolve, info)
if (psb_toupper(p_choice%csolve) == 'BJAC') &
& call prec%set('coarse_subsolve', p_choice%csbsolve, info)
call prec%set('coarse_mat', p_choice%cmat, info)
call prec%set('coarse_fillin', p_choice%cfill, info)
call prec%set('coarse_iluthrs', p_choice%cthres, info)
call prec%set('coarse_sweeps', p_choice%cjswp, info)
nlv = size(prec%precv)
if (psb_toupper(p_choice%csolve) == 'RKR') then
call prec%set('coarse_solve', 'BJAC', info)
call prec%set(rkr_slv,info,ilev=nlv)
call prec%set('rkr_method',p_choice%ckryl,info,ilev=nlv)
call prec%set('rkr_kprec', 'BJAC' , info,ilev=nlv)
call prec%set('rkr_global', 'global' , info,ilev=nlv)
call prec%set('rkr_eps', p_choice%crkeps,info,ilev=nlv)
call prec%set('rkr_itmax', p_choice%crkiter,info,ilev=nlv)
call prec%set('rkr_fillin', p_choice%cfill,info,ilev=nlv)
call prec%set('coarse_mat', p_choice%cmat, info)
call prec%set('coarse_sweeps', p_choice%cjswp, info)
call prec%set('rkr_itrace', p_choice%crktrace, info,ilev=nlv)
else
call prec%set('coarse_solve', p_choice%csolve, info)
select case(psb_toupper(trim(p_choice%csolve)))
case('BJAC','L1-BJAC')
select case(trim(psb_toupper(p_choice%csbsolve)))
case ('MUMPS')
call prec%set('MUMPS_LOC_GLOB','LOCAL_SOLVER',info)
!
! Experimental: enable Block Low-Rank
!
call prec%set('MUMPS_IPAR_ENTRY',ione,info,idx=35_psb_ipk_)
call prec%set('MUMPS_RPAR_ENTRY',4.0_psb_dpk_,info,idx=7_psb_ipk_)
case('RKR')
call prec%set(rkr_slv,info,ilev=nlv)
call prec%set('rkr_method',p_choice%ckryl,info,ilev=nlv)
call prec%set('rkr_global', 'local' , info,ilev=nlv)
call prec%set('rkr_eps', p_choice%crkeps,info,ilev=nlv)
call prec%set('rkr_itmax', p_choice%crkiter,info,ilev=nlv)
call prec%set('rkr_itrace', p_choice%crktrace, info,ilev=nlv)
call prec%set('rkr_fillin', p_choice%cfill,info,ilev=nlv)
case('INVK')
call prec%set(invksv, info,ilev=nlv)
case('INVT')
call prec%set(invtsv, info,ilev=nlv)
case('AINV')
call prec%set(ainvsv, info,ilev=nlv)
call prec%set('ainv_alg', p_choice%cvariant, info, ilev=nlv)
case default
call prec%set('coarse_subsolve', p_choice%csbsolve, info)
end select
!
! Experimental: Use residual check on coarse BJAC solver
!
call prec%set('SMOOTHER_STOP', p_choice%checkres, info)
call prec%set('SMOOTHER_TRACE', p_choice%printres, info)
call prec%set('SMOOTHER_STOPTOL', p_choice%tol, info)
call prec%set('SMOOTHER_ITRACE', p_choice%printiter, info)
call prec%set('SMOOTHER_RESIDUAL',p_choice%checkiter, info)
case('L1-GS')
call prec%set('SMOOTHER_STOP', p_choice%checkres, info)
call prec%set('SMOOTHER_TRACE', p_choice%printres, info)
call prec%set('SMOOTHER_STOPTOL', p_choice%tol, info)
call prec%set('SMOOTHER_ITRACE', p_choice%printiter, info)
call prec%set('SMOOTHER_RESIDUAL',p_choice%checkiter, info)
case default
! Do nothing, should have been already handled
end select
call prec%set('coarse_mat', p_choice%cmat, info)
call prec%set('coarse_fillin', p_choice%cfill, info)
call prec%set('inv_fillin', p_choice%cinvfill, info, ilev=nlv)
call prec%set('coarse_iluthrs', p_choice%cthres, info)
call prec%set('coarse_sweeps', p_choice%cjswp, info)
end if
end select
@@ -569,10 +648,21 @@ contains
! coasest-level solver
call read_data(prec%csolve,inp_unit) ! coarsest-lev solver
call read_data(prec%csbsolve,inp_unit) ! coarsest-lev subsolver
call read_data(prec%cvariant,inp_unit) ! AINV variant
call read_data(prec%ckryl,inp_unit) ! RKR Krylov method choice
call read_data(prec%cmat,inp_unit) ! coarsest mat layout
call read_data(prec%cfill,inp_unit) ! fill-in for incompl LU
call read_data(prec%cinvfill,inp_unit) ! Inverse fill-in for INVK
call read_data(prec%cthres,inp_unit) ! Threshold for ILUT
call read_data(prec%cjswp,inp_unit) ! sweeps for GS/JAC subsolver
call read_data(prec%crkiter,inp_unit) ! Max iterations for RKR, ignored otherwise
call read_data(prec%crkeps,inp_unit) ! eps for RKR, ignored otherwise
call read_data(prec%crktrace,inp_unit) ! itrace for RKR, ignored otherwise
call read_data(prec%checkres,inp_unit) ! Check the BJAC residual
call read_data(prec%printres,inp_unit) ! Print the BJAC residual
call read_data(prec%checkiter,inp_unit) ! ITRACE for residual check
call read_data(prec%printiter,inp_unit) ! ITRACE for residual print
call read_data(prec%tol,inp_unit) ! Tolerance for exit from BJAC
if (inp_unit /= psb_inp_unit) then
close(inp_unit)
end if
@@ -632,14 +722,26 @@ contains
end if
call psb_bcast(ctxt,prec%athres)
! broadcast coasest-level solver
call psb_bcast(ctxt,prec%csize)
call psb_bcast(ctxt,prec%cmat)
call psb_bcast(ctxt,prec%csolve)
call psb_bcast(ctxt,prec%csbsolve)
call psb_bcast(ctxt,prec%cvariant)
call psb_bcast(ctxt,prec%ckryl)
call psb_bcast(ctxt,prec%cfill)
call psb_bcast(ctxt,prec%cinvfill)
call psb_bcast(ctxt,prec%cthres)
call psb_bcast(ctxt,prec%cjswp)
call psb_bcast(ctxt,prec%crkiter)
call psb_bcast(ctxt,prec%crkeps)
call psb_bcast(ctxt,prec%crktrace)
call psb_bcast(ctxt,prec%checkres)
call psb_bcast(ctxt,prec%printres)
call psb_bcast(ctxt,prec%checkiter)
call psb_bcast(ctxt,prec%printiter)
call psb_bcast(ctxt,prec%tol)
call psb_bcast(ctxt,prec%dump)
end subroutine get_parms
tests/pdegen/amg_d_pde3d.f90
+121 -16
View File
@@ -74,6 +74,10 @@ program amg_d_pde3d
use amg_d_pde3d_exp_mod
use amg_d_pde3d_gauss_mod
use amg_d_genpde_mod
use amg_ainv_mod
use amg_d_ilu_solver
use amg_d_rkr_solver
implicit none
! input parameters
@@ -113,6 +117,10 @@ program amg_d_pde3d
type(solverdata) :: s_choice
! preconditioner data
type(amg_d_invt_solver_type) :: invtsv
type(amg_d_invk_solver_type) :: invksv
type(amg_d_ainv_solver_type) :: ainvsv
type(amg_d_rkr_solver_type) :: rkr_slv
type precdata
! preconditioner type
@@ -169,10 +177,22 @@ program amg_d_pde3d
! (repl. mat.)
character(len=16) :: csbsolve ! coarsest-lev local subsolver: ILU, ILUT,
! MILU, UMF, MUMPS, SLU
character(len=16) :: cvariant ! AINV variant: LLK, etc
character(len=16) :: ckryl ! Krylov method for RKR, ignored otherwise
! MILU, UMF, MUMPS, SLU
integer(psb_ipk_) :: cfill ! fill-in for incomplete LU factorization
real(psb_dpk_) :: cthres ! threshold for ILUT factorization
integer(psb_ipk_) :: cinvfill ! Inverse fill-in for INVK
integer(psb_ipk_) :: cjswp ! sweeps for GS or JAC coarsest-lev subsolver
real(psb_dpk_) :: cthres ! threshold for ILUT factorization
integer(psb_ipk_) :: crkiter ! Max iterations for RKR, ignored otherwise
real(psb_dpk_) :: crkeps ! eps for RKR, ignored otherwise
integer(psb_ipk_) :: crktrace ! ITRACE for RKR, ignored otherwise
character(len=16) :: checkres ! Check the BJAC residual
character(len=16) :: printres ! Print the BJAC residual
integer(psb_ipk_) :: checkiter ! ITRACE for residual check
integer(psb_ipk_) :: printiter ! ITRACE for residual print
real(psb_dpk_) :: tol ! Tolerance for exit from BJAC
logical :: dump ! dump on file
end type precdata
type(precdata) :: p_choice
@@ -310,11 +330,11 @@ program amg_d_pde3d
call prec%set('sub_prol', p_choice%prol, info)
select case(trim(psb_toupper(p_choice%solve)))
case('INVK')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set(invksv, info)
case('INVT')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set(invtsv, info)
case('AINV')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set(ainvsv, info)
call prec%set('ainv_alg', p_choice%variant, info)
case default
call prec%set('sub_solve', p_choice%solve, info)
@@ -337,12 +357,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(invksv, info, pos='post')
case('INVT')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set(invtsv, info, pos='post')
case('AINV')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set('ainv_alg', p_choice%variant, info)
call prec%set(ainvsv, info, pos='post')
call prec%set('ainv_alg', p_choice%variant2, info, pos='post')
case default
call prec%set('sub_solve', p_choice%solve2, info, pos='post')
end select
@@ -353,13 +373,72 @@ program amg_d_pde3d
end select
end if
call prec%set('coarse_solve', p_choice%csolve, info)
if (psb_toupper(p_choice%csolve) == 'BJAC') &
& call prec%set('coarse_subsolve', p_choice%csbsolve, info)
call prec%set('coarse_mat', p_choice%cmat, info)
call prec%set('coarse_fillin', p_choice%cfill, info)
call prec%set('coarse_iluthrs', p_choice%cthres, info)
call prec%set('coarse_sweeps', p_choice%cjswp, info)
nlv = size(prec%precv)
if (psb_toupper(p_choice%csolve) == 'RKR') then
call prec%set('coarse_solve', 'BJAC', info)
call prec%set(rkr_slv,info,ilev=nlv)
call prec%set('rkr_method',p_choice%ckryl,info,ilev=nlv)
call prec%set('rkr_kprec', 'BJAC' , info,ilev=nlv)
call prec%set('rkr_global', 'global' , info,ilev=nlv)
call prec%set('rkr_eps', p_choice%crkeps,info,ilev=nlv)
call prec%set('rkr_itmax', p_choice%crkiter,info,ilev=nlv)
call prec%set('rkr_fillin', p_choice%cfill,info,ilev=nlv)
call prec%set('coarse_mat', p_choice%cmat, info)
call prec%set('coarse_sweeps', p_choice%cjswp, info)
call prec%set('rkr_itrace', p_choice%crktrace, info,ilev=nlv)
else
call prec%set('coarse_solve', p_choice%csolve, info)
select case(psb_toupper(trim(p_choice%csolve)))
case('BJAC','L1-BJAC')
select case(trim(psb_toupper(p_choice%csbsolve)))
case ('MUMPS')
call prec%set('MUMPS_LOC_GLOB','LOCAL_SOLVER',info)
!
! Experimental: enable Block Low-Rank
!
call prec%set('MUMPS_IPAR_ENTRY',ione,info,idx=35_psb_ipk_)
call prec%set('MUMPS_RPAR_ENTRY',4.0_psb_dpk_,info,idx=7_psb_ipk_)
case('RKR')
call prec%set(rkr_slv,info,ilev=nlv)
call prec%set('rkr_method',p_choice%ckryl,info,ilev=nlv)
call prec%set('rkr_global', 'local' , info,ilev=nlv)
call prec%set('rkr_eps', p_choice%crkeps,info,ilev=nlv)
call prec%set('rkr_itmax', p_choice%crkiter,info,ilev=nlv)
call prec%set('rkr_itrace', p_choice%crktrace, info,ilev=nlv)
call prec%set('rkr_fillin', p_choice%cfill,info,ilev=nlv)
case('INVK')
call prec%set(invksv, info,ilev=nlv)
case('INVT')
call prec%set(invtsv, info,ilev=nlv)
case('AINV')
call prec%set(ainvsv, info,ilev=nlv)
call prec%set('ainv_alg', p_choice%cvariant, info, ilev=nlv)
case default
call prec%set('coarse_subsolve', p_choice%csbsolve, info)
end select
!
! Experimental: Use residual check on coarse BJAC solver
!
call prec%set('SMOOTHER_STOP', p_choice%checkres, info)
call prec%set('SMOOTHER_TRACE', p_choice%printres, info)
call prec%set('SMOOTHER_STOPTOL', p_choice%tol, info)
call prec%set('SMOOTHER_ITRACE', p_choice%printiter, info)
call prec%set('SMOOTHER_RESIDUAL',p_choice%checkiter, info)
case('L1-GS')
call prec%set('SMOOTHER_STOP', p_choice%checkres, info)
call prec%set('SMOOTHER_TRACE', p_choice%printres, info)
call prec%set('SMOOTHER_STOPTOL', p_choice%tol, info)
call prec%set('SMOOTHER_ITRACE', p_choice%printiter, info)
call prec%set('SMOOTHER_RESIDUAL',p_choice%checkiter, info)
case default
! Do nothing, should have been already handled
end select
call prec%set('coarse_mat', p_choice%cmat, info)
call prec%set('coarse_fillin', p_choice%cfill, info)
call prec%set('inv_fillin', p_choice%cinvfill, info, ilev=nlv)
call prec%set('coarse_iluthrs', p_choice%cthres, info)
call prec%set('coarse_sweeps', p_choice%cjswp, info)
end if
end select
@@ -573,10 +652,23 @@ contains
! coasest-level solver
call read_data(prec%csolve,inp_unit) ! coarsest-lev solver
call read_data(prec%csbsolve,inp_unit) ! coarsest-lev subsolver
call read_data(prec%cvariant,inp_unit) ! AINV variant
call read_data(prec%ckryl,inp_unit) ! RKR Krylov method choice
call read_data(prec%cmat,inp_unit) ! coarsest mat layout
call read_data(prec%cfill,inp_unit) ! fill-in for incompl LU
call read_data(prec%cinvfill,inp_unit) ! Inverse fill-in for INVK
call read_data(prec%cthres,inp_unit) ! Threshold for ILUT
call read_data(prec%cjswp,inp_unit) ! sweeps for GS/JAC subsolver
call read_data(prec%crkiter,inp_unit) ! Max iterations for RKR, ignored otherwise
call read_data(prec%crkeps,inp_unit) ! eps for RKR, ignored otherwise
call read_data(prec%crktrace,inp_unit) ! itrace for RKR, ignored otherwise
call read_data(prec%checkres,inp_unit) ! Check the BJAC residual
call read_data(prec%printres,inp_unit) ! Print the BJAC residual
call read_data(prec%checkiter,inp_unit) ! ITRACE for residual check
call read_data(prec%printiter,inp_unit) ! ITRACE for residual print
call read_data(prec%tol,inp_unit) ! Tolerance for exit from BJAC
call read_data(prec%dump,inp_unit) !
if (inp_unit /= psb_inp_unit) then
close(inp_unit)
end if
@@ -636,13 +728,26 @@ contains
end if
call psb_bcast(ctxt,prec%athres)
! broadcast coasest-level solver
call psb_bcast(ctxt,prec%csize)
call psb_bcast(ctxt,prec%cmat)
call psb_bcast(ctxt,prec%csolve)
call psb_bcast(ctxt,prec%csbsolve)
call psb_bcast(ctxt,prec%cvariant)
call psb_bcast(ctxt,prec%ckryl)
call psb_bcast(ctxt,prec%cfill)
call psb_bcast(ctxt,prec%cinvfill)
call psb_bcast(ctxt,prec%cthres)
call psb_bcast(ctxt,prec%cjswp)
call psb_bcast(ctxt,prec%crkiter)
call psb_bcast(ctxt,prec%crkeps)
call psb_bcast(ctxt,prec%crktrace)
call psb_bcast(ctxt,prec%checkres)
call psb_bcast(ctxt,prec%printres)
call psb_bcast(ctxt,prec%checkiter)
call psb_bcast(ctxt,prec%printiter)
call psb_bcast(ctxt,prec%tol)
call psb_bcast(ctxt,prec%dump)
end subroutine get_parms
tests/pdegen/amg_s_pde2d.f90
+119 -17
View File
@@ -73,6 +73,10 @@ program amg_s_pde2d
use amg_s_pde2d_exp_mod
use amg_s_pde2d_box_mod
use amg_s_genpde_mod
use amg_ainv_mod
use amg_s_ilu_solver
use amg_s_rkr_solver
implicit none
! input parameters
@@ -112,6 +116,10 @@ program amg_s_pde2d
type(solverdata) :: s_choice
! preconditioner data
type(amg_s_invt_solver_type) :: invtsv
type(amg_s_invk_solver_type) :: invksv
type(amg_s_ainv_solver_type) :: ainvsv
type(amg_s_rkr_solver_type) :: rkr_slv
type precdata
! preconditioner type
@@ -168,10 +176,22 @@ program amg_s_pde2d
! (repl. mat.)
character(len=16) :: csbsolve ! coarsest-lev local subsolver: ILU, ILUT,
! MILU, UMF, MUMPS, SLU
character(len=16) :: cvariant ! AINV variant: LLK, etc
character(len=16) :: ckryl ! Krylov method for RKR, ignored otherwise
! MILU, UMF, MUMPS, SLU
integer(psb_ipk_) :: cfill ! fill-in for incomplete LU factorization
real(psb_spk_) :: cthres ! threshold for ILUT factorization
integer(psb_ipk_) :: cinvfill ! Inverse fill-in for INVK
integer(psb_ipk_) :: cjswp ! sweeps for GS or JAC coarsest-lev subsolver
real(psb_spk_) :: cthres ! threshold for ILUT factorization
integer(psb_ipk_) :: crkiter ! Max iterations for RKR, ignored otherwise
real(psb_spk_) :: crkeps ! eps for RKR, ignored otherwise
integer(psb_ipk_) :: crktrace ! ITRACE for RKR, ignored otherwise
character(len=16) :: checkres ! Check the BJAC residual
character(len=16) :: printres ! Print the BJAC residual
integer(psb_ipk_) :: checkiter ! ITRACE for residual check
integer(psb_ipk_) :: printiter ! ITRACE for residual print
real(psb_spk_) :: tol ! Tolerance for exit from BJAC
logical :: dump ! dump on file
end type precdata
type(precdata) :: p_choice
@@ -306,11 +326,11 @@ program amg_s_pde2d
call prec%set('sub_prol', p_choice%prol, info)
select case(trim(psb_toupper(p_choice%solve)))
case('INVK')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set(invksv, info)
case('INVT')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set(invtsv, info)
case('AINV')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set(ainvsv, info)
call prec%set('ainv_alg', p_choice%variant, info)
case default
call prec%set('sub_solve', p_choice%solve, info)
@@ -333,12 +353,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(invksv, info, pos='post')
case('INVT')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set(invtsv, info, pos='post')
case('AINV')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set('ainv_alg', p_choice%variant, info)
call prec%set(ainvsv, info, pos='post')
call prec%set('ainv_alg', p_choice%variant2, info, pos='post')
case default
call prec%set('sub_solve', p_choice%solve2, info, pos='post')
end select
@@ -349,13 +369,72 @@ program amg_s_pde2d
end select
end if
call prec%set('coarse_solve', p_choice%csolve, info)
if (psb_toupper(p_choice%csolve) == 'BJAC') &
& call prec%set('coarse_subsolve', p_choice%csbsolve, info)
call prec%set('coarse_mat', p_choice%cmat, info)
call prec%set('coarse_fillin', p_choice%cfill, info)
call prec%set('coarse_iluthrs', p_choice%cthres, info)
call prec%set('coarse_sweeps', p_choice%cjswp, info)
nlv = size(prec%precv)
if (psb_toupper(p_choice%csolve) == 'RKR') then
call prec%set('coarse_solve', 'BJAC', info)
call prec%set(rkr_slv,info,ilev=nlv)
call prec%set('rkr_method',p_choice%ckryl,info,ilev=nlv)
call prec%set('rkr_kprec', 'BJAC' , info,ilev=nlv)
call prec%set('rkr_global', 'global' , info,ilev=nlv)
call prec%set('rkr_eps', p_choice%crkeps,info,ilev=nlv)
call prec%set('rkr_itmax', p_choice%crkiter,info,ilev=nlv)
call prec%set('rkr_fillin', p_choice%cfill,info,ilev=nlv)
call prec%set('coarse_mat', p_choice%cmat, info)
call prec%set('coarse_sweeps', p_choice%cjswp, info)
call prec%set('rkr_itrace', p_choice%crktrace, info,ilev=nlv)
else
call prec%set('coarse_solve', p_choice%csolve, info)
select case(psb_toupper(trim(p_choice%csolve)))
case('BJAC','L1-BJAC')
select case(trim(psb_toupper(p_choice%csbsolve)))
case ('MUMPS')
call prec%set('MUMPS_LOC_GLOB','LOCAL_SOLVER',info)
!
! Experimental: enable Block Low-Rank
!
call prec%set('MUMPS_IPAR_ENTRY',ione,info,idx=35_psb_ipk_)
call prec%set('MUMPS_RPAR_ENTRY',4.0_psb_spk_,info,idx=7_psb_ipk_)
case('RKR')
call prec%set(rkr_slv,info,ilev=nlv)
call prec%set('rkr_method',p_choice%ckryl,info,ilev=nlv)
call prec%set('rkr_global', 'local' , info,ilev=nlv)
call prec%set('rkr_eps', p_choice%crkeps,info,ilev=nlv)
call prec%set('rkr_itmax', p_choice%crkiter,info,ilev=nlv)
call prec%set('rkr_itrace', p_choice%crktrace, info,ilev=nlv)
call prec%set('rkr_fillin', p_choice%cfill,info,ilev=nlv)
case('INVK')
call prec%set(invksv, info,ilev=nlv)
case('INVT')
call prec%set(invtsv, info,ilev=nlv)
case('AINV')
call prec%set(ainvsv, info,ilev=nlv)
call prec%set('ainv_alg', p_choice%cvariant, info, ilev=nlv)
case default
call prec%set('coarse_subsolve', p_choice%csbsolve, info)
end select
!
! Experimental: Use residual check on coarse BJAC solver
!
call prec%set('SMOOTHER_STOP', p_choice%checkres, info)
call prec%set('SMOOTHER_TRACE', p_choice%printres, info)
call prec%set('SMOOTHER_STOPTOL', p_choice%tol, info)
call prec%set('SMOOTHER_ITRACE', p_choice%printiter, info)
call prec%set('SMOOTHER_RESIDUAL',p_choice%checkiter, info)
case('L1-GS')
call prec%set('SMOOTHER_STOP', p_choice%checkres, info)
call prec%set('SMOOTHER_TRACE', p_choice%printres, info)
call prec%set('SMOOTHER_STOPTOL', p_choice%tol, info)
call prec%set('SMOOTHER_ITRACE', p_choice%printiter, info)
call prec%set('SMOOTHER_RESIDUAL',p_choice%checkiter, info)
case default
! Do nothing, should have been already handled
end select
call prec%set('coarse_mat', p_choice%cmat, info)
call prec%set('coarse_fillin', p_choice%cfill, info)
call prec%set('inv_fillin', p_choice%cinvfill, info, ilev=nlv)
call prec%set('coarse_iluthrs', p_choice%cthres, info)
call prec%set('coarse_sweeps', p_choice%cjswp, info)
end if
end select
@@ -569,10 +648,21 @@ contains
! coasest-level solver
call read_data(prec%csolve,inp_unit) ! coarsest-lev solver
call read_data(prec%csbsolve,inp_unit) ! coarsest-lev subsolver
call read_data(prec%cvariant,inp_unit) ! AINV variant
call read_data(prec%ckryl,inp_unit) ! RKR Krylov method choice
call read_data(prec%cmat,inp_unit) ! coarsest mat layout
call read_data(prec%cfill,inp_unit) ! fill-in for incompl LU
call read_data(prec%cinvfill,inp_unit) ! Inverse fill-in for INVK
call read_data(prec%cthres,inp_unit) ! Threshold for ILUT
call read_data(prec%cjswp,inp_unit) ! sweeps for GS/JAC subsolver
call read_data(prec%crkiter,inp_unit) ! Max iterations for RKR, ignored otherwise
call read_data(prec%crkeps,inp_unit) ! eps for RKR, ignored otherwise
call read_data(prec%crktrace,inp_unit) ! itrace for RKR, ignored otherwise
call read_data(prec%checkres,inp_unit) ! Check the BJAC residual
call read_data(prec%printres,inp_unit) ! Print the BJAC residual
call read_data(prec%checkiter,inp_unit) ! ITRACE for residual check
call read_data(prec%printiter,inp_unit) ! ITRACE for residual print
call read_data(prec%tol,inp_unit) ! Tolerance for exit from BJAC
if (inp_unit /= psb_inp_unit) then
close(inp_unit)
end if
@@ -632,14 +722,26 @@ contains
end if
call psb_bcast(ctxt,prec%athres)
! broadcast coasest-level solver
call psb_bcast(ctxt,prec%csize)
call psb_bcast(ctxt,prec%cmat)
call psb_bcast(ctxt,prec%csolve)
call psb_bcast(ctxt,prec%csbsolve)
call psb_bcast(ctxt,prec%cvariant)
call psb_bcast(ctxt,prec%ckryl)
call psb_bcast(ctxt,prec%cfill)
call psb_bcast(ctxt,prec%cinvfill)
call psb_bcast(ctxt,prec%cthres)
call psb_bcast(ctxt,prec%cjswp)
call psb_bcast(ctxt,prec%crkiter)
call psb_bcast(ctxt,prec%crkeps)
call psb_bcast(ctxt,prec%crktrace)
call psb_bcast(ctxt,prec%checkres)
call psb_bcast(ctxt,prec%printres)
call psb_bcast(ctxt,prec%checkiter)
call psb_bcast(ctxt,prec%printiter)
call psb_bcast(ctxt,prec%tol)
call psb_bcast(ctxt,prec%dump)
end subroutine get_parms
tests/pdegen/amg_s_pde3d.f90
+121 -16
View File
@@ -74,6 +74,10 @@ program amg_s_pde3d
use amg_s_pde3d_exp_mod
use amg_s_pde3d_gauss_mod
use amg_s_genpde_mod
use amg_ainv_mod
use amg_s_ilu_solver
use amg_s_rkr_solver
implicit none
! input parameters
@@ -113,6 +117,10 @@ program amg_s_pde3d
type(solverdata) :: s_choice
! preconditioner data
type(amg_s_invt_solver_type) :: invtsv
type(amg_s_invk_solver_type) :: invksv
type(amg_s_ainv_solver_type) :: ainvsv
type(amg_s_rkr_solver_type) :: rkr_slv
type precdata
! preconditioner type
@@ -169,10 +177,22 @@ program amg_s_pde3d
! (repl. mat.)
character(len=16) :: csbsolve ! coarsest-lev local subsolver: ILU, ILUT,
! MILU, UMF, MUMPS, SLU
character(len=16) :: cvariant ! AINV variant: LLK, etc
character(len=16) :: ckryl ! Krylov method for RKR, ignored otherwise
! MILU, UMF, MUMPS, SLU
integer(psb_ipk_) :: cfill ! fill-in for incomplete LU factorization
real(psb_spk_) :: cthres ! threshold for ILUT factorization
integer(psb_ipk_) :: cinvfill ! Inverse fill-in for INVK
integer(psb_ipk_) :: cjswp ! sweeps for GS or JAC coarsest-lev subsolver
real(psb_spk_) :: cthres ! threshold for ILUT factorization
integer(psb_ipk_) :: crkiter ! Max iterations for RKR, ignored otherwise
real(psb_spk_) :: crkeps ! eps for RKR, ignored otherwise
integer(psb_ipk_) :: crktrace ! ITRACE for RKR, ignored otherwise
character(len=16) :: checkres ! Check the BJAC residual
character(len=16) :: printres ! Print the BJAC residual
integer(psb_ipk_) :: checkiter ! ITRACE for residual check
integer(psb_ipk_) :: printiter ! ITRACE for residual print
real(psb_spk_) :: tol ! Tolerance for exit from BJAC
logical :: dump ! dump on file
end type precdata
type(precdata) :: p_choice
@@ -310,11 +330,11 @@ program amg_s_pde3d
call prec%set('sub_prol', p_choice%prol, info)
select case(trim(psb_toupper(p_choice%solve)))
case('INVK')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set(invksv, info)
case('INVT')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set(invtsv, info)
case('AINV')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set(ainvsv, info)
call prec%set('ainv_alg', p_choice%variant, info)
case default
call prec%set('sub_solve', p_choice%solve, info)
@@ -337,12 +357,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(invksv, info, pos='post')
case('INVT')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set(invtsv, info, pos='post')
case('AINV')
call prec%set('sub_solve', p_choice%solve, info)
call prec%set('ainv_alg', p_choice%variant, info)
call prec%set(ainvsv, info, pos='post')
call prec%set('ainv_alg', p_choice%variant2, info, pos='post')
case default
call prec%set('sub_solve', p_choice%solve2, info, pos='post')
end select
@@ -353,13 +373,72 @@ program amg_s_pde3d
end select
end if
call prec%set('coarse_solve', p_choice%csolve, info)
if (psb_toupper(p_choice%csolve) == 'BJAC') &
& call prec%set('coarse_subsolve', p_choice%csbsolve, info)
call prec%set('coarse_mat', p_choice%cmat, info)
call prec%set('coarse_fillin', p_choice%cfill, info)
call prec%set('coarse_iluthrs', p_choice%cthres, info)
call prec%set('coarse_sweeps', p_choice%cjswp, info)
nlv = size(prec%precv)
if (psb_toupper(p_choice%csolve) == 'RKR') then
call prec%set('coarse_solve', 'BJAC', info)
call prec%set(rkr_slv,info,ilev=nlv)
call prec%set('rkr_method',p_choice%ckryl,info,ilev=nlv)
call prec%set('rkr_kprec', 'BJAC' , info,ilev=nlv)
call prec%set('rkr_global', 'global' , info,ilev=nlv)
call prec%set('rkr_eps', p_choice%crkeps,info,ilev=nlv)
call prec%set('rkr_itmax', p_choice%crkiter,info,ilev=nlv)
call prec%set('rkr_fillin', p_choice%cfill,info,ilev=nlv)
call prec%set('coarse_mat', p_choice%cmat, info)
call prec%set('coarse_sweeps', p_choice%cjswp, info)
call prec%set('rkr_itrace', p_choice%crktrace, info,ilev=nlv)
else
call prec%set('coarse_solve', p_choice%csolve, info)
select case(psb_toupper(trim(p_choice%csolve)))
case('BJAC','L1-BJAC')
select case(trim(psb_toupper(p_choice%csbsolve)))
case ('MUMPS')
call prec%set('MUMPS_LOC_GLOB','LOCAL_SOLVER',info)
!
! Experimental: enable Block Low-Rank
!
call prec%set('MUMPS_IPAR_ENTRY',ione,info,idx=35_psb_ipk_)
call prec%set('MUMPS_RPAR_ENTRY',4.0_psb_spk_,info,idx=7_psb_ipk_)
case('RKR')
call prec%set(rkr_slv,info,ilev=nlv)
call prec%set('rkr_method',p_choice%ckryl,info,ilev=nlv)
call prec%set('rkr_global', 'local' , info,ilev=nlv)
call prec%set('rkr_eps', p_choice%crkeps,info,ilev=nlv)
call prec%set('rkr_itmax', p_choice%crkiter,info,ilev=nlv)
call prec%set('rkr_itrace', p_choice%crktrace, info,ilev=nlv)
call prec%set('rkr_fillin', p_choice%cfill,info,ilev=nlv)
case('INVK')
call prec%set(invksv, info,ilev=nlv)
case('INVT')
call prec%set(invtsv, info,ilev=nlv)
case('AINV')
call prec%set(ainvsv, info,ilev=nlv)
call prec%set('ainv_alg', p_choice%cvariant, info, ilev=nlv)
case default
call prec%set('coarse_subsolve', p_choice%csbsolve, info)
end select
!
! Experimental: Use residual check on coarse BJAC solver
!
call prec%set('SMOOTHER_STOP', p_choice%checkres, info)
call prec%set('SMOOTHER_TRACE', p_choice%printres, info)
call prec%set('SMOOTHER_STOPTOL', p_choice%tol, info)
call prec%set('SMOOTHER_ITRACE', p_choice%printiter, info)
call prec%set('SMOOTHER_RESIDUAL',p_choice%checkiter, info)
case('L1-GS')
call prec%set('SMOOTHER_STOP', p_choice%checkres, info)
call prec%set('SMOOTHER_TRACE', p_choice%printres, info)
call prec%set('SMOOTHER_STOPTOL', p_choice%tol, info)
call prec%set('SMOOTHER_ITRACE', p_choice%printiter, info)
call prec%set('SMOOTHER_RESIDUAL',p_choice%checkiter, info)
case default
! Do nothing, should have been already handled
end select
call prec%set('coarse_mat', p_choice%cmat, info)
call prec%set('coarse_fillin', p_choice%cfill, info)
call prec%set('inv_fillin', p_choice%cinvfill, info, ilev=nlv)
call prec%set('coarse_iluthrs', p_choice%cthres, info)
call prec%set('coarse_sweeps', p_choice%cjswp, info)
end if
end select
@@ -573,10 +652,23 @@ contains
! coasest-level solver
call read_data(prec%csolve,inp_unit) ! coarsest-lev solver
call read_data(prec%csbsolve,inp_unit) ! coarsest-lev subsolver
call read_data(prec%cvariant,inp_unit) ! AINV variant
call read_data(prec%ckryl,inp_unit) ! RKR Krylov method choice
call read_data(prec%cmat,inp_unit) ! coarsest mat layout
call read_data(prec%cfill,inp_unit) ! fill-in for incompl LU
call read_data(prec%cinvfill,inp_unit) ! Inverse fill-in for INVK
call read_data(prec%cthres,inp_unit) ! Threshold for ILUT
call read_data(prec%cjswp,inp_unit) ! sweeps for GS/JAC subsolver
call read_data(prec%crkiter,inp_unit) ! Max iterations for RKR, ignored otherwise
call read_data(prec%crkeps,inp_unit) ! eps for RKR, ignored otherwise
call read_data(prec%crktrace,inp_unit) ! itrace for RKR, ignored otherwise
call read_data(prec%checkres,inp_unit) ! Check the BJAC residual
call read_data(prec%printres,inp_unit) ! Print the BJAC residual
call read_data(prec%checkiter,inp_unit) ! ITRACE for residual check
call read_data(prec%printiter,inp_unit) ! ITRACE for residual print
call read_data(prec%tol,inp_unit) ! Tolerance for exit from BJAC
call read_data(prec%dump,inp_unit) !
if (inp_unit /= psb_inp_unit) then
close(inp_unit)
end if
@@ -636,13 +728,26 @@ contains
end if
call psb_bcast(ctxt,prec%athres)
! broadcast coasest-level solver
call psb_bcast(ctxt,prec%csize)
call psb_bcast(ctxt,prec%cmat)
call psb_bcast(ctxt,prec%csolve)
call psb_bcast(ctxt,prec%csbsolve)
call psb_bcast(ctxt,prec%cvariant)
call psb_bcast(ctxt,prec%ckryl)
call psb_bcast(ctxt,prec%cfill)
call psb_bcast(ctxt,prec%cinvfill)
call psb_bcast(ctxt,prec%cthres)
call psb_bcast(ctxt,prec%cjswp)
call psb_bcast(ctxt,prec%crkiter)
call psb_bcast(ctxt,prec%crkeps)
call psb_bcast(ctxt,prec%crktrace)
call psb_bcast(ctxt,prec%checkres)
call psb_bcast(ctxt,prec%printres)
call psb_bcast(ctxt,prec%checkiter)
call psb_bcast(ctxt,prec%printiter)
call psb_bcast(ctxt,prec%tol)
call psb_bcast(ctxt,prec%dump)
end subroutine get_parms
tests/pdegen/runs/amg_pde2d.inp
+18 -5
View File
@@ -46,10 +46,23 @@ FILTER ! Filtering of matrix: FILTER NOFILTER
-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 %%%%%%%%%%%%%%%%
BJAC ! Coarsest-level solver: MUMPS UMF SLU SLUDIST JACOBI GS BJAC
ILU ! Coarsest-level subsolver for BJAC: ILU ILUT MILU UMF MUMPS SLU
%%%%%%%%%%% Coarse level solver %%%%%%%%%%%%%%%%
RKR ! Coarsest-level solver: MUMPS(global) UMF SLU SLUDIST JACOBI GS BJAC RKR(global)
NONE ! Coarsest-level subsolver for BJAC: ILU ILUT MILU UMF MUMPS(local) SLU RKR(local)
LLK ! AINV Variant for the coarse solver
BICGSTAB ! Krylov method for RKR solver/subsolver, ignored otherwise
DIST ! Coarsest-level matrix distribution: DIST REPL
1 ! Coarsest-level fillin P for ILU(P) and ILU(T,P)
0 ! Coarsest-level fillin P for ILU(P) and ILU(T,P)
1 ! Coarsest-level inverse Fill level P for INVK
1.d-4 ! Coarsest-level threshold T for ILU(T,P)
1 ! Number of sweeps for JACOBI/GS/BJAC coarsest-level solver
30 ! Number of sweeps for JACOBI/GS/BJAC coarsest-level solver
30 ! maxit for RKR
1.d-4 ! eps for RKR
30 ! itrace for RKR
T ! Check the BJAC residual
T ! Print the BJAC residual
5 ! ITRACE for residual check
5 ! ITRACE for residual print
1.d-4 ! Tolerance for exit from BJAC
% dump
T ! Dump preconditioner
tests/pdegen/runs/amg_pde3d.inp
+18 -5
View File
@@ -46,10 +46,23 @@ NOFILTER ! Filtering of matrix: FILTER NOFILTER
-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 %%%%%%%%%%%%%%%%
BJAC ! Coarsest-level solver: MUMPS UMF SLU SLUDIST JACOBI GS BJAC
ILU ! Coarsest-level subsolver for BJAC: ILU ILUT MILU UMF MUMPS SLU
%%%%%%%%%%% Coarse level solver %%%%%%%%%%%%%%%%
RKR ! Coarsest-level solver: MUMPS(global) UMF SLU SLUDIST JACOBI GS BJAC RKR(global)
NONE ! Coarsest-level subsolver for BJAC: ILU ILUT MILU UMF MUMPS(local) SLU RKR(local)
LLK ! AINV Variant for the coarse solver
BICGSTAB ! Krylov method for RKR solver/subsolver, ignored otherwise
DIST ! Coarsest-level matrix distribution: DIST REPL
1 ! Coarsest-level fillin P for ILU(P) and ILU(T,P)
0 ! Coarsest-level fillin P for ILU(P) and ILU(T,P)
1 ! Coarsest-level inverse Fill level P for INVK
1.d-4 ! Coarsest-level threshold T for ILU(T,P)
1 ! Number of sweeps for JACOBI/GS/BJAC coarsest-level solver
30 ! Number of sweeps for JACOBI/GS/BJAC coarsest-level solver
30 ! maxit for RKR
1.d-4 ! eps for RKR
30 ! itrace for RKR
T ! Check the BJAC residual
T ! Print the BJAC residual
5 ! ITRACE for residual check
5 ! ITRACE for residual print
1.d-4 ! Tolerance for exit from BJAC
% dump
T ! Dump preconditioner