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

mld2p4-2:

Browse Source 
README
 mlprec/mld_base_prec_type.F90
 mlprec/mld_c_prec_type.f90
 mlprec/mld_cprecbld.f90
 mlprec/mld_d_prec_type.f90
 mlprec/mld_dprecbld.f90
 mlprec/mld_dprecinit.F90
 mlprec/mld_s_prec_type.f90
 mlprec/mld_sprecbld.f90
 mlprec/mld_z_prec_type.f90
 mlprec/mld_zprecbld.f90
 mlprec/mld_zprecinit.F90
 tests/pdegen/ppde.f90
 tests/pdegen/runs/ppde.inp
 tests/pdegen/spde.f90

Fixes for printout of description, plus computing operator
complexity.
stopcriterion
Salvatore Filippone 14 years ago
parent 8e4c0c99fd
commit eed800dbb4
15 changed files with 755 additions and 927 deletions
Show Stats Download Patch File Download Diff File

7
README
Unescape Escape View File

@ -1,7 +1,12 @@
This directory contains the MLD2P4 set of preconditioners, version 1.1
This directory contains the MLD2P4 set of preconditioners, version 2.0
WHAT'S NEW
Version 2.0.
Finally moved to F2003, with the support of PSBLAS3.
In version 1.1:
- The MLD_SIZEOF() function has been redefined to be INTEGER(8), so
as to be able to measure large data sets.

485
mlprec/mld_base_prec_type.F90
Unescape Escape View File

