fdurastante
/
amg4psblas
mirror of https://github.com/sfilippone/amg4psblas.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'mergeparmatch' of github.com:sfilippone/amg4psblas into mergeparmatch

Browse Source
mergeparmatch
Salvatore Filippone 4 years ago
parent 189a4170ec 0153904ef2
commit 97fe836609
9 changed files with 226 additions and 223 deletions
Show Stats Download Patch File Download Diff File

169
amgprec/amg_base_prec_type.F90
Unescape Escape View File

@ -50,16 +50,16 @@
! !
! It contains routines for ! It contains routines for
! - converting character constants defining the preconditioner into integer ! - converting character constants defining the preconditioner into integer
! constants; ! constants;
! - checking if the preconditioner is correctly defined; ! - checking if the preconditioner is correctly defined;
! - printing a description of the preconditioner; ! - printing a description of the preconditioner;
! - deallocating the preconditioner data structure. ! - deallocating the preconditioner data structure.
! !
module amg_base_prec_type module amg_base_prec_type
! !
! This reduces the size of .mod file. Without the ONLY clause compilation ! This reduces the size of .mod file. Without the ONLY clause compilation
! blows up on some systems. ! blows up on some systems.
! !
use psb_const_mod use psb_const_mod
@ -78,7 +78,7 @@ module amg_base_prec_type
& psb_err_from_subroutine_, psb_err_missing_override_method_, & & psb_err_from_subroutine_, psb_err_missing_override_method_, &
& psb_error_handler, psb_out_unit, psb_err_unit & psb_error_handler, psb_out_unit, psb_err_unit
! !
! Version numbers ! Version numbers
! !
character(len=*), parameter :: amg_version_string_ = "1.0.0" character(len=*), parameter :: amg_version_string_ = "1.0.0"
@ -120,7 +120,7 @@ module amg_base_prec_type
procedure, pass(pm) :: printout => d_ml_parms_printout procedure, pass(pm) :: printout => d_ml_parms_printout
end type amg_dml_parms end type amg_dml_parms
type amg_iaggr_data type amg_iaggr_data
! !
@ -134,32 +134,32 @@ module amg_base_prec_type
integer(psb_ipk_) :: min_coarse_size = -ione integer(psb_ipk_) :: min_coarse_size = -ione
integer(psb_ipk_) :: min_coarse_size_per_process = -ione integer(psb_ipk_) :: min_coarse_size_per_process = -ione
integer(psb_lpk_) :: target_coarse_size integer(psb_lpk_) :: target_coarse_size
! 2. maximum number of levels. Defaults to 20 ! 2. maximum number of levels. Defaults to 20
integer(psb_ipk_) :: max_levs = 20_psb_ipk_ integer(psb_ipk_) :: max_levs = 20_psb_ipk_
end type amg_iaggr_data end type amg_iaggr_data
type, extends(amg_iaggr_data) :: amg_saggr_data type, extends(amg_iaggr_data) :: amg_saggr_data
! 3. min_cr_ratio = 1.5 ! 3. min_cr_ratio = 1.5
real(psb_spk_) :: min_cr_ratio = 1.5_psb_spk_ real(psb_spk_) :: min_cr_ratio = 1.5_psb_spk_
real(psb_spk_) :: op_complexity = szero real(psb_spk_) :: op_complexity = szero
real(psb_spk_) :: avg_cr = szero real(psb_spk_) :: avg_cr = szero
end type amg_saggr_data end type amg_saggr_data
type, extends(amg_iaggr_data) :: amg_daggr_data type, extends(amg_iaggr_data) :: amg_daggr_data
! 3. min_cr_ratio = 1.5 ! 3. min_cr_ratio = 1.5
real(psb_dpk_) :: min_cr_ratio = 1.5_psb_dpk_ real(psb_dpk_) :: min_cr_ratio = 1.5_psb_dpk_
real(psb_dpk_) :: op_complexity = dzero real(psb_dpk_) :: op_complexity = dzero
real(psb_dpk_) :: avg_cr = dzero real(psb_dpk_) :: avg_cr = dzero
end type amg_daggr_data end type amg_daggr_data
! !
! Entries in iprcparm ! Entries in iprcparm
! !
! These are in baseprec ! These are in baseprec
! !
integer(psb_ipk_), parameter :: amg_smoother_type_ = 1 integer(psb_ipk_), parameter :: amg_smoother_type_ = 1
integer(psb_ipk_), parameter :: amg_sub_solve_ = 2 integer(psb_ipk_), parameter :: amg_sub_solve_ = 2
integer(psb_ipk_), parameter :: amg_sub_restr_ = 3 integer(psb_ipk_), parameter :: amg_sub_restr_ = 3
integer(psb_ipk_), parameter :: amg_sub_prol_ = 4 integer(psb_ipk_), parameter :: amg_sub_prol_ = 4
@ -169,7 +169,7 @@ module amg_base_prec_type
! !
! These are in onelev ! These are in onelev
! !
integer(psb_ipk_), parameter :: amg_ml_cycle_ = 20 integer(psb_ipk_), parameter :: amg_ml_cycle_ = 20
integer(psb_ipk_), parameter :: amg_smoother_sweeps_pre_ = 21 integer(psb_ipk_), parameter :: amg_smoother_sweeps_pre_ = 21
integer(psb_ipk_), parameter :: amg_smoother_sweeps_post_ = 22 integer(psb_ipk_), parameter :: amg_smoother_sweeps_post_ = 22
@ -181,7 +181,7 @@ module amg_base_prec_type
integer(psb_ipk_), parameter :: amg_aggr_eig_ = 28 integer(psb_ipk_), parameter :: amg_aggr_eig_ = 28
integer(psb_ipk_), parameter :: amg_aggr_filter_ = 29 integer(psb_ipk_), parameter :: amg_aggr_filter_ = 29
integer(psb_ipk_), parameter :: amg_coarse_mat_ = 30 integer(psb_ipk_), parameter :: amg_coarse_mat_ = 30
integer(psb_ipk_), parameter :: amg_coarse_solve_ = 31 integer(psb_ipk_), parameter :: amg_coarse_solve_ = 31
integer(psb_ipk_), parameter :: amg_coarse_sweeps_ = 32 integer(psb_ipk_), parameter :: amg_coarse_sweeps_ = 32
integer(psb_ipk_), parameter :: amg_coarse_fillin_ = 33 integer(psb_ipk_), parameter :: amg_coarse_fillin_ = 33
integer(psb_ipk_), parameter :: amg_coarse_subsolve_ = 34 integer(psb_ipk_), parameter :: amg_coarse_subsolve_ = 34
@ -196,7 +196,7 @@ module amg_base_prec_type
! !
! Legal values for entry: amg_smoother_type_ ! Legal values for entry: amg_smoother_type_
! !
integer(psb_ipk_), parameter :: amg_min_prec_ = 0 integer(psb_ipk_), parameter :: amg_min_prec_ = 0
integer(psb_ipk_), parameter :: amg_noprec_ = 0 integer(psb_ipk_), parameter :: amg_noprec_ = 0
integer(psb_ipk_), parameter :: amg_base_smooth_ = 0 integer(psb_ipk_), parameter :: amg_base_smooth_ = 0
@ -234,7 +234,8 @@ module amg_base_prec_type
integer(psb_ipk_), parameter :: amg_sludist_ = amg_slv_delta_+9 integer(psb_ipk_), parameter :: amg_sludist_ = amg_slv_delta_+9
integer(psb_ipk_), parameter :: amg_mumps_ = amg_slv_delta_+10 integer(psb_ipk_), parameter :: amg_mumps_ = amg_slv_delta_+10
integer(psb_ipk_), parameter :: amg_bwgs_ = amg_slv_delta_+11 integer(psb_ipk_), parameter :: amg_bwgs_ = amg_slv_delta_+11
integer(psb_ipk_), parameter :: amg_max_sub_solve_ = amg_slv_delta_+11 integer(psb_ipk_), parameter :: amg_krm_ = amg_slv_delta_+12
integer(psb_ipk_), parameter :: amg_max_sub_solve_ = amg_slv_delta_+12
integer(psb_ipk_), parameter :: amg_min_sub_solve_ = amg_diag_scale_ integer(psb_ipk_), parameter :: amg_min_sub_solve_ = amg_diag_scale_
! !
@ -392,7 +393,7 @@ module amg_base_prec_type
& 'MILU(n) ','ILU(t,n) ',& & 'MILU(n) ','ILU(t,n) ',&
& 'SuperLU ','UMFPACK LU ',& & 'SuperLU ','UMFPACK LU ',&
& 'SuperLU_Dist ','MUMPS ',& & 'SuperLU_Dist ','MUMPS ',&
& 'Backward GS '/) & 'Backward GS ','Krylov Method '/)
interface amg_check_def interface amg_check_def
module procedure amg_icheck_def, amg_scheck_def, amg_dcheck_def module procedure amg_icheck_def, amg_scheck_def, amg_dcheck_def
@ -427,7 +428,7 @@ contains
do_remap = val do_remap = val
end subroutine amg_set_do_remap end subroutine amg_set_do_remap
! !
! Function: amg_stringval ! Function: amg_stringval
! !
@ -442,10 +443,10 @@ contains
! !
function amg_stringval(string) result(val) function amg_stringval(string) result(val)
use psb_prec_const_mod use psb_prec_const_mod
implicit none implicit none
! Arguments ! Arguments
character(len=*), intent(in) :: string character(len=*), intent(in) :: string
integer(psb_ipk_) :: val integer(psb_ipk_) :: val
character(len=*), parameter :: name='amg_stringval' character(len=*), parameter :: name='amg_stringval'
! Local variable ! Local variable
integer :: index_tab integer :: index_tab
@ -453,14 +454,14 @@ contains
index_tab=index(string,char(9)) index_tab=index(string,char(9))
if (index_tab.NE.0) then if (index_tab.NE.0) then
string2=string(1:index_tab-1) string2=string(1:index_tab-1)
else else
string2=string string2=string
endif endif
select case(psb_toupper(trim(string2))) select case(psb_toupper(trim(string2)))
case('NONE') case('NONE')
val = 0 val = 0
case('HALO') case('HALO')
val = psb_halo_ val = psb_halo_
case('SUM') case('SUM')
val = psb_sum_ val = psb_sum_
case('AVG') case('AVG')
@ -545,6 +546,8 @@ contains
val = amg_jac_ val = amg_jac_
case('L1-JACOBI') case('L1-JACOBI')
val = amg_l1_jac_ val = amg_l1_jac_
case('KRM')
val = amg_krm_
case('AS') case('AS')
val = amg_as_ val = amg_as_
case('A_NORMI') case('A_NORMI')
@ -569,47 +572,47 @@ contains
end function amg_stringval end function amg_stringval
subroutine ml_parms_get_coarse(pm,pmin) subroutine ml_parms_get_coarse(pm,pmin)
implicit none implicit none
class(amg_ml_parms), intent(inout) :: pm class(amg_ml_parms), intent(inout) :: pm
class(amg_ml_parms), intent(in) :: pmin class(amg_ml_parms), intent(in) :: pmin
pm%coarse_mat = pmin%coarse_mat pm%coarse_mat = pmin%coarse_mat
pm%coarse_solve = pmin%coarse_solve pm%coarse_solve = pmin%coarse_solve
end subroutine ml_parms_get_coarse end subroutine ml_parms_get_coarse
subroutine ml_parms_printout(pm,iout) subroutine ml_parms_printout(pm,iout)
implicit none implicit none
class(amg_ml_parms), intent(in) :: pm class(amg_ml_parms), intent(in) :: pm
integer(psb_ipk_), intent(in) :: iout integer(psb_ipk_), intent(in) :: iout
write(iout,*) 'ML : ',pm%ml_cycle write(iout,*) 'ML : ',pm%ml_cycle
write(iout,*) 'Sweeps: ',pm%sweeps_pre,pm%sweeps_post write(iout,*) 'Sweeps: ',pm%sweeps_pre,pm%sweeps_post
write(iout,*) 'AGGR : ',pm%par_aggr_alg,pm%aggr_prol, pm%aggr_ord write(iout,*) 'AGGR : ',pm%par_aggr_alg,pm%aggr_prol, pm%aggr_ord
write(iout,*) ' : ',pm%aggr_omega_alg,pm%aggr_eig,pm%aggr_filter write(iout,*) ' : ',pm%aggr_omega_alg,pm%aggr_eig,pm%aggr_filter
write(iout,*) 'COARSE: ',pm%coarse_mat,pm%coarse_solve write(iout,*) 'COARSE: ',pm%coarse_mat,pm%coarse_solve
end subroutine ml_parms_printout end subroutine ml_parms_printout
subroutine s_ml_parms_printout(pm,iout) subroutine s_ml_parms_printout(pm,iout)
implicit none implicit none
class(amg_sml_parms), intent(in) :: pm class(amg_sml_parms), intent(in) :: pm
integer(psb_ipk_), intent(in) :: iout integer(psb_ipk_), intent(in) :: iout
call pm%amg_ml_parms%printout(iout) call pm%amg_ml_parms%printout(iout)
write(iout,*) 'REAL : ',pm%aggr_omega_val,pm%aggr_thresh write(iout,*) 'REAL : ',pm%aggr_omega_val,pm%aggr_thresh
end subroutine s_ml_parms_printout end subroutine s_ml_parms_printout
subroutine d_ml_parms_printout(pm,iout) subroutine d_ml_parms_printout(pm,iout)
implicit none implicit none
class(amg_dml_parms), intent(in) :: pm class(amg_dml_parms), intent(in) :: pm
integer(psb_ipk_), intent(in) :: iout integer(psb_ipk_), intent(in) :: iout
call pm%amg_ml_parms%printout(iout) call pm%amg_ml_parms%printout(iout)
write(iout,*) 'REAL : ',pm%aggr_omega_val,pm%aggr_thresh write(iout,*) 'REAL : ',pm%aggr_omega_val,pm%aggr_thresh
end subroutine d_ml_parms_printout end subroutine d_ml_parms_printout
! !
! Routines printing out a description of the preconditioner ! Routines printing out a description of the preconditioner
@ -625,7 +628,7 @@ contains
info = psb_success_ info = psb_success_
if ((pm%ml_cycle>=amg_no_ml_).and.(pm%ml_cycle<=amg_max_ml_cycle_)) then if ((pm%ml_cycle>=amg_no_ml_).and.(pm%ml_cycle<=amg_max_ml_cycle_)) then
write(iout,*) ' Multilevel cycle: ',& write(iout,*) ' Multilevel cycle: ',&
& ml_names(pm%ml_cycle) & ml_names(pm%ml_cycle)
select case (pm%ml_cycle) select case (pm%ml_cycle)
@ -651,7 +654,7 @@ contains
info = psb_success_ info = psb_success_
if ((pm%ml_cycle>=amg_no_ml_).and.(pm%ml_cycle<=amg_max_ml_cycle_)) then if ((pm%ml_cycle>=amg_no_ml_).and.(pm%ml_cycle<=amg_max_ml_cycle_)) then
write(iout,*) ' Parallel aggregation algorithm: ',& write(iout,*) ' Parallel aggregation algorithm: ',&
& par_aggr_alg_names(pm%par_aggr_alg) & par_aggr_alg_names(pm%par_aggr_alg)
if (pm%aggr_type>0) write(iout,*) ' Aggregation type: ',& if (pm%aggr_type>0) write(iout,*) ' Aggregation type: ',&
@ -663,23 +666,23 @@ contains
write(iout,*) ' Aggregation prolongator: ', & write(iout,*) ' Aggregation prolongator: ', &
& aggr_prols(pm%aggr_prol) & aggr_prols(pm%aggr_prol)
if (pm%aggr_prol /= amg_no_smooth_) then if (pm%aggr_prol /= amg_no_smooth_) then
write(iout,*) ' with: ', aggr_filters(pm%aggr_filter) write(iout,*) ' with: ', aggr_filters(pm%aggr_filter)
if (pm%aggr_omega_alg == amg_eig_est_) then if (pm%aggr_omega_alg == amg_eig_est_) then
write(iout,*) ' Damping omega computation: spectral radius estimate' write(iout,*) ' Damping omega computation: spectral radius estimate'
write(iout,*) ' Spectral radius estimate: ', & write(iout,*) ' Spectral radius estimate: ', &
& eigen_estimates(pm%aggr_eig) & eigen_estimates(pm%aggr_eig)
else if (pm%aggr_omega_alg == amg_user_choice_) then else if (pm%aggr_omega_alg == amg_user_choice_) then
write(iout,*) ' Damping omega computation: user defined value.' write(iout,*) ' Damping omega computation: user defined value.'
else else
write(iout,*) ' Damping omega computation: unknown value in iprcparm!!' write(iout,*) ' Damping omega computation: unknown value in iprcparm!!'
end if end if
end if end if
!end if !end if
else else
write(iout,*) ' Multilevel type: Unkonwn value. Something is amiss....',& write(iout,*) ' Multilevel type: Unkonwn value. Something is amiss....',&
& pm%ml_cycle & pm%ml_cycle
end if end if
return return
end subroutine ml_parms_mldescr end subroutine ml_parms_mldescr
@ -696,13 +699,13 @@ contains
logical :: coarse_ logical :: coarse_
info = psb_success_ info = psb_success_
if (present(coarse)) then if (present(coarse)) then
coarse_ = coarse coarse_ = coarse
else else
coarse_ = .false. coarse_ = .false.
end if end if
if (coarse_) then if (coarse_) then
call pm%coarsedescr(iout,info) call pm%coarsedescr(iout,info)
end if end if
@ -725,12 +728,12 @@ contains
write(iout,*) ' Coarse matrix: ',& write(iout,*) ' Coarse matrix: ',&
& matrix_names(pm%coarse_mat) & matrix_names(pm%coarse_mat)
select case(pm%coarse_solve) select case(pm%coarse_solve)
case (amg_bjac_,amg_as_) case (amg_bjac_,amg_as_)
write(iout,*) ' Number of sweeps : ',& write(iout,*) ' Number of sweeps : ',&
& pm%sweeps_pre & pm%sweeps_pre
write(iout,*) ' Coarse solver: ',& write(iout,*) ' Coarse solver: ',&
& 'Block Jacobi' & 'Block Jacobi'
case (amg_l1_bjac_) case (amg_l1_bjac_)
write(iout,*) ' Number of sweeps : ',& write(iout,*) ' Number of sweeps : ',&
& pm%sweeps_pre & pm%sweeps_pre
write(iout,*) ' Coarse solver: ',& write(iout,*) ' Coarse solver: ',&
@ -797,7 +800,7 @@ contains
! !
function is_legal_base_prec(ip) function is_legal_base_prec(ip)
implicit none implicit none
integer(psb_ipk_), intent(in) :: ip integer(psb_ipk_), intent(in) :: ip
logical :: is_legal_base_prec logical :: is_legal_base_prec
@ -805,44 +808,44 @@ contains
return return
end function is_legal_base_prec end function is_legal_base_prec
function is_int_non_negative(ip) function is_int_non_negative(ip)
implicit none implicit none
integer(psb_ipk_), intent(in) :: ip integer(psb_ipk_), intent(in) :: ip
logical :: is_int_non_negative logical :: is_int_non_negative
is_int_non_negative = (ip >= 0) is_int_non_negative = (ip >= 0)
return return
end function is_int_non_negative end function is_int_non_negative
function is_legal_ilu_scale(ip) function is_legal_ilu_scale(ip)
implicit none implicit none
integer(psb_ipk_), intent(in) :: ip integer(psb_ipk_), intent(in) :: ip
logical :: is_legal_ilu_scale logical :: is_legal_ilu_scale
is_legal_ilu_scale = ((ip >= amg_ilu_scale_none_).and.(ip <= amg_max_ilu_scale_)) is_legal_ilu_scale = ((ip >= amg_ilu_scale_none_).and.(ip <= amg_max_ilu_scale_))
return return
end function is_legal_ilu_scale end function is_legal_ilu_scale
function is_int_positive(ip) function is_int_positive(ip)
implicit none implicit none
integer(psb_ipk_), intent(in) :: ip integer(psb_ipk_), intent(in) :: ip
logical :: is_int_positive logical :: is_int_positive
is_int_positive = (ip >= 1) is_int_positive = (ip >= 1)
return return
end function is_int_positive end function is_int_positive
function is_legal_prolong(ip) function is_legal_prolong(ip)
implicit none implicit none
integer(psb_ipk_), intent(in) :: ip integer(psb_ipk_), intent(in) :: ip
logical :: is_legal_prolong logical :: is_legal_prolong
is_legal_prolong = ((ip>=psb_none_).and.(ip<=psb_square_root_)) is_legal_prolong = ((ip>=psb_none_).and.(ip<=psb_square_root_))
return return
end function is_legal_prolong end function is_legal_prolong
function is_legal_restrict(ip) function is_legal_restrict(ip)
implicit none implicit none
integer(psb_ipk_), intent(in) :: ip integer(psb_ipk_), intent(in) :: ip
logical :: is_legal_restrict logical :: is_legal_restrict
is_legal_restrict = ((ip == psb_nohalo_).or.(ip==psb_halo_)) is_legal_restrict = ((ip == psb_nohalo_).or.(ip==psb_halo_))
return return
end function is_legal_restrict end function is_legal_restrict
function is_legal_ml_cycle(ip) function is_legal_ml_cycle(ip)
implicit none implicit none
integer(psb_ipk_), intent(in) :: ip integer(psb_ipk_), intent(in) :: ip
logical :: is_legal_ml_cycle logical :: is_legal_ml_cycle
@ -988,7 +991,7 @@ contains
return return
end function is_legal_s_fact_thrs end function is_legal_s_fact_thrs
function is_legal_s_aggr_thrs(ip) function is_legal_s_aggr_thrs(ip)
implicit none implicit none
real(psb_spk_), intent(in) :: ip real(psb_spk_), intent(in) :: ip
logical :: is_legal_s_aggr_thrs logical :: is_legal_s_aggr_thrs
@ -1032,7 +1035,7 @@ contains
end interface end interface
character(len=20), parameter :: rname='amg_check_def' character(len=20), parameter :: rname='amg_check_def'
if (.not.is_legal(ip)) then if (.not.is_legal(ip)) then
write(0,*)trim(rname),': Error: Illegal value for ',& write(0,*)trim(rname),': Error: Illegal value for ',&
& name,' :',ip, '. defaulting to ',id & name,' :',ip, '. defaulting to ',id
ip = id ip = id
@ -1040,11 +1043,11 @@ contains
end subroutine amg_scheck_def end subroutine amg_scheck_def
subroutine amg_dcheck_def(ip,name,id,is_legal) subroutine amg_dcheck_def(ip,name,id,is_legal)
implicit none implicit none
real(psb_dpk_), intent(inout) :: ip real(psb_dpk_), intent(inout) :: ip
real(psb_dpk_), intent(in) :: id real(psb_dpk_), intent(in) :: id
character(len=*), intent(in) :: name character(len=*), intent(in) :: name
interface interface
function is_legal(i) function is_legal(i)
use psb_base_mod, only : psb_dpk_ use psb_base_mod, only : psb_dpk_
real(psb_dpk_), intent(in) :: i real(psb_dpk_), intent(in) :: i
@ -1053,7 +1056,7 @@ contains
end interface end interface
character(len=20), parameter :: rname='amg_check_def' character(len=20), parameter :: rname='amg_check_def'
if (.not.is_legal(ip)) then if (.not.is_legal(ip)) then
write(0,*)trim(rname),': Error: Illegal value for ',& write(0,*)trim(rname),': Error: Illegal value for ',&
& name,' :',ip, '. defaulting to ',id & name,' :',ip, '. defaulting to ',id
ip = id ip = id
@ -1062,7 +1065,7 @@ contains
function pr_to_str(iprec) function pr_to_str(iprec)
implicit none implicit none
integer(psb_ipk_), intent(in) :: iprec integer(psb_ipk_), intent(in) :: iprec
character(len=10) :: pr_to_str character(len=10) :: pr_to_str
@ -1070,11 +1073,11 @@ contains
select case(iprec) select case(iprec)
case(amg_noprec_) case(amg_noprec_)
pr_to_str='NOPREC' pr_to_str='NOPREC'
case(amg_jac_) case(amg_jac_)
pr_to_str='JAC' pr_to_str='JAC'
case(amg_bjac_) case(amg_bjac_)
pr_to_str='BJAC' pr_to_str='BJAC'
case(amg_as_) case(amg_as_)
pr_to_str='AS' pr_to_str='AS'
end select end select
@ -1082,7 +1085,7 @@ contains
subroutine amg_ml_bcast(ctxt,dat,root) subroutine amg_ml_bcast(ctxt,dat,root)
implicit none implicit none
type(psb_ctxt_type), intent(in) :: ctxt type(psb_ctxt_type), intent(in) :: ctxt
type(amg_ml_parms), intent(inout) :: dat type(amg_ml_parms), intent(inout) :: dat
integer(psb_ipk_), intent(in), optional :: root integer(psb_ipk_), intent(in), optional :: root
@ -1104,7 +1107,7 @@ contains
subroutine amg_sml_bcast(ctxt,dat,root) subroutine amg_sml_bcast(ctxt,dat,root)
implicit none implicit none
type(psb_ctxt_type), intent(in) :: ctxt type(psb_ctxt_type), intent(in) :: ctxt
type(amg_sml_parms), intent(inout) :: dat type(amg_sml_parms), intent(inout) :: dat
integer(psb_ipk_), intent(in), optional :: root integer(psb_ipk_), intent(in), optional :: root
@ -1115,7 +1118,7 @@ contains
end subroutine amg_sml_bcast end subroutine amg_sml_bcast
subroutine amg_dml_bcast(ctxt,dat,root) subroutine amg_dml_bcast(ctxt,dat,root)
implicit none implicit none
type(psb_ctxt_type), intent(in) :: ctxt type(psb_ctxt_type), intent(in) :: ctxt
type(amg_dml_parms), intent(inout) :: dat type(amg_dml_parms), intent(inout) :: dat
integer(psb_ipk_), intent(in), optional :: root integer(psb_ipk_), intent(in), optional :: root
@ -1127,7 +1130,7 @@ contains
subroutine ml_parms_clone(pm,pmout,info) subroutine ml_parms_clone(pm,pmout,info)
implicit none implicit none
class(amg_ml_parms), intent(inout) :: pm class(amg_ml_parms), intent(inout) :: pm
class(amg_ml_parms), intent(out) :: pmout class(amg_ml_parms), intent(out) :: pmout
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -1147,19 +1150,19 @@ contains
pmout%coarse_solve = pm%coarse_solve pmout%coarse_solve = pm%coarse_solve
end subroutine ml_parms_clone end subroutine ml_parms_clone
subroutine s_ml_parms_clone(pm,pmout,info) subroutine s_ml_parms_clone(pm,pmout,info)
implicit none implicit none
class(amg_sml_parms), intent(inout) :: pm class(amg_sml_parms), intent(inout) :: pm
class(amg_ml_parms), intent(out) :: pmout class(amg_ml_parms), intent(out) :: pmout
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='clone' character(len=20) :: name='clone'
info = 0 info = 0
select type(pout => pmout) select type(pout => pmout)
class is (amg_sml_parms) class is (amg_sml_parms)
@ -1174,21 +1177,21 @@ contains
call psb_get_erraction(err_act) call psb_get_erraction(err_act)
call psb_error_handler(err_act) call psb_error_handler(err_act)
end select end select
end subroutine s_ml_parms_clone end subroutine s_ml_parms_clone
subroutine d_ml_parms_clone(pm,pmout,info) subroutine d_ml_parms_clone(pm,pmout,info)
implicit none implicit none
class(amg_dml_parms), intent(inout) :: pm class(amg_dml_parms), intent(inout) :: pm
class(amg_ml_parms), intent(out) :: pmout class(amg_ml_parms), intent(out) :: pmout
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='clone' character(len=20) :: name='clone'
info = 0 info = 0
select type(pout => pmout) select type(pout => pmout)
class is (amg_dml_parms) class is (amg_dml_parms)
@ -1204,13 +1207,13 @@ contains
call psb_error_handler(err_act) call psb_error_handler(err_act)
return return
end select end select
end subroutine d_ml_parms_clone end subroutine d_ml_parms_clone
function amg_s_equal_aggregation(parms1, parms2) result(val) function amg_s_equal_aggregation(parms1, parms2) result(val)
type(amg_sml_parms), intent(in) :: parms1, parms2 type(amg_sml_parms), intent(in) :: parms1, parms2
logical :: val logical :: val
val = (parms1%par_aggr_alg == parms2%par_aggr_alg ) .and. & val = (parms1%par_aggr_alg == parms2%par_aggr_alg ) .and. &
& (parms1%aggr_type == parms2%aggr_type ) .and. & & (parms1%aggr_type == parms2%aggr_type ) .and. &
& (parms1%aggr_ord == parms2%aggr_ord ) .and. & & (parms1%aggr_ord == parms2%aggr_ord ) .and. &
@ -1225,7 +1228,7 @@ contains
function amg_d_equal_aggregation(parms1, parms2) result(val) function amg_d_equal_aggregation(parms1, parms2) result(val)
type(amg_dml_parms), intent(in) :: parms1, parms2 type(amg_dml_parms), intent(in) :: parms1, parms2
logical :: val logical :: val
val = (parms1%par_aggr_alg == parms2%par_aggr_alg ) .and. & val = (parms1%par_aggr_alg == parms2%par_aggr_alg ) .and. &
& (parms1%aggr_type == parms2%aggr_type ) .and. & & (parms1%aggr_type == parms2%aggr_type ) .and. &
& (parms1%aggr_ord == parms2%aggr_ord ) .and. & & (parms1%aggr_ord == parms2%aggr_ord ) .and. &
@ -1236,5 +1239,5 @@ contains
& (parms1%aggr_omega_val == parms2%aggr_omega_val ) .and. & & (parms1%aggr_omega_val == parms2%aggr_omega_val ) .and. &
& (parms1%aggr_thresh == parms2%aggr_thresh ) & (parms1%aggr_thresh == parms2%aggr_thresh )
end function amg_d_equal_aggregation end function amg_d_equal_aggregation
end module amg_base_prec_type end module amg_base_prec_type