@ -102,9 +102,12 @@ module mld_base_prec_type
integer :: aggr_omega_alg, aggr_eig, aggr_filter
integer :: coarse_mat, coarse_solve
contains
procedure, pass(pm) :: descr => ml_parms_descr
procedure, pass(pm) :: descr => ml_parms_descr
procedure, pass(pm) :: mldescr => ml_parms_mldescr
procedure, pass(pm) :: coarsedescr => ml_parms_coarsedescr
end type mld_ml_parms
type, extends(mld_ml_parms) :: mld_sml_parms
real(psb_spk_) :: aggr_omega_val, aggr_thresh
contains
@ -426,7 +429,7 @@ contains
! Routines printing out a description of the preconditioner
!
subroutine ml_parms_descr(pm,iout,info,coarse)
subroutine ml_parms_mldescr(pm,iout,info)
use psb_base_mod
@ -436,449 +439,153 @@ contains
class(mld_ml_parms), intent(in) :: pm
integer, intent(in) :: iout
integer, intent(out) :: info
logical, intent(in), optional :: coarse
logical :: coarse_
info = psb_success_
if (present(coarse)) then
coarse_ = coarse
else
coarse_ = .false.
end if
if (pm%ml_type>mld_no_ml_) then
if (coarse_) then
write(iout,*) ' Coarsest matrix: ',&
& matrix_names(pm%coarse_mat)
if (pm%coarse_solve == mld_bjac_) then
write(iout,*) ' Coarse solver: Block Jacobi '
write(iout,*) ' Multilevel type: ',&
& ml_names(pm%ml_type)
write(iout,*) ' Smoother position: ',&
& smooth_pos_names(pm%smoother_pos)
if (pm%ml_type == mld_add_ml_) then
write(iout,*) ' Number of sweeps : ',&
& pm%sweeps
else
write(iout,*) ' Coarse solver: ',&
& fact_names(pm%coarse_solve)
endif
else
if (pm%ml_type>mld_no_ml_) then
write(iout,*) ' Multilevel type: ',&
& ml_names(pm%ml_type)
write(iout,*) ' Smoother position: ',&
& smooth_pos_names(pm%smoother_pos)
if (pm%ml_type == mld_add_ml_) then
else
select case (pm%smoother_pos)
case (mld_pre_smooth_)
write(iout,*) ' Number of sweeps : ',&
& pm%sweeps
& pm%sweeps_pre
case (mld_post_smooth_)
write(iout,*) ' Number of sweeps : ',&
& pm%sweeps_post
case (mld_twoside_smooth_)
write(iout,*) ' Number of sweeps : pre: ',&
& pm%sweeps_pre ,&
& ' post: ',&
& pm%sweeps_post
end select
end if
write(iout,*) ' Aggregation: ', &
& aggr_names(pm%aggr_alg)
write(iout,*) ' Aggregation type: ', &
& aggr_kinds(pm%aggr_kind)
if (pm%aggr_kind /= mld_no_smooth_) then
if (pm%aggr_omega_alg == mld_eig_est_) then
write(iout,*) ' Damping omega computation: spectral radius estimate'
write(iout,*) ' Spectral radius estimate: ', &
& eigen_estimates(pm%aggr_eig)
else if (pm%aggr_omega_alg == mld_user_choice_) then
write(iout,*) ' Damping omega computation: user defined value.'
else
select case (pm%smoother_pos)
case (mld_pre_smooth_)
write(iout,*) ' Number of sweeps : ',&
& pm%sweeps_pre
case (mld_post_smooth_)
write(iout,*) ' Number of sweeps : ',&
& pm%sweeps_post
case (mld_twoside_smooth_)
write(iout,*) ' Number of sweeps : pre: ',&
& pm%sweeps_pre ,&
& ' post: ',&
& pm%sweeps_post
end select
end if
if (pm%aggr_kind /= mld_no_smooth_) then
if (pm%aggr_omega_alg == mld_eig_est_) then
write(iout,*) ' Damping omega computation: spectral radius estimate'
write(iout,*) ' Spectral radius estimate: ', &
& eigen_estimates(pm%aggr_eig)
else if (pm%aggr_omega_alg == mld_user_choice_) then
write(iout,*) ' Damping omega computation: user defined value.'
else
write(iout,*) ' Damping omega computation: unknown value in iprcparm!!'
end if
write(iout,*) ' Damping omega computation: unknown value in iprcparm!!'
end if
write(iout,*) ' Aggregation: ', &
& aggr_names(pm%aggr_alg)
write(iout,*) ' Aggregation type: ', &
& aggr_kinds(pm%aggr_kind)
end if
end if
return
end subroutine ml_parms_descr
end subroutine ml_parms_mldescr
subroutine s_ml_parms_descr(pm,iout,info,coarse)
subroutine ml_parms_coarsedescr(pm,iout,info)
use psb_base_mod
Implicit None
! Arguments
class(mld_sml_parms), intent(in) :: pm
class(mld_ml_parms), intent(in) :: pm
integer, intent(in) :: iout
integer, intent(out) :: info
logical, intent(in), optional :: coarse
info = psb_success_
write(iout,*) ' Coarsest matrix: ',&
& matrix_names(pm%coarse_mat)
if (pm%coarse_solve == mld_bjac_) then
write(iout,*) ' Coarse solver: Block Jacobi '
write(iout,*) ' Number of sweeps : ',&
& pm%sweeps
else
write(iout,*) ' Coarse solver: ',&
& fact_names(pm%coarse_solve)
endif
call pm%mld_ml_parms%descr(iout,info,coarse)
write(iout,*) ' Aggregation threshold: ', &
& pm%aggr_thresh
return
end subroutine s_ml_parms_descr
end subroutine ml_parms_coarsedescr
subroutine d_ml_parms_descr(pm,iout,info,coarse)
subroutine ml_parms_descr(pm,iout,info,coarse)
use psb_base_mod
Implicit None
! Arguments
class(mld_dml_parms), intent(in) :: pm
class(mld_ml_parms), intent(in) :: pm
integer, intent(in) :: iout
integer, intent(out) :: info
logical, intent(in), optional :: coarse
logical :: coarse_
info = psb_success_
if (present(coarse)) then
coarse_ = coarse
else
coarse_ = .false.
end if
call pm%mld_ml_parms%descr(iout,info,coarse)
write(iout,*) ' Aggregation threshold: ', &
& pm%aggr_thresh
return
end subroutine d_ml_parms_descr
if (coarse_) then
call pm%coarsedescr(iout,info)
end if
subroutine mld_base_prec_descr(iout,iprcparm, info,rprcparm,dprcparm)
implicit none
integer, intent(in) :: iprcparm(:),iout
integer, intent(out) :: info
real(psb_spk_), intent(in), optional :: rprcparm(:)
real(psb_dpk_), intent(in), optional :: dprcparm(:)
info = psb_success_
if (count((/ present(rprcparm),present(dprcparm) /)) /= 1) then
info=psb_err_no_optional_arg_
!!$ call psb_errpush(info,name,a_err=" rprcparm, dprcparm")
return
endif
select case(iprcparm(mld_smoother_type_))
case(mld_noprec_)
write(iout,*) ' No preconditioning'
case(mld_jac_)
write(iout,*) ' Jacobi '
case(mld_bjac_)
write(iout,*) ' Block Jacobi with ',&
& fact_names(iprcparm(mld_sub_solve_))
select case(iprcparm(mld_sub_solve_))
case(mld_ilu_n_,mld_milu_n_)
write(iout,*) ' Fill level:',iprcparm(mld_sub_fillin_)
case(mld_ilu_t_)
write(iout,*) ' Fill level:',iprcparm(mld_sub_fillin_)
if (present(rprcparm)) then
write(iout,*) ' Fill threshold :',rprcparm(mld_sub_iluthrs_)
else
write(iout,*) ' Fill threshold :',dprcparm(mld_sub_iluthrs_)
end if
case(mld_slu_,mld_umf_,mld_sludist_,mld_diag_scale_)
case default
write(iout,*) ' Should never get here!'
end select
case(mld_as_)
write(iout,*) ' Additive Schwarz with ',&
& fact_names(iprcparm(mld_sub_solve_))
select case(iprcparm(mld_sub_solve_))
case(mld_ilu_n_,mld_milu_n_)
write(iout,*) ' Fill level:',iprcparm(mld_sub_fillin_)
case(mld_ilu_t_)
write(iout,*) ' Fill level:',iprcparm(mld_sub_fillin_)
if (present(rprcparm)) then
write(iout,*) ' Fill threshold :',rprcparm(mld_sub_iluthrs_)
else
write(iout,*) ' Fill threshold :',dprcparm(mld_sub_iluthrs_)
end if
case(mld_slu_,mld_umf_,mld_sludist_,mld_diag_scale_)
case default
write(iout,*) ' Should never get here!'
end select
write(iout,*) ' Overlap:',&
& iprcparm(mld_sub_ovr_)
write(iout,*) ' Restriction: ',&
& restrict_names(iprcparm(mld_sub_restr_))
write(iout,*) ' Prolongation: ',&
& prolong_names(iprcparm(mld_sub_prol_))
end select
return
end subroutine mld_base_prec_descr
subroutine mld_ml_alg_descr(iout,ilev,iprcparm, info,rprcparm,dprcparm)
implicit none
integer, intent(in) :: iprcparm(:),iout,ilev
integer, intent(out) :: info
real(psb_spk_), intent(in), optional :: rprcparm(:)
real(psb_dpk_), intent(in), optional :: dprcparm(:)
integer :: sweeps
info = psb_success_
if (count((/ present(rprcparm),present(dprcparm) /)) /= 1) then
info=psb_err_no_optional_arg_
!!$ call psb_errpush(info,name,a_err=" rprcparm, dprcparm")
return
endif
if (iprcparm(mld_ml_type_)>mld_no_ml_) then
end subroutine ml_parms_descr
write(iout,*) ' Multilevel type: ',&
& ml_names(iprcparm(mld_ml_type_))
write(iout,*) ' Smoother position: ',&
& smooth_pos_names(iprcparm(mld_smoother_pos_))
if (iprcparm(mld_ml_type_) == mld_add_ml_) then
write(iout,*) ' Number of sweeps : ',&
& iprcparm(mld_smoother_sweeps_)
else
select case (iprcparm(mld_smoother_pos_))
case (mld_pre_smooth_)
write(iout,*) ' Number of sweeps : ',&
& iprcparm(mld_smoother_sweeps_pre_)
case (mld_post_smooth_)
write(iout,*) ' Number of sweeps : ',&
& iprcparm(mld_smoother_sweeps_post_)
case (mld_twoside_smooth_)
write(iout,*) ' Number of sweeps : pre: ',&
& iprcparm(mld_smoother_sweeps_pre_) ,&
& ' post: ',&
& iprcparm(mld_smoother_sweeps_post_)
end select
end if
subroutine s_ml_parms_descr(pm,iout,info,coarse)
write(iout,*) ' Aggregation: ', &
& aggr_names(iprcparm(mld_aggr_alg_))
write(iout,*) ' Aggregation type: ', &
& aggr_kinds(iprcparm(mld_aggr_kind_))
if (present(rprcparm)) then
write(iout,*) ' Aggregation threshold: ', &
& rprcparm(mld_aggr_thresh_)
else
write(iout,*) ' Aggregation threshold: ', &
& dprcparm(mld_aggr_thresh_)
end if
if (iprcparm(mld_aggr_kind_) /= mld_no_smooth_) then
if (iprcparm(mld_aggr_omega_alg_) == mld_eig_est_) then
write(iout,*) ' Damping omega computation: spectral radius estimate'
write(iout,*) ' Spectral radius estimate: ', &
& eigen_estimates(iprcparm(mld_aggr_eig_))
else if (iprcparm(mld_aggr_omega_alg_) == mld_user_choice_) then
write(iout,*) ' Damping omega computation: user defined value.'
else
write(iout,*) ' Damping omega computation: unknown value in iprcparm!!'
end if
end if
end if
use psb_base_mod
return
end subroutine mld_ml_alg_descr
Implicit None
subroutine mld_ml_level_descr(iout,ilev,iprcparm,nlaggr, info,rprcparm,dprcparm)
implicit none
integer, intent(in) :: iprcparm(:),iout,ilev
integer, intent(in), allocatable :: nlaggr(:)
integer, intent(out) :: info
real(psb_spk_), intent(in), optional :: rprcparm(:)
real(psb_dpk_), intent(in), optional :: dprcparm(:)
! Arguments
class(mld_sml_parms), intent(in) :: pm
integer, intent(in) :: iout
integer, intent(out) :: info
logical, intent(in), optional :: coarse
info = psb_success_
if (count((/ present(rprcparm),present(dprcparm) /)) /= 1) then
info=psb_err_no_optional_arg_
!!$ call psb_errpush(info,name,a_err=" rprcparm, dprcparm")
return
endif
if (iprcparm(mld_ml_type_)>mld_no_ml_) then
write(iout,*) ' Level ',ilev
if (allocated(nlaggr)) then
write(iout,*) ' Size of coarse matrix: ', &
& sum(nlaggr(:))
write(iout,*) ' Sizes of aggregates: ', &
& nlaggr(:)
end if
if (iprcparm(mld_aggr_kind_) /= mld_no_smooth_) then
if (present(rprcparm)) then
write(iout,*) ' Damping omega: ', &
& rprcparm(mld_aggr_omega_val_)
else
write(iout,*) ' Damping omega: ', &
& dprcparm(mld_aggr_omega_val_)
end if
end if
call pm%mld_ml_parms%descr(iout,info,coarse)
if (pm%aggr_kind /= mld_no_smooth_) then
write(iout,*) ' Damping omega value :',pm%aggr_omega_val
end if
return
end subroutine mld_ml_level_descr
subroutine mld_ml_coarse_descr(iout,ilev,iprcparm,iprcparm2,nlaggr,info,&
& rprcparm,dprcparm, rprcparm2,dprcparm2)
implicit none
integer, intent(in) :: iprcparm(:),iprcparm2(:),iout,ilev
integer, intent(in), allocatable :: nlaggr(:)
integer, intent(out) :: info
real(psb_spk_), intent(in), optional :: rprcparm(:), rprcparm2(:)
real(psb_dpk_), intent(in), optional :: dprcparm(:), dprcparm2(:)
write(iout,*) ' Aggregation threshold:',pm%aggr_thresh
info = psb_success_
if (count((/ present(rprcparm),present(dprcparm) /)) /= 1) then
info=psb_err_no_optional_arg_
!!$ call psb_errpush(info,name,a_err=" rprcparm, dprcparm")
return
endif
if (count((/ present(rprcparm2),present(dprcparm2) /)) /= 1) then
info=psb_err_no_optional_arg_
!!$ call psb_errpush(info,name,a_err=" rprcparm, dprcparm")
return
endif
if (iprcparm(mld_ml_type_)>mld_no_ml_) then
return
write(iout,*) ' Level ',ilev,' (coarsest)'
write(iout,*) ' Coarsest matrix: ',&
& matrix_names(iprcparm(mld_coarse_mat_))
if (allocated(nlaggr)) then
write(iout,*) ' Size of coarsest matrix: ', &
& sum( nlaggr(:))
write(iout,*) ' Sizes of aggregates: ', &
& nlaggr(:)
end if
if (iprcparm(mld_aggr_kind_) /= mld_no_smooth_) then
if (present(rprcparm)) then
write(iout,*) ' Damping omega: ', &
& rprcparm(mld_aggr_omega_val_)
else
write(iout,*) ' Damping omega: ', &
& dprcparm(mld_aggr_omega_val_)
end if
end if
if (iprcparm(mld_coarse_mat_) == mld_distr_mat_ .and. &
& iprcparm(mld_sub_solve_) /= mld_sludist_) then
!!$ write(iout,*) ' Coarsest matrix solver: ',&
!!$ & smoother_names(iprcparm2(mld_smoother_type_))
select case (iprcparm2(mld_smoother_type_))
case(mld_bjac_,mld_as_)
write(iout,*) ' subdomain solver: ',&
& fact_names(iprcparm2(mld_sub_solve_))
write(iout,*) ' Number of smoother sweeps: ', &
& (iprcparm2(mld_smoother_sweeps_))
case(mld_jac_)
write(iout,*) ' Number of smoother sweeps: ', &
& (iprcparm2(mld_smoother_sweeps_))
end select
else
write(iout,*) ' Coarsest matrix solver: ', &
& fact_names(iprcparm2(mld_sub_solve_))
end if
select case(iprcparm2(mld_sub_solve_))
case(mld_ilu_n_,mld_milu_n_)
write(iout,*) ' Fill level:',iprcparm2(mld_sub_fillin_)
case(mld_ilu_t_)
write(iout,*) ' Fill level:',iprcparm2(mld_sub_fillin_)
if (present(rprcparm2)) then
write(iout,*) ' Fill threshold :',rprcparm2(mld_sub_iluthrs_)
else if (present(dprcparm2)) then
write(iout,*) ' Fill threshold :',dprcparm2(mld_sub_iluthrs_)
end if
case(mld_slu_,mld_umf_,mld_sludist_,mld_diag_scale_)
case default
write(iout,*) ' Should never get here!'
end select
end if
end subroutine s_ml_parms_descr
subroutine d_ml_parms_descr(pm,iout,info,coarse)
return
end subroutine mld_ml_coarse_descr
use psb_base_mod
Implicit None
subroutine mld_ml_new_coarse_descr(iout,ilev,iprcparm,nlaggr,info,&
& rprcparm,dprcparm)
implicit none
integer, intent(in) :: iprcparm(:),iout,ilev
integer, intent(in), allocatable :: nlaggr(:)
integer, intent(out) :: info
real(psb_spk_), intent(in), optional :: rprcparm(:)
real(psb_dpk_), intent(in), optional :: dprcparm(:)
! Arguments
class(mld_dml_parms), intent(in) :: pm
integer, intent(in) :: iout
integer, intent(out) :: info
logical, intent(in), optional :: coarse
info = psb_success_
if (count((/ present(rprcparm),present(dprcparm) /)) /= 1) then
info=psb_err_no_optional_arg_
!!$ call psb_errpush(info,name,a_err=" rprcparm, dprcparm")
return
endif
!!$ if (count((/ present(rprcparm2),present(dprcparm2) /)) /= 1) then
!!$ info=psb_err_no_optional_arg_
! !$ call psb_errpush(info,name,a_err=" rprcparm, dprcparm")
!!$ return
!!$ endif
if (iprcparm(mld_ml_type_)>mld_no_ml_) then
write(iout,*) ' Level ',ilev,' (coarsest)'
write(iout,*) ' Coarsest matrix: ',&
& matrix_names(iprcparm(mld_coarse_mat_))
if (allocated(nlaggr)) then
write(iout,*) ' Size of coarsest matrix: ', &
& sum( nlaggr(:))
write(iout,*) ' Sizes of aggregates: ', &
& nlaggr(:)
end if
if (iprcparm(mld_aggr_kind_) /= mld_no_smooth_) then
if (present(rprcparm)) then
write(iout,*) ' Damping omega: ', &
& rprcparm(mld_aggr_omega_val_)
else
write(iout,*) ' Damping omega: ', &
& dprcparm(mld_aggr_omega_val_)
end if
end if
!!$ if (iprcparm(mld_coarse_mat_) == mld_distr_mat_ .and. &
!!$ & iprcparm(mld_sub_solve_) /= mld_sludist_) then
! !$ write(iout,*) ' Coarsest matrix solver: ',&
! !$ & smoother_names(iprcparm2(mld_smoother_type_))
!!$ select case (iprcparm2(mld_smoother_type_))
!!$ case(mld_bjac_,mld_as_)
!!$ write(iout,*) ' subdomain solver: ',&
!!$ & fact_names(iprcparm2(mld_sub_solve_))
!!$ write(iout,*) ' Number of smoother sweeps: ', &
!!$ & (iprcparm2(mld_smoother_sweeps_))
!!$ case(mld_jac_)
!!$ write(iout,*) ' Number of smoother sweeps: ', &
!!$ & (iprcparm2(mld_smoother_sweeps_))
!!$ end select
!!$ else
!!$ write(iout,*) ' Coarsest matrix solver: ', &
!!$ & fact_names(iprcparm2(mld_sub_solve_))
!!$ end if
!!$ select case(iprcparm2(mld_sub_solve_))
!!$ case(mld_ilu_n_,mld_milu_n_)
!!$ write(iout,*) ' Fill level:',iprcparm2(mld_sub_fillin_)
!!$ case(mld_ilu_t_)
!!$ write(iout,*) ' Fill level:',iprcparm2(mld_sub_fillin_)
!!$ if (present(rprcparm2)) then
!!$ write(iout,*) ' Fill threshold :',rprcparm2(mld_sub_iluthrs_)
!!$ else if (present(dprcparm2)) then
!!$ write(iout,*) ' Fill threshold :',dprcparm2(mld_sub_iluthrs_)
!!$ end if
!!$ case(mld_slu_,mld_umf_,mld_sludist_,mld_diag_scale_)
!!$ case default
!!$ write(iout,*) ' Should never get here!'
!!$ end select
end if
call pm%mld_ml_parms%descr(iout,info,coarse)
if (pm%aggr_kind /= mld_no_smooth_) then
write(iout,*) ' Damping omega value :',pm%aggr_omega_val
end if
write(iout,*) ' Aggregation threshold:',pm%aggr_thresh
return
end subroutine mld_ml_new_coarse_descr
end subroutine d_ml_parms_descr
!
@ -1110,7 +817,7 @@ contains
end function is_legal
end interface
character(len=20), parameter :: rname='mld_check_def'
if (.not.is_legal(ip)) then
write(0,*)trim(rname),': Error: Illegal value for ',&
& name,' :',ip, '. defaulting to ',id
@ -1131,7 +838,7 @@ contains
end function is_legal
end interface
character(len=20), parameter :: rname='mld_check_def'
if (.not.is_legal(ip)) then
write(0,*)trim(rname),': Error: Illegal value for ',&
& name,' :',ip, '. defaulting to ',id
@ -1192,14 +899,14 @@ contains
call psb_bcast(ictxt,dat%aggr_omega_val,root)
call psb_bcast(ictxt,dat%aggr_thresh,root)
end subroutine mld_sml_bcast
subroutine mld_dml_bcast(ictxt,dat,root)
use psb_base_mod
implicit none
integer, intent(in) :: ictxt
type(mld_dml_parms), intent(inout) :: dat
integer, intent(in), optional :: root
call psb_bcast(ictxt,dat%mld_ml_parms,root)
call psb_bcast(ictxt,dat%aggr_omega_val,root)
call psb_bcast(ictxt,dat%aggr_thresh,root)

706
mlprec/mld_c_prec_type.f90
View File

File diff suppressed because it is too large Load Diff

2
mlprec/mld_cprecbld.f90
Unescape Escape View File

@ -194,6 +194,8 @@ subroutine mld_cprecbld(a,desc_a,p,info)
goto 9999
endif
end if
call p%cmp_complexity()
call psb_erractionrestore(err_act)
return

149
mlprec/mld_d_prec_type.f90
Unescape Escape View File

@ -229,11 +229,14 @@ module mld_d_prec_type
type, extends(psb_dprec_type) :: mld_dprec_type
integer :: ictxt
real(psb_dpk_) :: op_complexity=-done
type(mld_donelev_type), allocatable :: precv(:)
contains
procedure, pass(prec) :: d_apply2v => mld_d_apply2v
procedure, pass(prec) :: d_apply1v => mld_d_apply1v
procedure, pass(prec) :: dump => mld_d_dump
procedure, pass(prec) :: get_complexity => mld_d_get_compl
procedure, pass(prec) :: cmp_complexity => mld_d_cmp_compl
end type mld_dprec_type
private :: d_base_solver_bld, d_base_solver_apply, &
@ -251,7 +254,8 @@ module mld_d_prec_type
& d_base_onelev_seti, d_base_onelev_setc, &
& d_base_onelev_setr, d_base_onelev_check, &
& d_base_onelev_default, d_base_onelev_dump, &
& d_base_onelev_descr
& d_base_onelev_descr, mld_d_dump, &
& mld_d_get_compl, mld_d_cmp_compl
!
@ -304,7 +308,6 @@ contains
!
function mld_dprec_sizeof(prec) result(val)
use psb_base_mod
implicit none
type(mld_dprec_type), intent(in) :: prec
integer(psb_long_int_k_) :: val
@ -318,7 +321,6 @@ contains
end if
end function mld_dprec_sizeof
function mld_d_onelev_prec_sizeof(prec) result(val)
implicit none
type(mld_donelev_type), intent(in) :: prec
@ -330,10 +332,48 @@ contains
val = val + psb_sizeof(prec%ac)
val = val + psb_sizeof(prec%map)
if (allocated(prec%sm)) val = val + prec%sm%sizeof()
!!$ write(0,*) 'ONelev sizes: ',psb_sizeof(prec%desc_ac),&
!!$ & psb_sizeof(prec%ac), psb_sizeof(prec%map), prec%sm%sizeof()
end function mld_d_onelev_prec_sizeof
function mld_d_get_compl(prec) result(val)
implicit none
class(mld_dprec_type), intent(in) :: prec
real(psb_dpk_) :: val
val = prec%op_complexity
end function mld_d_get_compl
subroutine mld_d_cmp_compl(prec)
use psb_base_mod, only : psb_min, psb_sum
implicit none
class(mld_dprec_type), intent(inout) :: prec
real(psb_dpk_) :: num,den
integer :: ictxt, il
num = -done
den = done
ictxt = prec%ictxt
if (allocated(prec%precv)) then
il = 1
num = prec%precv(il)%base_a%get_nzeros()
if (num >= dzero) then
den = num
do il=2,size(prec%precv)
num = num + max(0,prec%precv(il)%base_a%get_nzeros())
end do
end if
end if
call psb_min(ictxt,num)
if (num < dzero) then
den = done
else
call psb_sum(ictxt,num)
call psb_sum(ictxt,den)
end if
prec%op_complexity = num/den
end subroutine mld_d_cmp_compl
!
! Subroutine: mld_file_prec_descr
! Version: real
@ -376,7 +416,6 @@ contains
ictxt = p%ictxt
if (allocated(p%precv)) then
!!$ ictxt = psb_cd_get_context(p%precv(1)%prec%desc_data)
call psb_info(ictxt,me,np)
@ -409,58 +448,33 @@ contains
write(iout_,*) 'Base preconditioner (smoother) details'
endif
call p%precv(1)%sm%descr(info,iout=iout_)
if (nlev == 1) then
write(iout_,*)
return
end if
end if
if (nlev > 1) then
!
! Print multilevel details
!
write(iout_,*)
write(iout_,*) 'Multilevel details'
write(iout_,*) ' Number of levels: ',nlev
!
! Currently, all the preconditioner parameters must have
! the same value at levels
! 2,...,nlev-1, hence only the values at level 2 are printed
!
ilev=2
call p%precv(ilev)%parms%descr(iout_,info)
!
! Coarse matrices are different at levels 2,...,nlev-1, hence related
! info is printed separately
!
write(iout_,*)
do ilev = 2, nlev-1
write(iout_,*) ' Level ',ilev
call p%precv(ilev)%descr(info,iout=iout_)
end do
!
! Print coarsest level details
!
! Should rework this.
ilev = nlev
write(iout_,*)
write(iout_,*) ' Level ',ilev,' (coarsest)'
call p%precv(ilev)%parms%descr(iout_,info,coarse=.true.)
call p%precv(ilev)%descr(info,iout=iout_,coarse=.true.)
end if
!
! Print multilevel details
!
write(iout_,*)
write(iout_,*) 'Multilevel details'
write(iout_,*) ' Number of levels : ',nlev
write(iout_,*) ' Operator complexity: ',p%get_complexity()
do ilev=2,nlev
call p%precv(ilev)%descr(ilev,nlev,info,iout=iout_)
end do
write(iout_,*)
end if
endif
write(iout_,*)
else
write(iout_,*) trim(name), &
& ': Error: no base preconditioner available, something is wrong!'
info = -2
return
endif
end subroutine mld_dfile_prec_descr
@ -478,7 +492,7 @@ contains
! error code.
!
subroutine d_base_onelev_descr(lv,info,iout,coarse)
subroutine d_base_onelev_descr(lv,il,nl,info,iout)
use psb_base_mod
@ -486,44 +500,53 @@ contains
! Arguments
class(mld_donelev_type), intent(in) :: lv
integer, intent(in) :: il,nl
integer, intent(out) :: info
integer, intent(in), optional :: iout
logical, intent(in), optional :: coarse
! Local variables
integer :: err_act
integer :: ictxt, me, np
character(len=20), parameter :: name='mld_d_base_onelev_descr'
integer :: iout_
logical :: coarse_
logical :: coarse
call psb_erractionsave(err_act)
if (present(coarse)) then
coarse_ = coarse
else
coarse_ = .false.
end if
coarse = (il==nl)
if (present(iout)) then
iout_ = iout
else
iout_ = 6
end if
write(iout_,*)
if (il == 2) then
call lv%parms%mldescr(iout_,info)
write(iout_,*)
end if
if (coarse) then
write(iout_,*) ' Level ',il,' (coarsest)'
else
write(iout_,*) ' Level ',il
end if
if (lv%parms%ml_type > mld_no_ml_) then
call lv%parms%descr(iout_,info,coarse=coarse)
if (nl > 1) then
if (allocated(lv%map%naggr)) then
write(iout_,*) ' Size of coarse matrix: ', &
& sum(lv%map%naggr(:))
write(iout_,*) ' Sizes of aggregates: ', &
& lv%map%naggr(:)
end if
if (lv%parms%aggr_kind /= mld_no_smooth_) then
write(iout_,*) ' Damping omega: ', &
& lv%parms%aggr_omega_val
end if
end if
if (allocated(lv%sm)) &
if (coarse.and.allocated(lv%sm)) &
& call lv%sm%descr(info,iout=iout_,coarse=coarse)
call psb_erractionrestore(err_act)