66
amgprec/impl/amg_c_smoothers_bld.f90
Unescape Escape View File

@ -1,15 +1,15 @@
! !
! !
! AMG4PSBLAS version 1.0 ! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package ! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7) ! based on PSBLAS (Parallel Sparse BLAS version 3.7)
! !
! (C) Copyright 2021 ! (C) Copyright 2021
! !
! Salvatore Filippone ! Salvatore Filippone
! Pasqua D'Ambra ! Pasqua D'Ambra
! Fabio Durastante ! Fabio Durastante
! !
! Redistribution and use in source and binary forms, with or without ! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions ! modification, are permitted provided that the following conditions
! are met: ! are met:
@ -21,7 +21,7 @@
! 3. The name of the AMG4PSBLAS group or the names of its contributors may ! 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 ! not be used to endorse or promote products derived from this
! software without specific written permission. ! software without specific written permission.
! !
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
@ -33,8 +33,8 @@
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! 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 ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE. ! POSSIBILITY OF SUCH DAMAGE.
! !
! !
! File: amg_c_smoothers_bld.f90 ! File: amg_c_smoothers_bld.f90
! !
! Subroutine: amg_c_smoothers_bld ! Subroutine: amg_c_smoothers_bld
@ -43,7 +43,7 @@
! This routine performs the final phase of the multilevel preconditioner ! This routine performs the final phase of the multilevel preconditioner
! build process: builds the "smoother" objects at each level, ! build process: builds the "smoother" objects at each level,
! based on the matrix hierarchy prepared by amg_c_hierarchy_bld. ! based on the matrix hierarchy prepared by amg_c_hierarchy_bld.
! !
! A multilevel preconditioner is regarded as an array of 'one-level' ! A multilevel preconditioner is regarded as an array of 'one-level'
! data structures, each containing the part of the ! data structures, each containing the part of the
! preconditioner associated to a certain level, ! preconditioner associated to a certain level,
@ -52,8 +52,8 @@
! level 1 is the finest level. No transfer operators are associated to level 1. ! level 1 is the finest level. No transfer operators are associated to level 1.
! Each level provides a "build" method; for the base type, the "one-level" ! Each level provides a "build" method; for the base type, the "one-level"
! build procedure simply invokes the build method of the first smoother object, ! build procedure simply invokes the build method of the first smoother object,
! and also on the second object if allocated. ! and also on the second object if allocated.
! !
! !
! Arguments: ! Arguments:
! a - type(psb_cspmat_type). ! a - type(psb_cspmat_type).
@ -65,7 +65,7 @@
! The preconditioner data structure containing the local part ! The preconditioner data structure containing the local part
! of the preconditioner to be built. ! of the preconditioner to be built.
! info - integer, output. ! info - integer, output.
! Error code. ! Error code.
! !
! amold - class(psb_c_base_sparse_mat), input, optional ! amold - class(psb_c_base_sparse_mat), input, optional
! Mold for the inner format of matrices contained in the ! Mold for the inner format of matrices contained in the
@ -77,7 +77,7 @@
! preconditioner ! preconditioner
! !
! !
! !
subroutine amg_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold) subroutine amg_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
use psb_base_mod use psb_base_mod
@ -126,7 +126,7 @@ subroutine amg_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Entering ' & 'Entering '
! !
if (.not.allocated(prec%precv)) then if (.not.allocated(prec%precv)) then
!! Error: should have called amg_cprecinit !! Error: should have called amg_cprecinit
info=3111 info=3111
call psb_errpush(info,name) call psb_errpush(info,name)
@ -134,11 +134,11 @@ subroutine amg_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
end if end if
! !
! Check to ensure all procs have the same ! Check to ensure all procs have the same
! !
iszv = size(prec%precv) iszv = size(prec%precv)
call psb_bcast(ctxt,iszv) call psb_bcast(ctxt,iszv)
if (iszv /= size(prec%precv)) then if (iszv /= size(prec%precv)) then
info=psb_err_internal_error_ info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent size of precv') call psb_errpush(info,name,a_err='Inconsistent size of precv')
goto 9999 goto 9999
@ -151,12 +151,12 @@ subroutine amg_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
endif endif
! !
! Issue a warning for inconsistent changes to COARSE_SOLVE ! Issue a warning for inconsistent changes to COARSE_SOLVE
! but only if it really is a multilevel ! but only if it really is a multilevel
! !
if ((me == psb_root_).and.(iszv>1)) then if ((me == psb_root_).and.(iszv>1)) then
coarse_solve_id = prec%precv(iszv)%parms%coarse_solve coarse_solve_id = prec%precv(iszv)%parms%coarse_solve
select case (coarse_solve_id) select case (coarse_solve_id)
case(amg_umf_,amg_slu_) case(amg_umf_,amg_slu_)
@ -185,7 +185,7 @@ subroutine amg_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& 'AMG4PSBLAS: Warning: original coarse matrix was requested as replicated', & & 'AMG4PSBLAS: Warning: original coarse matrix was requested as replicated', &
& ' but it has been changed to distributed.' & ' but it has been changed to distributed.'
end if end if
case(psb_ilu_n_, psb_ilu_t_,psb_milu_n_) case(psb_ilu_n_, psb_ilu_t_,psb_milu_n_)
if (prec%precv(iszv)%sm%sv%get_id() /= psb_ilu_n_) then if (prec%precv(iszv)%sm%sv%get_id() /= psb_ilu_n_) then
write(psb_err_unit,*) & write(psb_err_unit,*) &
@ -210,7 +210,7 @@ subroutine amg_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& amg_fact_names(coarse_solve_id),& & amg_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to distributed' & ' but the coarse matrix has been changed to distributed'
end if end if
case(amg_mumps_) case(amg_mumps_)
if (prec%precv(iszv)%sm%sv%get_id() /= amg_mumps_) then if (prec%precv(iszv)%sm%sv%get_id() /= amg_mumps_) then
write(psb_err_unit,*) & write(psb_err_unit,*) &
@ -232,7 +232,7 @@ subroutine amg_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& ' was not configured at AMG4PSBLAS build time, or' & ' was not configured at AMG4PSBLAS build time, or'
write(psb_err_unit,*) ' 3. an unsupported solver setup was specified.' write(psb_err_unit,*) ' 3. an unsupported solver setup was specified.'
end if end if
case(amg_sludist_) case(amg_sludist_)
if (prec%precv(iszv)%sm%sv%get_id() /= coarse_solve_id) then if (prec%precv(iszv)%sm%sv%get_id() /= coarse_solve_id) then
write(psb_err_unit,*) & write(psb_err_unit,*) &
@ -260,29 +260,29 @@ subroutine amg_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& amg_fact_names(coarse_solve_id),& & amg_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to replicated' & ' but the coarse matrix has been changed to replicated'
end if end if
case(amg_bjac_,amg_l1_bjac_,amg_jac_, amg_l1_jac_, amg_gs_, amg_fbgs_, amg_l1_gs_,amg_l1_fbgs_) case(amg_bjac_,amg_l1_bjac_,amg_jac_, amg_l1_jac_, amg_gs_, amg_fbgs_, amg_l1_gs_,amg_l1_fbgs_,amg_krm_)
if (prec%precv(iszv)%parms%coarse_mat /= amg_distr_mat_) then if (prec%precv(iszv)%parms%coarse_mat /= amg_distr_mat_) then
write(psb_err_unit,*) & write(psb_err_unit,*) &
& 'AMG4PSBLAS: Warning: original coarse solver was requested as ',& & 'AMG4PSBLAS: Warning: original coarse solver was requested as ',&
& amg_fact_names(coarse_solve_id),& & amg_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to replicated' & ' but the coarse matrix has been changed to replicated'
end if end if
case default case default
! We should never get here. ! We should never get here.
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='unkn coarse_solve' ch_err='unkn coarse_solve'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end select end select
end if end if
! Sanity check: need to ensure that the MUMPS local/global NZ ! Sanity check: need to ensure that the MUMPS local/global NZ
! are handled correctly; this is controlled by local vs global solver. ! are handled correctly; this is controlled by local vs global solver.
! From this point of view, REPL is LOCAL because it owns everyting. ! From this point of view, REPL is LOCAL because it owns everyting.
! Should really find a better way of handling this. ! Should really find a better way of handling this.
if (prec%precv(iszv)%parms%coarse_mat == amg_repl_mat_) & if (prec%precv(iszv)%parms%coarse_mat == amg_repl_mat_) &
& call prec%precv(iszv)%sm%sv%set('MUMPS_LOC_GLOB', amg_local_solver_,info) & call prec%precv(iszv)%sm%sv%set('MUMPS_LOC_GLOB', amg_local_solver_,info)
! !
@ -295,8 +295,8 @@ subroutine amg_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
! !
!!$ write(0,*) me,' Building at level ',i !!$ write(0,*) me,' Building at level ',i
call prec%precv(i)%bld(info,amold=amold,vmold=vmold,imold=imold,ilv=i) call prec%precv(i)%bld(info,amold=amold,vmold=vmold,imold=imold,ilv=i)
if (info /= psb_success_) then if (info /= psb_success_) then
write(ch_err,'(a,i7)') 'Error @ level',i write(ch_err,'(a,i7)') 'Error @ level',i
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err=ch_err) & a_err=ch_err)