2
mlprec/mld_dprecbld.f90
Unescape Escape View File

@ -193,6 +193,8 @@ subroutine mld_dprecbld(a,desc_a,p,info)
goto 9999
endif
end if
call p%cmp_complexity()
call psb_erractionrestore(err_act)
return

2
mlprec/mld_dprecinit.F90
Unescape Escape View File

@ -204,7 +204,7 @@ subroutine mld_dprecinit(p,ptype,info,nlev)
call p%precv(ilev_)%set(mld_sub_prol_,psb_none_,info)
call p%precv(ilev_)%set(mld_sub_ovr_,0,info)
thr = 0.16
thr = 0.16d0
do ilev_=1,nlev_
call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info)
thr = thr/2

165
mlprec/mld_s_prec_type.f90
Unescape Escape View File

@ -229,11 +229,14 @@ module mld_s_prec_type
type, extends(psb_sprec_type) :: mld_sprec_type
integer :: ictxt
real(psb_spk_) :: op_complexity=-sone
type(mld_sonelev_type), allocatable :: precv(:)
contains
procedure, pass(prec) :: s_apply2v => mld_s_apply2v
procedure, pass(prec) :: s_apply1v => mld_s_apply1v
procedure, pass(prec) :: dump => mld_s_dump
procedure, pass(prec) :: get_complexity => mld_s_get_compl
procedure, pass(prec) :: cmp_complexity => mld_s_cmp_compl
end type mld_sprec_type
private :: s_base_solver_bld, s_base_solver_apply, &
@ -251,7 +254,8 @@ module mld_s_prec_type
& s_base_onelev_seti, s_base_onelev_setc, &
& s_base_onelev_setr, s_base_onelev_check, &
& s_base_onelev_default, s_base_onelev_dump, &
& s_base_onelev_descr
& s_base_onelev_descr, mld_s_dump, &
& mld_s_get_compl, mld_s_cmp_compl
!
@ -331,6 +335,46 @@ contains
if (allocated(prec%sm)) val = val + prec%sm%sizeof()
end function mld_s_onelev_prec_sizeof
function mld_s_get_compl(prec) result(val)
implicit none
class(mld_sprec_type), intent(in) :: prec
real(psb_spk_) :: val
val = prec%op_complexity
end function mld_s_get_compl
subroutine mld_s_cmp_compl(prec)
use psb_base_mod, only : psb_min, psb_sum
implicit none
class(mld_sprec_type), intent(inout) :: prec
real(psb_spk_) :: num,den
integer :: ictxt, il
num = -sone
den = sone
ictxt = prec%ictxt
if (allocated(prec%precv)) then
il = 1
num = prec%precv(il)%base_a%get_nzeros()
if (num >= szero) then
den = num
do il=2,size(prec%precv)
num = num + max(0,prec%precv(il)%base_a%get_nzeros())
end do
end if
end if
call psb_min(ictxt,num)
if (num < szero) then
den = sone
else
call psb_sum(ictxt,num)
call psb_sum(ictxt,den)
end if
prec%op_complexity = num/den
end subroutine mld_s_cmp_compl
!
! Subroutine: mld_file_prec_descr
! Version: real
@ -371,12 +415,11 @@ contains
if (iout_ < 0) iout_ = 6
ictxt = p%ictxt
if (allocated(p%precv)) then
!!$ ictxt = psb_cd_get_context(p%precv(1)%prec%desc_data)
call psb_info(ictxt,me,np)
!
! The preconditioner description is printed by processor psb_root_.
! This agrees with the fact that all the parameters defining the
@ -406,58 +449,33 @@ contains
write(iout_,*) 'Base preconditioner (smoother) details'
endif
call p%precv(1)%sm%descr(info,iout=iout_)
if (nlev == 1) then
write(iout_,*)
return
end if
end if
if (nlev > 1) then
!
! Print multilevel details
!
write(iout_,*)
write(iout_,*) 'Multilevel details'
write(iout_,*) ' Number of levels: ',nlev
!
! Currently, all the preconditioner parameters must have
! the same value at levels
! 2,...,nlev-1, hence only the values at level 2 are printed
!
ilev=2
call p%precv(ilev)%parms%descr(iout_,info)
!
! Coarse matrices are different at levels 2,...,nlev-1, hence related
! info is printed separately
!
write(iout_,*)
do ilev = 2, nlev-1
write(iout_,*) ' Level ',ilev
call p%precv(ilev)%descr(info,iout=iout_)
end do
!
! Print coarsest level details
!
! Should rework this.
ilev = nlev
write(iout_,*)
write(iout_,*) ' Level ',ilev,' (coarsest)'
!
! Print multilevel details
!
write(iout_,*)
write(iout_,*) 'Multilevel details'
write(iout_,*) ' Number of levels : ',nlev
write(iout_,*) ' Operator complexity: ',p%get_complexity()
do ilev=2,nlev
call p%precv(ilev)%descr(ilev,nlev,info,iout=iout_)
end do
write(iout_,*)
end if
call p%precv(ilev)%parms%descr(iout_,info,coarse=.true.)
call p%precv(ilev)%descr(info,iout=iout_,coarse=.true.)
end if
endif
write(iout_,*)
else
write(iout_,*) trim(name), &
& ': Error: no base preconditioner available, something is wrong!'
info = -2
return
endif
end subroutine mld_sfile_prec_descr
@ -475,7 +493,7 @@ contains
! error code.
!
subroutine s_base_onelev_descr(lv,info,iout,coarse)
subroutine s_base_onelev_descr(lv,il,nl,info,iout)
use psb_base_mod
@ -483,49 +501,58 @@ contains
! Arguments
class(mld_sonelev_type), intent(in) :: lv
integer, intent(in) :: il,nl
integer, intent(out) :: info
integer, intent(in), optional :: iout
logical, intent(in), optional :: coarse
! Local variables
integer :: err_act
integer :: ictxt, me, np
character(len=20), parameter :: name='mld_s_base_onelev_descr'
integer :: iout_
logical :: coarse_
logical :: coarse
call psb_erractionsave(err_act)
if (present(coarse)) then
coarse_ = coarse
else
coarse_ = .false.
end if
coarse = (il==nl)
if (present(iout)) then
iout_ = iout
else
iout_ = 6
end if
if (lv%parms%ml_type > mld_no_ml_) then
write(iout_,*)
if (il == 2) then
call lv%parms%mldescr(iout_,info)
write(iout_,*)
end if
if (coarse) then
write(iout_,*) ' Level ',il,' (coarsest)'
else
write(iout_,*) ' Level ',il
end if
call lv%parms%descr(iout_,info,coarse=coarse)
if (nl > 1) then
if (allocated(lv%map%naggr)) then
write(iout_,*) ' Size of coarse matrix: ', &
& sum(lv%map%naggr(:))
write(iout_,*) ' Sizes of aggregates: ', &
& lv%map%naggr(:)
end if
if (lv%parms%aggr_kind /= mld_no_smooth_) then
write(iout_,*) ' Damping omega: ', &
& lv%parms%aggr_omega_val
end if
end if
if (allocated(lv%sm)) &
if (coarse.and.allocated(lv%sm)) &
& call lv%sm%descr(info,iout=iout_,coarse=coarse)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then

2
mlprec/mld_sprecbld.f90
Unescape Escape View File

@ -193,6 +193,8 @@ subroutine mld_sprecbld(a,desc_a,p,info)
goto 9999
endif
end if
call p%cmp_complexity()
call psb_erractionrestore(err_act)
return

150
mlprec/mld_z_prec_type.f90
Unescape Escape View File

@ -229,11 +229,14 @@ module mld_z_prec_type
type, extends(psb_zprec_type) :: mld_zprec_type
integer :: ictxt
real(psb_dpk_) :: op_complexity=-done
type(mld_zonelev_type), allocatable :: precv(:)
contains
procedure, pass(prec) :: z_apply2v => mld_z_apply2v
procedure, pass(prec) :: z_apply1v => mld_z_apply1v
procedure, pass(prec) :: dump => mld_z_dump
procedure, pass(prec) :: get_complexity => mld_z_get_compl
procedure, pass(prec) :: cmp_complexity => mld_z_cmp_compl
end type mld_zprec_type
private :: z_base_solver_bld, z_base_solver_apply, &
@ -251,7 +254,8 @@ module mld_z_prec_type
& z_base_onelev_seti, z_base_onelev_setc, &
& z_base_onelev_setr, z_base_onelev_check, &
& z_base_onelev_default, z_base_onelev_dump, &
& z_base_onelev_descr
& z_base_onelev_descr, mld_z_dump, &
& mld_z_get_compl, mld_z_cmp_compl
!
@ -330,6 +334,46 @@ contains
if (allocated(prec%sm)) val = val + prec%sm%sizeof()
end function mld_z_onelev_prec_sizeof
function mld_z_get_compl(prec) result(val)
implicit none
class(mld_zprec_type), intent(in) :: prec
real(psb_dpk_) :: val
val = prec%op_complexity
end function mld_z_get_compl
subroutine mld_z_cmp_compl(prec)
use psb_base_mod, only : psb_min, psb_sum
implicit none
class(mld_zprec_type), intent(inout) :: prec
real(psb_dpk_) :: num,den
integer :: ictxt, il
num = -done
den = done
ictxt = prec%ictxt
if (allocated(prec%precv)) then
il = 1
num = prec%precv(il)%base_a%get_nzeros()
if (num >= dzero) then
den = num
do il=2,size(prec%precv)
num = num + max(0,prec%precv(il)%base_a%get_nzeros())
end do
end if
end if
call psb_min(ictxt,num)
if (num < dzero) then
den = done
else
call psb_sum(ictxt,num)
call psb_sum(ictxt,den)
end if
prec%op_complexity = num/den
end subroutine mld_z_cmp_compl
!
! Subroutine: mld_file_prec_descr
! Version: real
@ -370,12 +414,11 @@ contains
if (iout_ < 0) iout_ = 6
ictxt = p%ictxt
if (allocated(p%precv)) then
!!$ ictxt = psb_cd_get_context(p%precv(1)%prec%desc_data)
call psb_info(ictxt,me,np)
!
! The preconditioner description is printed by processor psb_root_.
! This agrees with the fact that all the parameters defining the
@ -405,57 +448,33 @@ contains
write(iout_,*) 'Base preconditioner (smoother) details'
endif
call p%precv(1)%sm%descr(info,iout=iout_)
if (nlev == 1) then
write(iout_,*)
return
end if
end if
if (nlev > 1) then
!
! Print multilevel details
!
write(iout_,*)
write(iout_,*) 'Multilevel details'
write(iout_,*) ' Number of levels: ',nlev
!
! Currently, all the preconditioner parameters must have
! the same value at levels
! 2,...,nlev-1, hence only the values at level 2 are printed
!
ilev=2
call p%precv(ilev)%parms%descr(iout_,info)
!
! Coarse matrices are different at levels 2,...,nlev-1, hence related
! info is printed separately
!
write(iout_,*)
do ilev = 2, nlev-1
write(iout_,*) ' Level ',ilev
call p%precv(ilev)%descr(info,iout=iout_)
end do
!
! Print coarsest level details
!
! Should rework this.
ilev = nlev
write(iout_,*)
write(iout_,*) ' Level ',ilev,' (coarsest)'
!
! Print multilevel details
!
write(iout_,*)
write(iout_,*) 'Multilevel details'
write(iout_,*) ' Number of levels : ',nlev
write(iout_,*) ' Operator complexity: ',p%get_complexity()
do ilev=2,nlev
call p%precv(ilev)%descr(ilev,nlev,info,iout=iout_)
end do
write(iout_,*)
end if
call p%precv(ilev)%parms%descr(iout_,info,coarse=.true.)
call p%precv(ilev)%descr(info,iout=iout_,coarse=.true.)
end if
endif
write(iout_,*)
else
write(iout_,*) trim(name), &
& ': Error: no base preconditioner available, something is wrong!'
info = -2
return
endif
end subroutine mld_zfile_prec_descr
@ -473,7 +492,7 @@ contains
! error code.
!
subroutine z_base_onelev_descr(lv,info,iout,coarse)
subroutine z_base_onelev_descr(lv,il,nl,info,iout)
use psb_base_mod
@ -481,44 +500,53 @@ contains
! Arguments
class(mld_zonelev_type), intent(in) :: lv
integer, intent(in) :: il,nl
integer, intent(out) :: info
integer, intent(in), optional :: iout
logical, intent(in), optional :: coarse
! Local variables
integer :: err_act
integer :: ictxt, me, np
character(len=20), parameter :: name='mld_z_base_onelev_descr'
integer :: iout_
logical :: coarse_
logical :: coarse
call psb_erractionsave(err_act)
if (present(coarse)) then
coarse_ = coarse
else
coarse_ = .false.
end if
coarse = (il==nl)
if (present(iout)) then
iout_ = iout
else
iout_ = 6
end if
write(iout_,*)
if (il == 2) then
call lv%parms%mldescr(iout_,info)
write(iout_,*)
end if
if (lv%parms%ml_type > mld_no_ml_) then
if (coarse) then
write(iout_,*) ' Level ',il,' (coarsest)'
else
write(iout_,*) ' Level ',il
end if
call lv%parms%descr(iout_,info,coarse=coarse)
if (nl > 1) then
if (allocated(lv%map%naggr)) then
write(iout_,*) ' Size of coarse matrix: ', &
& sum(lv%map%naggr(:))
write(iout_,*) ' Sizes of aggregates: ', &
& lv%map%naggr(:)
end if
if (lv%parms%aggr_kind /= mld_no_smooth_) then
write(iout_,*) ' Damping omega: ', &
& lv%parms%aggr_omega_val
end if
end if
if (allocated(lv%sm)) &
if (coarse.and.allocated(lv%sm)) &
& call lv%sm%descr(info,iout=iout_,coarse=coarse)
call psb_erractionrestore(err_act)