4
amgprec/impl/amg_ccprecset.F90
Unescape Escape View File

@ -561,7 +561,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
case('KRM') case('KRM')
block block
type(amg_c_krm_solver_type) :: krm_slv type(amg_c_krm_solver_type) :: krm_slv
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos) call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_krm_,info,pos=pos)
call p%precv(nlev_)%set(krm_slv,info) call p%precv(nlev_)%set(krm_slv,info)
call p%precv(nlev_)%default() call p%precv(nlev_)%default()
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
@ -711,7 +711,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
case('KRM') case('KRM')
block block
type(amg_c_krm_solver_type) :: krm_slv type(amg_c_krm_solver_type) :: krm_slv
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos) call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_krm_,info,pos=pos)
call p%precv(nlev_)%set(krm_slv,info) call p%precv(nlev_)%set(krm_slv,info)
call p%precv(nlev_)%default() call p%precv(nlev_)%default()
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)

66
amgprec/impl/amg_d_smoothers_bld.f90
Unescape Escape View File

@ -1,15 +1,15 @@
! !
! !
! AMG4PSBLAS version 1.0 ! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package ! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7) ! based on PSBLAS (Parallel Sparse BLAS version 3.7)
! !
! (C) Copyright 2021 ! (C) Copyright 2021
! !
! Salvatore Filippone ! Salvatore Filippone
! Pasqua D'Ambra ! Pasqua D'Ambra
! Fabio Durastante ! Fabio Durastante
! !
! Redistribution and use in source and binary forms, with or without ! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions ! modification, are permitted provided that the following conditions
! are met: ! are met:
@ -21,7 +21,7 @@
! 3. The name of the AMG4PSBLAS group or the names of its contributors may ! 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 ! not be used to endorse or promote products derived from this
! software without specific written permission. ! software without specific written permission.
! !
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
@ -33,8 +33,8 @@
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! 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 ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE. ! POSSIBILITY OF SUCH DAMAGE.
! !
! !
! File: amg_d_smoothers_bld.f90 ! File: amg_d_smoothers_bld.f90
! !
! Subroutine: amg_d_smoothers_bld ! Subroutine: amg_d_smoothers_bld
@ -43,7 +43,7 @@
! This routine performs the final phase of the multilevel preconditioner ! This routine performs the final phase of the multilevel preconditioner
! build process: builds the "smoother" objects at each level, ! build process: builds the "smoother" objects at each level,
! based on the matrix hierarchy prepared by amg_d_hierarchy_bld. ! based on the matrix hierarchy prepared by amg_d_hierarchy_bld.
! !
! A multilevel preconditioner is regarded as an array of 'one-level' ! A multilevel preconditioner is regarded as an array of 'one-level'
! data structures, each containing the part of the ! data structures, each containing the part of the
! preconditioner associated to a certain level, ! preconditioner associated to a certain level,
@ -52,8 +52,8 @@
! level 1 is the finest level. No transfer operators are associated to level 1. ! level 1 is the finest level. No transfer operators are associated to level 1.
! Each level provides a "build" method; for the base type, the "one-level" ! Each level provides a "build" method; for the base type, the "one-level"
! build procedure simply invokes the build method of the first smoother object, ! build procedure simply invokes the build method of the first smoother object,
! and also on the second object if allocated. ! and also on the second object if allocated.
! !
! !
! Arguments: ! Arguments:
! a - type(psb_dspmat_type). ! a - type(psb_dspmat_type).
@ -65,7 +65,7 @@
! The preconditioner data structure containing the local part ! The preconditioner data structure containing the local part
! of the preconditioner to be built. ! of the preconditioner to be built.
! info - integer, output. ! info - integer, output.
! Error code. ! Error code.
! !
! amold - class(psb_d_base_sparse_mat), input, optional ! amold - class(psb_d_base_sparse_mat), input, optional
! Mold for the inner format of matrices contained in the ! Mold for the inner format of matrices contained in the
@ -77,7 +77,7 @@
! preconditioner ! preconditioner
! !
! !
! !
subroutine amg_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold) subroutine amg_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
use psb_base_mod use psb_base_mod
@ -126,7 +126,7 @@ subroutine amg_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Entering ' & 'Entering '
! !
if (.not.allocated(prec%precv)) then if (.not.allocated(prec%precv)) then
!! Error: should have called amg_dprecinit !! Error: should have called amg_dprecinit
info=3111 info=3111
call psb_errpush(info,name) call psb_errpush(info,name)
@ -134,11 +134,11 @@ subroutine amg_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
end if end if
! !
! Check to ensure all procs have the same ! Check to ensure all procs have the same
! !
iszv = size(prec%precv) iszv = size(prec%precv)
call psb_bcast(ctxt,iszv) call psb_bcast(ctxt,iszv)
if (iszv /= size(prec%precv)) then if (iszv /= size(prec%precv)) then
info=psb_err_internal_error_ info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent size of precv') call psb_errpush(info,name,a_err='Inconsistent size of precv')
goto 9999 goto 9999
@ -151,12 +151,12 @@ subroutine amg_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
endif endif
! !
! Issue a warning for inconsistent changes to COARSE_SOLVE ! Issue a warning for inconsistent changes to COARSE_SOLVE
! but only if it really is a multilevel ! but only if it really is a multilevel
! !
if ((me == psb_root_).and.(iszv>1)) then if ((me == psb_root_).and.(iszv>1)) then
coarse_solve_id = prec%precv(iszv)%parms%coarse_solve coarse_solve_id = prec%precv(iszv)%parms%coarse_solve
select case (coarse_solve_id) select case (coarse_solve_id)
case(amg_umf_,amg_slu_) case(amg_umf_,amg_slu_)
@ -185,7 +185,7 @@ subroutine amg_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& 'AMG4PSBLAS: Warning: original coarse matrix was requested as replicated', & & 'AMG4PSBLAS: Warning: original coarse matrix was requested as replicated', &
& ' but it has been changed to distributed.' & ' but it has been changed to distributed.'
end if end if
case(psb_ilu_n_, psb_ilu_t_,psb_milu_n_) case(psb_ilu_n_, psb_ilu_t_,psb_milu_n_)
if (prec%precv(iszv)%sm%sv%get_id() /= psb_ilu_n_) then if (prec%precv(iszv)%sm%sv%get_id() /= psb_ilu_n_) then
write(psb_err_unit,*) & write(psb_err_unit,*) &
@ -210,7 +210,7 @@ subroutine amg_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& amg_fact_names(coarse_solve_id),& & amg_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to distributed' & ' but the coarse matrix has been changed to distributed'
end if end if
case(amg_mumps_) case(amg_mumps_)
if (prec%precv(iszv)%sm%sv%get_id() /= amg_mumps_) then if (prec%precv(iszv)%sm%sv%get_id() /= amg_mumps_) then
write(psb_err_unit,*) & write(psb_err_unit,*) &
@ -232,7 +232,7 @@ subroutine amg_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& ' was not configured at AMG4PSBLAS build time, or' & ' was not configured at AMG4PSBLAS build time, or'
write(psb_err_unit,*) ' 3. an unsupported solver setup was specified.' write(psb_err_unit,*) ' 3. an unsupported solver setup was specified.'
end if end if
case(amg_sludist_) case(amg_sludist_)
if (prec%precv(iszv)%sm%sv%get_id() /= coarse_solve_id) then if (prec%precv(iszv)%sm%sv%get_id() /= coarse_solve_id) then
write(psb_err_unit,*) & write(psb_err_unit,*) &
@ -260,29 +260,29 @@ subroutine amg_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& amg_fact_names(coarse_solve_id),& & amg_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to replicated' & ' but the coarse matrix has been changed to replicated'
end if end if
case(amg_bjac_,amg_l1_bjac_,amg_jac_, amg_l1_jac_, amg_gs_, amg_fbgs_, amg_l1_gs_,amg_l1_fbgs_) case(amg_bjac_,amg_l1_bjac_,amg_jac_, amg_l1_jac_, amg_gs_, amg_fbgs_, amg_l1_gs_,amg_l1_fbgs_,amg_krm_)
if (prec%precv(iszv)%parms%coarse_mat /= amg_distr_mat_) then if (prec%precv(iszv)%parms%coarse_mat /= amg_distr_mat_) then
write(psb_err_unit,*) & write(psb_err_unit,*) &
& 'AMG4PSBLAS: Warning: original coarse solver was requested as ',& & 'AMG4PSBLAS: Warning: original coarse solver was requested as ',&
& amg_fact_names(coarse_solve_id),& & amg_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to replicated' & ' but the coarse matrix has been changed to replicated'
end if end if
case default case default
! We should never get here. ! We should never get here.
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='unkn coarse_solve' ch_err='unkn coarse_solve'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end select end select
end if end if
! Sanity check: need to ensure that the MUMPS local/global NZ ! Sanity check: need to ensure that the MUMPS local/global NZ
! are handled correctly; this is controlled by local vs global solver. ! are handled correctly; this is controlled by local vs global solver.
! From this point of view, REPL is LOCAL because it owns everyting. ! From this point of view, REPL is LOCAL because it owns everyting.
! Should really find a better way of handling this. ! Should really find a better way of handling this.
if (prec%precv(iszv)%parms%coarse_mat == amg_repl_mat_) & if (prec%precv(iszv)%parms%coarse_mat == amg_repl_mat_) &
& call prec%precv(iszv)%sm%sv%set('MUMPS_LOC_GLOB', amg_local_solver_,info) & call prec%precv(iszv)%sm%sv%set('MUMPS_LOC_GLOB', amg_local_solver_,info)
! !
@ -295,8 +295,8 @@ subroutine amg_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
! !
!!$ write(0,*) me,' Building at level ',i !!$ write(0,*) me,' Building at level ',i
call prec%precv(i)%bld(info,amold=amold,vmold=vmold,imold=imold,ilv=i) call prec%precv(i)%bld(info,amold=amold,vmold=vmold,imold=imold,ilv=i)
if (info /= psb_success_) then if (info /= psb_success_) then
write(ch_err,'(a,i7)') 'Error @ level',i write(ch_err,'(a,i7)') 'Error @ level',i
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err=ch_err) & a_err=ch_err)