2
mlprec/mld_zprecbld.f90
Unescape Escape View File

@ -194,6 +194,8 @@ subroutine mld_zprecbld(a,desc_a,p,info)
goto 9999
endif
end if
call p%cmp_complexity()
call psb_erractionrestore(err_act)
return

2
mlprec/mld_zprecinit.F90
Unescape Escape View File

@ -202,7 +202,7 @@ subroutine mld_zprecinit(p,ptype,info,nlev)
call p%precv(ilev_)%set(mld_sub_prol_,psb_none_,info)
call p%precv(ilev_)%set(mld_sub_ovr_,0,info)
thr = 0.16
thr = 0.16d0
do ilev_=1,nlev_
call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info)
thr = thr/2

3
tests/pdegen/ppde.f90
Unescape Escape View File

@ -195,7 +195,8 @@ program ppde
call mld_precset(prec,mld_aggr_alg_, prectype%aggr_alg,info)
call mld_precset(prec,mld_ml_type_, prectype%mltype, info)
call mld_precset(prec,mld_smoother_pos_, prectype%smthpos, info)
call mld_precset(prec,mld_aggr_thresh_, prectype%athres, info)
if (prectype%athres >= dzero) &
& call mld_precset(prec,mld_aggr_thresh_, prectype%athres, info)
call mld_precset(prec,mld_coarse_solve_, prectype%csolve, info)
call mld_precset(prec,mld_coarse_subsolve_, prectype%csbsolve,info)
call mld_precset(prec,mld_coarse_mat_, prectype%cmat, info)