4
amgprec/impl/amg_dcprecset.F90
Unescape Escape View File

@ -587,7 +587,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
case('KRM') case('KRM')
block block
type(amg_d_krm_solver_type) :: krm_slv type(amg_d_krm_solver_type) :: krm_slv
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos) call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_krm_,info,pos=pos)
call p%precv(nlev_)%set(krm_slv,info) call p%precv(nlev_)%set(krm_slv,info)
call p%precv(nlev_)%default() call p%precv(nlev_)%default()
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
@ -751,7 +751,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
case('KRM') case('KRM')
block block
type(amg_d_krm_solver_type) :: krm_slv type(amg_d_krm_solver_type) :: krm_slv
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos) call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_krm_,info,pos=pos)
call p%precv(nlev_)%set(krm_slv,info) call p%precv(nlev_)%set(krm_slv,info)
call p%precv(nlev_)%default() call p%precv(nlev_)%default()
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)

66
amgprec/impl/amg_s_smoothers_bld.f90
Unescape Escape View File

@ -1,15 +1,15 @@
! !
! !
! AMG4PSBLAS version 1.0 ! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package ! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7) ! based on PSBLAS (Parallel Sparse BLAS version 3.7)
! !
! (C) Copyright 2021 ! (C) Copyright 2021
! !
! Salvatore Filippone ! Salvatore Filippone
! Pasqua D'Ambra ! Pasqua D'Ambra
! Fabio Durastante ! Fabio Durastante
! !
! Redistribution and use in source and binary forms, with or without ! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions ! modification, are permitted provided that the following conditions
! are met: ! are met:
@ -21,7 +21,7 @@
! 3. The name of the AMG4PSBLAS group or the names of its contributors may ! 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 ! not be used to endorse or promote products derived from this
! software without specific written permission. ! software without specific written permission.
! !
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
@ -33,8 +33,8 @@
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! 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 ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE. ! POSSIBILITY OF SUCH DAMAGE.
! !
! !
! File: amg_s_smoothers_bld.f90 ! File: amg_s_smoothers_bld.f90
! !
! Subroutine: amg_s_smoothers_bld ! Subroutine: amg_s_smoothers_bld
@ -43,7 +43,7 @@
! This routine performs the final phase of the multilevel preconditioner ! This routine performs the final phase of the multilevel preconditioner
! build process: builds the "smoother" objects at each level, ! build process: builds the "smoother" objects at each level,
! based on the matrix hierarchy prepared by amg_s_hierarchy_bld. ! based on the matrix hierarchy prepared by amg_s_hierarchy_bld.
! !
! A multilevel preconditioner is regarded as an array of 'one-level' ! A multilevel preconditioner is regarded as an array of 'one-level'
! data structures, each containing the part of the ! data structures, each containing the part of the
! preconditioner associated to a certain level, ! preconditioner associated to a certain level,
@ -52,8 +52,8 @@
! level 1 is the finest level. No transfer operators are associated to level 1. ! level 1 is the finest level. No transfer operators are associated to level 1.
! Each level provides a "build" method; for the base type, the "one-level" ! Each level provides a "build" method; for the base type, the "one-level"
! build procedure simply invokes the build method of the first smoother object, ! build procedure simply invokes the build method of the first smoother object,
! and also on the second object if allocated. ! and also on the second object if allocated.
! !
! !
! Arguments: ! Arguments:
! a - type(psb_sspmat_type). ! a - type(psb_sspmat_type).
@ -65,7 +65,7 @@
! The preconditioner data structure containing the local part ! The preconditioner data structure containing the local part
! of the preconditioner to be built. ! of the preconditioner to be built.
! info - integer, output. ! info - integer, output.
! Error code. ! Error code.
! !
! amold - class(psb_s_base_sparse_mat), input, optional ! amold - class(psb_s_base_sparse_mat), input, optional
! Mold for the inner format of matrices contained in the ! Mold for the inner format of matrices contained in the
@ -77,7 +77,7 @@
! preconditioner ! preconditioner
! !
! !
! !
subroutine amg_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold) subroutine amg_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
use psb_base_mod use psb_base_mod
@ -126,7 +126,7 @@ subroutine amg_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Entering ' & 'Entering '
! !
if (.not.allocated(prec%precv)) then if (.not.allocated(prec%precv)) then
!! Error: should have called amg_sprecinit !! Error: should have called amg_sprecinit
info=3111 info=3111
call psb_errpush(info,name) call psb_errpush(info,name)
@ -134,11 +134,11 @@ subroutine amg_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
end if end if
! !
! Check to ensure all procs have the same ! Check to ensure all procs have the same
! !
iszv = size(prec%precv) iszv = size(prec%precv)
call psb_bcast(ctxt,iszv) call psb_bcast(ctxt,iszv)
if (iszv /= size(prec%precv)) then if (iszv /= size(prec%precv)) then
info=psb_err_internal_error_ info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent size of precv') call psb_errpush(info,name,a_err='Inconsistent size of precv')
goto 9999 goto 9999
@ -151,12 +151,12 @@ subroutine amg_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
endif endif
! !
! Issue a warning for inconsistent changes to COARSE_SOLVE ! Issue a warning for inconsistent changes to COARSE_SOLVE
! but only if it really is a multilevel ! but only if it really is a multilevel
! !
if ((me == psb_root_).and.(iszv>1)) then if ((me == psb_root_).and.(iszv>1)) then
coarse_solve_id = prec%precv(iszv)%parms%coarse_solve coarse_solve_id = prec%precv(iszv)%parms%coarse_solve
select case (coarse_solve_id) select case (coarse_solve_id)
case(amg_umf_,amg_slu_) case(amg_umf_,amg_slu_)
@ -185,7 +185,7 @@ subroutine amg_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& 'AMG4PSBLAS: Warning: original coarse matrix was requested as replicated', & & 'AMG4PSBLAS: Warning: original coarse matrix was requested as replicated', &
& ' but it has been changed to distributed.' & ' but it has been changed to distributed.'
end if end if
case(psb_ilu_n_, psb_ilu_t_,psb_milu_n_) case(psb_ilu_n_, psb_ilu_t_,psb_milu_n_)
if (prec%precv(iszv)%sm%sv%get_id() /= psb_ilu_n_) then if (prec%precv(iszv)%sm%sv%get_id() /= psb_ilu_n_) then
write(psb_err_unit,*) & write(psb_err_unit,*) &
@ -210,7 +210,7 @@ subroutine amg_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& amg_fact_names(coarse_solve_id),& & amg_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to distributed' & ' but the coarse matrix has been changed to distributed'
end if end if
case(amg_mumps_) case(amg_mumps_)
if (prec%precv(iszv)%sm%sv%get_id() /= amg_mumps_) then if (prec%precv(iszv)%sm%sv%get_id() /= amg_mumps_) then
write(psb_err_unit,*) & write(psb_err_unit,*) &
@ -232,7 +232,7 @@ subroutine amg_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& ' was not configured at AMG4PSBLAS build time, or' & ' was not configured at AMG4PSBLAS build time, or'
write(psb_err_unit,*) ' 3. an unsupported solver setup was specified.' write(psb_err_unit,*) ' 3. an unsupported solver setup was specified.'
end if end if
case(amg_sludist_) case(amg_sludist_)
if (prec%precv(iszv)%sm%sv%get_id() /= coarse_solve_id) then if (prec%precv(iszv)%sm%sv%get_id() /= coarse_solve_id) then
write(psb_err_unit,*) & write(psb_err_unit,*) &
@ -260,29 +260,29 @@ subroutine amg_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& amg_fact_names(coarse_solve_id),& & amg_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to replicated' & ' but the coarse matrix has been changed to replicated'
end if end if
case(amg_bjac_,amg_l1_bjac_,amg_jac_, amg_l1_jac_, amg_gs_, amg_fbgs_, amg_l1_gs_,amg_l1_fbgs_) case(amg_bjac_,amg_l1_bjac_,amg_jac_, amg_l1_jac_, amg_gs_, amg_fbgs_, amg_l1_gs_,amg_l1_fbgs_,amg_krm_)
if (prec%precv(iszv)%parms%coarse_mat /= amg_distr_mat_) then if (prec%precv(iszv)%parms%coarse_mat /= amg_distr_mat_) then
write(psb_err_unit,*) & write(psb_err_unit,*) &
& 'AMG4PSBLAS: Warning: original coarse solver was requested as ',& & 'AMG4PSBLAS: Warning: original coarse solver was requested as ',&
& amg_fact_names(coarse_solve_id),& & amg_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to replicated' & ' but the coarse matrix has been changed to replicated'
end if end if
case default case default
! We should never get here. ! We should never get here.
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='unkn coarse_solve' ch_err='unkn coarse_solve'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end select end select
end if end if
! Sanity check: need to ensure that the MUMPS local/global NZ ! Sanity check: need to ensure that the MUMPS local/global NZ
! are handled correctly; this is controlled by local vs global solver. ! are handled correctly; this is controlled by local vs global solver.
! From this point of view, REPL is LOCAL because it owns everyting. ! From this point of view, REPL is LOCAL because it owns everyting.
! Should really find a better way of handling this. ! Should really find a better way of handling this.
if (prec%precv(iszv)%parms%coarse_mat == amg_repl_mat_) & if (prec%precv(iszv)%parms%coarse_mat == amg_repl_mat_) &
& call prec%precv(iszv)%sm%sv%set('MUMPS_LOC_GLOB', amg_local_solver_,info) & call prec%precv(iszv)%sm%sv%set('MUMPS_LOC_GLOB', amg_local_solver_,info)
! !
@ -295,8 +295,8 @@ subroutine amg_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
! !
!!$ write(0,*) me,' Building at level ',i !!$ write(0,*) me,' Building at level ',i
call prec%precv(i)%bld(info,amold=amold,vmold=vmold,imold=imold,ilv=i) call prec%precv(i)%bld(info,amold=amold,vmold=vmold,imold=imold,ilv=i)
if (info /= psb_success_) then if (info /= psb_success_) then
write(ch_err,'(a,i7)') 'Error @ level',i write(ch_err,'(a,i7)') 'Error @ level',i
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err=ch_err) & a_err=ch_err)

4
amgprec/impl/amg_scprecset.F90
Unescape Escape View File

@ -561,7 +561,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
case('KRM') case('KRM')
block block
type(amg_s_krm_solver_type) :: krm_slv type(amg_s_krm_solver_type) :: krm_slv
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos) call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_krm_,info,pos=pos)
call p%precv(nlev_)%set(krm_slv,info) call p%precv(nlev_)%set(krm_slv,info)
call p%precv(nlev_)%default() call p%precv(nlev_)%default()
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
@ -711,7 +711,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
case('KRM') case('KRM')
block block
type(amg_s_krm_solver_type) :: krm_slv type(amg_s_krm_solver_type) :: krm_slv
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos) call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_krm_,info,pos=pos)
call p%precv(nlev_)%set(krm_slv,info) call p%precv(nlev_)%set(krm_slv,info)
call p%precv(nlev_)%default() call p%precv(nlev_)%default()
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)

66
amgprec/impl/amg_z_smoothers_bld.f90
Unescape Escape View File

@ -1,15 +1,15 @@
! !
! !
! AMG4PSBLAS version 1.0 ! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package ! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7) ! based on PSBLAS (Parallel Sparse BLAS version 3.7)
! !
! (C) Copyright 2021 ! (C) Copyright 2021
! !
! Salvatore Filippone ! Salvatore Filippone
! Pasqua D'Ambra ! Pasqua D'Ambra
! Fabio Durastante ! Fabio Durastante
! !
! Redistribution and use in source and binary forms, with or without ! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions ! modification, are permitted provided that the following conditions
! are met: ! are met:
@ -21,7 +21,7 @@
! 3. The name of the AMG4PSBLAS group or the names of its contributors may ! 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 ! not be used to endorse or promote products derived from this
! software without specific written permission. ! software without specific written permission.
! !
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
@ -33,8 +33,8 @@
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! 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 ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE. ! POSSIBILITY OF SUCH DAMAGE.
! !
! !
! File: amg_z_smoothers_bld.f90 ! File: amg_z_smoothers_bld.f90
! !
! Subroutine: amg_z_smoothers_bld ! Subroutine: amg_z_smoothers_bld
@ -43,7 +43,7 @@
! This routine performs the final phase of the multilevel preconditioner ! This routine performs the final phase of the multilevel preconditioner
! build process: builds the "smoother" objects at each level, ! build process: builds the "smoother" objects at each level,
! based on the matrix hierarchy prepared by amg_z_hierarchy_bld. ! based on the matrix hierarchy prepared by amg_z_hierarchy_bld.
! !
! A multilevel preconditioner is regarded as an array of 'one-level' ! A multilevel preconditioner is regarded as an array of 'one-level'
! data structures, each containing the part of the ! data structures, each containing the part of the
! preconditioner associated to a certain level, ! preconditioner associated to a certain level,
@ -52,8 +52,8 @@
! level 1 is the finest level. No transfer operators are associated to level 1. ! level 1 is the finest level. No transfer operators are associated to level 1.
! Each level provides a "build" method; for the base type, the "one-level" ! Each level provides a "build" method; for the base type, the "one-level"
! build procedure simply invokes the build method of the first smoother object, ! build procedure simply invokes the build method of the first smoother object,
! and also on the second object if allocated. ! and also on the second object if allocated.
! !
! !
! Arguments: ! Arguments:
! a - type(psb_zspmat_type). ! a - type(psb_zspmat_type).
@ -65,7 +65,7 @@
! The preconditioner data structure containing the local part ! The preconditioner data structure containing the local part
! of the preconditioner to be built. ! of the preconditioner to be built.
! info - integer, output. ! info - integer, output.
! Error code. ! Error code.
! !
! amold - class(psb_z_base_sparse_mat), input, optional ! amold - class(psb_z_base_sparse_mat), input, optional
! Mold for the inner format of matrices contained in the ! Mold for the inner format of matrices contained in the
@ -77,7 +77,7 @@
! preconditioner ! preconditioner
! !
! !
! !
subroutine amg_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold) subroutine amg_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
use psb_base_mod use psb_base_mod
@ -126,7 +126,7 @@ subroutine amg_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Entering ' & 'Entering '
! !
if (.not.allocated(prec%precv)) then if (.not.allocated(prec%precv)) then
!! Error: should have called amg_zprecinit !! Error: should have called amg_zprecinit
info=3111 info=3111
call psb_errpush(info,name) call psb_errpush(info,name)
@ -134,11 +134,11 @@ subroutine amg_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
end if end if
! !
! Check to ensure all procs have the same ! Check to ensure all procs have the same
! !
iszv = size(prec%precv) iszv = size(prec%precv)
call psb_bcast(ctxt,iszv) call psb_bcast(ctxt,iszv)
if (iszv /= size(prec%precv)) then if (iszv /= size(prec%precv)) then
info=psb_err_internal_error_ info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent size of precv') call psb_errpush(info,name,a_err='Inconsistent size of precv')
goto 9999 goto 9999
@ -151,12 +151,12 @@ subroutine amg_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
endif endif
! !
! Issue a warning for inconsistent changes to COARSE_SOLVE ! Issue a warning for inconsistent changes to COARSE_SOLVE
! but only if it really is a multilevel ! but only if it really is a multilevel
! !
if ((me == psb_root_).and.(iszv>1)) then if ((me == psb_root_).and.(iszv>1)) then
coarse_solve_id = prec%precv(iszv)%parms%coarse_solve coarse_solve_id = prec%precv(iszv)%parms%coarse_solve
select case (coarse_solve_id) select case (coarse_solve_id)
case(amg_umf_,amg_slu_) case(amg_umf_,amg_slu_)
@ -185,7 +185,7 @@ subroutine amg_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& 'AMG4PSBLAS: Warning: original coarse matrix was requested as replicated', & & 'AMG4PSBLAS: Warning: original coarse matrix was requested as replicated', &
& ' but it has been changed to distributed.' & ' but it has been changed to distributed.'
end if end if
case(psb_ilu_n_, psb_ilu_t_,psb_milu_n_) case(psb_ilu_n_, psb_ilu_t_,psb_milu_n_)
if (prec%precv(iszv)%sm%sv%get_id() /= psb_ilu_n_) then if (prec%precv(iszv)%sm%sv%get_id() /= psb_ilu_n_) then
write(psb_err_unit,*) & write(psb_err_unit,*) &
@ -210,7 +210,7 @@ subroutine amg_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& amg_fact_names(coarse_solve_id),& & amg_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to distributed' & ' but the coarse matrix has been changed to distributed'
end if end if
case(amg_mumps_) case(amg_mumps_)
if (prec%precv(iszv)%sm%sv%get_id() /= amg_mumps_) then if (prec%precv(iszv)%sm%sv%get_id() /= amg_mumps_) then
write(psb_err_unit,*) & write(psb_err_unit,*) &
@ -232,7 +232,7 @@ subroutine amg_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& ' was not configured at AMG4PSBLAS build time, or' & ' was not configured at AMG4PSBLAS build time, or'
write(psb_err_unit,*) ' 3. an unsupported solver setup was specified.' write(psb_err_unit,*) ' 3. an unsupported solver setup was specified.'
end if end if
case(amg_sludist_) case(amg_sludist_)
if (prec%precv(iszv)%sm%sv%get_id() /= coarse_solve_id) then if (prec%precv(iszv)%sm%sv%get_id() /= coarse_solve_id) then
write(psb_err_unit,*) & write(psb_err_unit,*) &
@ -260,29 +260,29 @@ subroutine amg_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& amg_fact_names(coarse_solve_id),& & amg_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to replicated' & ' but the coarse matrix has been changed to replicated'
end if end if
case(amg_bjac_,amg_l1_bjac_,amg_jac_, amg_l1_jac_, amg_gs_, amg_fbgs_, amg_l1_gs_,amg_l1_fbgs_) case(amg_bjac_,amg_l1_bjac_,amg_jac_, amg_l1_jac_, amg_gs_, amg_fbgs_, amg_l1_gs_,amg_l1_fbgs_,amg_krm_)
if (prec%precv(iszv)%parms%coarse_mat /= amg_distr_mat_) then if (prec%precv(iszv)%parms%coarse_mat /= amg_distr_mat_) then
write(psb_err_unit,*) & write(psb_err_unit,*) &
& 'AMG4PSBLAS: Warning: original coarse solver was requested as ',& & 'AMG4PSBLAS: Warning: original coarse solver was requested as ',&
& amg_fact_names(coarse_solve_id),& & amg_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to replicated' & ' but the coarse matrix has been changed to replicated'
end if end if
case default case default
! We should never get here. ! We should never get here.
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='unkn coarse_solve' ch_err='unkn coarse_solve'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end select end select
end if end if
! Sanity check: need to ensure that the MUMPS local/global NZ ! Sanity check: need to ensure that the MUMPS local/global NZ
! are handled correctly; this is controlled by local vs global solver. ! are handled correctly; this is controlled by local vs global solver.
! From this point of view, REPL is LOCAL because it owns everyting. ! From this point of view, REPL is LOCAL because it owns everyting.
! Should really find a better way of handling this. ! Should really find a better way of handling this.
if (prec%precv(iszv)%parms%coarse_mat == amg_repl_mat_) & if (prec%precv(iszv)%parms%coarse_mat == amg_repl_mat_) &
& call prec%precv(iszv)%sm%sv%set('MUMPS_LOC_GLOB', amg_local_solver_,info) & call prec%precv(iszv)%sm%sv%set('MUMPS_LOC_GLOB', amg_local_solver_,info)
! !
@ -295,8 +295,8 @@ subroutine amg_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
! !
!!$ write(0,*) me,' Building at level ',i !!$ write(0,*) me,' Building at level ',i
call prec%precv(i)%bld(info,amold=amold,vmold=vmold,imold=imold,ilv=i) call prec%precv(i)%bld(info,amold=amold,vmold=vmold,imold=imold,ilv=i)
if (info /= psb_success_) then if (info /= psb_success_) then
write(ch_err,'(a,i7)') 'Error @ level',i write(ch_err,'(a,i7)') 'Error @ level',i
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err=ch_err) & a_err=ch_err)

4
amgprec/impl/amg_zcprecset.F90
Unescape Escape View File

@ -587,7 +587,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
case('KRM') case('KRM')
block block
type(amg_z_krm_solver_type) :: krm_slv type(amg_z_krm_solver_type) :: krm_slv
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos) call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_krm_,info,pos=pos)
call p%precv(nlev_)%set(krm_slv,info) call p%precv(nlev_)%set(krm_slv,info)
call p%precv(nlev_)%default() call p%precv(nlev_)%default()
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
@ -751,7 +751,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
case('KRM') case('KRM')
block block
type(amg_z_krm_solver_type) :: krm_slv type(amg_z_krm_solver_type) :: krm_slv
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos) call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_krm_,info,pos=pos)
call p%precv(nlev_)%set(krm_slv,info) call p%precv(nlev_)%set(krm_slv,info)
call p%precv(nlev_)%default() call p%precv(nlev_)%default()
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)

Write Preview
Loading…
Cancel
Save