2
tests/pdegen/runs/ppde.inp
Unescape Escape View File

@ -27,4 +27,4 @@ UMF ! Coarse level: subsolver DSCALE ILU UMF SLU SLUDI
1 ! Coarse level: Level-set N for ILU(N)
1.d-4 ! Coarse level: Threshold T for ILU(T,P)
4 ! Coarse level: Number of Jacobi sweeps
0.10d0 ! Smoother Aggregation Threshold: >= 0.0
-0.10d0 ! Smoother Aggregation Threshold: >= 0.0 default if < 0.0

3
tests/pdegen/spde.f90
Unescape Escape View File

@ -193,7 +193,8 @@ program spde
call mld_precset(prec,mld_aggr_alg_, prectype%aggr_alg,info)
call mld_precset(prec,mld_ml_type_, prectype%mltype, info)
call mld_precset(prec,mld_smoother_pos_, prectype%smthpos, info)
call mld_precset(prec,mld_aggr_thresh_, prectype%athres, info)
if (prectype%athres >= szero) &
& call mld_precset(prec,mld_aggr_thresh_, prectype%athres, info)
call mld_precset(prec,mld_coarse_solve_, prectype%csolve, info)
call mld_precset(prec,mld_coarse_subsolve_, prectype%csbsolve,info)
call mld_precset(prec,mld_coarse_mat_, prectype%cmat, info)

Write Preview
Loading…
Cancel
Save