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

mld2p4-2:

Browse Source 
configure.ac
 configure
 mlprec/Makefile
 mlprec/impl/Makefile
 mlprec/impl/level/mld_c_base_onelev_build.f90
 mlprec/impl/level/mld_c_base_onelev_check.f90
 mlprec/impl/level/mld_c_base_onelev_csetc.f90
 mlprec/impl/level/mld_c_base_onelev_cseti.F90
 mlprec/impl/level/mld_c_base_onelev_csetr.f90
 mlprec/impl/level/mld_c_base_onelev_setc.f90
 mlprec/impl/level/mld_c_base_onelev_seti.F90
 mlprec/impl/level/mld_c_base_onelev_setr.f90
 mlprec/impl/level/mld_c_base_onelev_setsm.F90
 mlprec/impl/level/mld_c_base_onelev_setsv.F90
 mlprec/impl/level/mld_d_base_onelev_build.f90
 mlprec/impl/level/mld_d_base_onelev_check.f90
 mlprec/impl/level/mld_d_base_onelev_csetc.f90
 mlprec/impl/level/mld_d_base_onelev_cseti.F90
 mlprec/impl/level/mld_d_base_onelev_csetr.f90
 mlprec/impl/level/mld_d_base_onelev_setc.f90
 mlprec/impl/level/mld_d_base_onelev_seti.F90
 mlprec/impl/level/mld_d_base_onelev_setr.f90
 mlprec/impl/level/mld_d_base_onelev_setsm.F90
 mlprec/impl/level/mld_d_base_onelev_setsv.F90
 mlprec/impl/level/mld_s_base_onelev_build.f90
 mlprec/impl/level/mld_s_base_onelev_check.f90
 mlprec/impl/level/mld_s_base_onelev_csetc.f90
 mlprec/impl/level/mld_s_base_onelev_cseti.F90
 mlprec/impl/level/mld_s_base_onelev_csetr.f90
 mlprec/impl/level/mld_s_base_onelev_setc.f90
 mlprec/impl/level/mld_s_base_onelev_seti.F90
 mlprec/impl/level/mld_s_base_onelev_setr.f90
 mlprec/impl/level/mld_s_base_onelev_setsm.F90
 mlprec/impl/level/mld_s_base_onelev_setsv.F90
 mlprec/impl/level/mld_z_base_onelev_build.f90
 mlprec/impl/level/mld_z_base_onelev_check.f90
 mlprec/impl/level/mld_z_base_onelev_csetc.f90
 mlprec/impl/level/mld_z_base_onelev_cseti.F90
 mlprec/impl/level/mld_z_base_onelev_csetr.f90
 mlprec/impl/level/mld_z_base_onelev_setc.f90
 mlprec/impl/level/mld_z_base_onelev_seti.F90
 mlprec/impl/level/mld_z_base_onelev_setr.f90
 mlprec/impl/level/mld_z_base_onelev_setsm.F90
 mlprec/impl/level/mld_z_base_onelev_setsv.F90
 mlprec/impl/mld_c_extprol_bld.f90
 mlprec/impl/mld_c_hierarchy_bld.f90
 mlprec/impl/mld_c_lev_aggrmap_bld.f90
 mlprec/impl/mld_c_lev_aggrmat_asb.f90
 mlprec/impl/mld_c_smoothers_bld.f90
 mlprec/impl/mld_caggrmat_asb.f90
 mlprec/impl/mld_caggrmat_biz_asb.f90
 mlprec/impl/mld_caggrmat_smth_asb.f90
 mlprec/impl/mld_ccprecset.F90
 mlprec/impl/mld_cmlprec_aply.f90
 mlprec/impl/mld_cmlprec_bld.f90
 mlprec/impl/mld_cprecaply.f90
 mlprec/impl/mld_cprecbld.f90
 mlprec/impl/mld_cprecinit.F90
 mlprec/impl/mld_cprecset.F90
 mlprec/impl/mld_cslud_interface.c
 mlprec/impl/mld_d_extprol_bld.f90
 mlprec/impl/mld_d_hierarchy_bld.f90
 mlprec/impl/mld_d_lev_aggrmap_bld.f90
 mlprec/impl/mld_d_lev_aggrmat_asb.f90
 mlprec/impl/mld_d_smoothers_bld.f90
 mlprec/impl/mld_daggrmat_asb.f90
 mlprec/impl/mld_daggrmat_biz_asb.f90
 mlprec/impl/mld_daggrmat_smth_asb.f90
 mlprec/impl/mld_dcprecset.F90
 mlprec/impl/mld_dmlprec_aply.f90
 mlprec/impl/mld_dmlprec_bld.f90
 mlprec/impl/mld_dprecaply.f90
 mlprec/impl/mld_dprecbld.f90
 mlprec/impl/mld_dprecinit.F90
 mlprec/impl/mld_dprecset.F90
 mlprec/impl/mld_s_extprol_bld.f90
 mlprec/impl/mld_s_hierarchy_bld.f90
 mlprec/impl/mld_s_lev_aggrmap_bld.f90
 mlprec/impl/mld_s_lev_aggrmat_asb.f90
 mlprec/impl/mld_s_smoothers_bld.f90
 mlprec/impl/mld_saggrmat_asb.f90
 mlprec/impl/mld_saggrmat_biz_asb.f90
 mlprec/impl/mld_saggrmat_smth_asb.f90
 mlprec/impl/mld_scprecset.F90
 mlprec/impl/mld_smlprec_aply.f90
 mlprec/impl/mld_smlprec_bld.f90
 mlprec/impl/mld_sprecaply.f90
 mlprec/impl/mld_sprecbld.f90
 mlprec/impl/mld_sprecinit.F90
 mlprec/impl/mld_sprecset.F90
 mlprec/impl/mld_sslud_interface.c
 mlprec/impl/mld_z_extprol_bld.f90
 mlprec/impl/mld_z_hierarchy_bld.f90
 mlprec/impl/mld_z_lev_aggrmap_bld.f90
 mlprec/impl/mld_z_lev_aggrmat_asb.f90
 mlprec/impl/mld_z_smoothers_bld.f90
 mlprec/impl/mld_zaggrmat_asb.f90
 mlprec/impl/mld_zaggrmat_biz_asb.f90
 mlprec/impl/mld_zaggrmat_smth_asb.f90
 mlprec/impl/mld_zcprecset.F90
 mlprec/impl/mld_zmlprec_aply.f90
 mlprec/impl/mld_zmlprec_bld.f90
 mlprec/impl/mld_zprecaply.f90
 mlprec/impl/mld_zprecbld.f90
 mlprec/impl/mld_zprecinit.F90
 mlprec/impl/mld_zprecset.F90
 mlprec/impl/smoother/mld_c_as_smoother_bld.f90
 mlprec/impl/smoother/mld_c_base_smoother_bld.f90
 mlprec/impl/smoother/mld_c_jac_smoother_bld.f90
 mlprec/impl/smoother/mld_d_as_smoother_bld.f90
 mlprec/impl/smoother/mld_d_base_smoother_bld.f90
 mlprec/impl/smoother/mld_d_jac_smoother_bld.f90
 mlprec/impl/smoother/mld_s_as_smoother_bld.f90
 mlprec/impl/smoother/mld_s_base_smoother_bld.f90
 mlprec/impl/smoother/mld_s_jac_smoother_bld.f90
 mlprec/impl/smoother/mld_z_as_smoother_bld.f90
 mlprec/impl/smoother/mld_z_base_smoother_bld.f90
 mlprec/impl/smoother/mld_z_jac_smoother_bld.f90
 mlprec/impl/solver/mld_c_base_solver_bld.f90
 mlprec/impl/solver/mld_c_bwgs_solver_bld.f90
 mlprec/impl/solver/mld_c_diag_solver_bld.f90
 mlprec/impl/solver/mld_c_gs_solver_bld.f90
 mlprec/impl/solver/mld_c_ilu_solver_bld.f90
 mlprec/impl/solver/mld_c_mumps_solver_bld.F90
 mlprec/impl/solver/mld_d_base_solver_bld.f90
 mlprec/impl/solver/mld_d_bwgs_solver_bld.f90
 mlprec/impl/solver/mld_d_diag_solver_bld.f90
 mlprec/impl/solver/mld_d_gs_solver_bld.f90
 mlprec/impl/solver/mld_d_ilu_solver_bld.f90
 mlprec/impl/solver/mld_d_mumps_solver_bld.F90
 mlprec/impl/solver/mld_s_base_solver_bld.f90
 mlprec/impl/solver/mld_s_bwgs_solver_bld.f90
 mlprec/impl/solver/mld_s_diag_solver_bld.f90
 mlprec/impl/solver/mld_s_gs_solver_bld.f90
 mlprec/impl/solver/mld_s_ilu_solver_bld.f90
 mlprec/impl/solver/mld_s_mumps_solver_bld.F90
 mlprec/impl/solver/mld_z_base_solver_bld.f90
 mlprec/impl/solver/mld_z_bwgs_solver_bld.f90
 mlprec/impl/solver/mld_z_diag_solver_bld.f90
 mlprec/impl/solver/mld_z_gs_solver_bld.f90
 mlprec/impl/solver/mld_z_ilu_solver_bld.f90
 mlprec/impl/solver/mld_z_mumps_solver_bld.F90
 mlprec/mld_base_prec_type.F90
 mlprec/mld_c_as_smoother.f90
 mlprec/mld_c_base_smoother_mod.f90
 mlprec/mld_c_base_solver_mod.f90
 mlprec/mld_c_diag_solver.f90
 mlprec/mld_c_gs_solver.f90
 mlprec/mld_c_id_solver.f90
 mlprec/mld_c_ilu_solver.f90
 mlprec/mld_c_jac_smoother.f90
 mlprec/mld_c_mumps_solver.F90
 mlprec/mld_c_onelev_mod.f90
 mlprec/mld_c_prec_type.f90
 mlprec/mld_c_slu_solver.F90
 mlprec/mld_c_sludist_solver.F90
 mlprec/mld_d_as_smoother.f90
 mlprec/mld_d_base_smoother_mod.f90
 mlprec/mld_d_base_solver_mod.f90
 mlprec/mld_d_diag_solver.f90
 mlprec/mld_d_gs_solver.f90
 mlprec/mld_d_id_solver.f90
 mlprec/mld_d_ilu_solver.f90
 mlprec/mld_d_jac_smoother.f90
 mlprec/mld_d_mumps_solver.F90
 mlprec/mld_d_onelev_mod.f90
 mlprec/mld_d_prec_type.f90
 mlprec/mld_d_slu_solver.F90
 mlprec/mld_d_sludist_solver.F90
 mlprec/mld_d_umf_solver.F90
 mlprec/mld_s_as_smoother.f90
 mlprec/mld_s_base_smoother_mod.f90
 mlprec/mld_s_base_solver_mod.f90
 mlprec/mld_s_diag_solver.f90
 mlprec/mld_s_gs_solver.f90
 mlprec/mld_s_id_solver.f90
 mlprec/mld_s_ilu_solver.f90
 mlprec/mld_s_jac_smoother.f90
 mlprec/mld_s_mumps_solver.F90
 mlprec/mld_s_onelev_mod.f90
 mlprec/mld_s_prec_type.f90
 mlprec/mld_s_slu_solver.F90
 mlprec/mld_s_sludist_solver.F90
 mlprec/mld_z_as_smoother.f90
 mlprec/mld_z_base_smoother_mod.f90
 mlprec/mld_z_base_solver_mod.f90
 mlprec/mld_z_diag_solver.f90
 mlprec/mld_z_gs_solver.f90
 mlprec/mld_z_id_solver.f90
 mlprec/mld_z_ilu_solver.f90
 mlprec/mld_z_jac_smoother.f90
 mlprec/mld_z_mumps_solver.F90
 mlprec/mld_z_onelev_mod.f90
 mlprec/mld_z_prec_type.f90
 mlprec/mld_z_slu_solver.F90
 mlprec/mld_z_sludist_solver.F90
 mlprec/mld_z_umf_solver.F90
 tests/pdegen/Makefile
 tests/pdegen/mld_d_pde2d.f90
 tests/pdegen/mld_d_pde3d.f90
 tests/pdegen/mld_s_pde2d.f90
 tests/pdegen/mld_s_pde3d.f90

Further merge changes from fixprec branch.
This commit is contained in:
Salvatore Filippone
2017-04-15 20:05:07 +00:00
parent 7cd509730b
commit a28f9ff872
202 changed files with 6405 additions and 11194 deletions
Download Patch File Download Diff File Expand all files Collapse all files
configure
Vendored
+2697 -5867
View File
File diff suppressed because it is too large Load Diff
configure.ac
+1 -1
View File
@@ -672,7 +672,7 @@ if test "x$pac_cv_status_file" != "xNONE"; then
COMPILERULES='';
else
COMPILERULES='
FLINK=$(MPF90)
FLINK=$(MPFC)
# These should be portable rules, arent they?
.c.o:
mlprec/Makefile
+2 -2
View File
@@ -14,7 +14,7 @@ DMODOBJS=mld_d_prec_type.o mld_d_ilu_fact_mod.o \
SMODOBJS=mld_s_prec_type.o mld_s_ilu_fact_mod.o \
mld_s_inner_mod.o mld_s_ilu_solver.o mld_s_diag_solver.o mld_s_jac_smoother.o mld_s_as_smoother.o \
mld_s_slu_solver.o mld_s_sludist_solver.o mld_s_id_solver.o\
mld_s_slu_solver.o mld_s_id_solver.o\
mld_s_base_solver_mod.o mld_s_base_smoother_mod.o mld_s_onelev_mod.o \
mld_s_gs_solver.o mld_s_mumps_solver.o
@@ -26,7 +26,7 @@ ZMODOBJS=mld_z_prec_type.o mld_z_ilu_fact_mod.o \
CMODOBJS=mld_c_prec_type.o mld_c_ilu_fact_mod.o \
mld_c_inner_mod.o mld_c_ilu_solver.o mld_c_diag_solver.o mld_c_jac_smoother.o mld_c_as_smoother.o \
mld_c_slu_solver.o mld_c_sludist_solver.o mld_c_id_solver.o\
mld_c_slu_solver.o mld_c_id_solver.o\
mld_c_base_solver_mod.o mld_c_base_smoother_mod.o mld_c_onelev_mod.o \
mld_c_gs_solver.o mld_c_mumps_solver.o
mlprec/impl/Makefile
+1 -1
View File
@@ -18,7 +18,7 @@ CMPFOBJS=mld_caggrmat_nosmth_asb.o mld_caggrmat_smth_asb.o mld_caggrmat_minnrg_a
MPFOBJS=$(SMPFOBJS) $(DMPFOBJS) $(CMPFOBJS) $(ZMPFOBJS)
MPCOBJS=mld_sslud_interface.o mld_dslud_interface.o mld_cslud_interface.o mld_zslud_interface.o
MPCOBJS=mld_dslud_interface.o mld_zslud_interface.o
DINNEROBJS= mld_dmlprec_bld.o \
mlprec/impl/level/mld_c_base_onelev_build.f90
+2 -4
View File
@@ -91,18 +91,16 @@ subroutine mld_c_base_onelev_build(lv,info,amold,vmold,imold)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
call mld_check_def(lv%parms%sweeps,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call mld_check_def(lv%parms%sweeps_pre,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call mld_check_def(lv%parms%sweeps_post,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call lv%sm%build(lv%base_a,lv%base_desc,&
& 'F',info,amold=amold,vmold=vmold,imold=imold)
& info,amold=amold,vmold=vmold,imold=imold)
if (info == 0) then
if (allocated(lv%sm2a)) then
call lv%sm2a%build(lv%base_a,lv%base_desc,'F',info,&
call lv%sm2a%build(lv%base_a,lv%base_desc,info,&
& amold=amold,vmold=vmold,imold=imold)
lv%sm2 => lv%sm2a
else
mlprec/impl/level/mld_c_base_onelev_check.f90
+8 -3
View File
@@ -53,14 +53,11 @@ subroutine mld_c_base_onelev_check(lv,info)
call psb_erractionsave(err_act)
info = psb_success_
call mld_check_def(lv%parms%sweeps,&
& 'Jacobi sweeps',ione,is_int_non_negative)
call mld_check_def(lv%parms%sweeps_pre,&
& 'Jacobi sweeps',ione,is_int_non_negative)
call mld_check_def(lv%parms%sweeps_post,&
& 'Jacobi sweeps',ione,is_int_non_negative)
if (allocated(lv%sm)) then
call lv%sm%check(info)
else
@@ -69,6 +66,14 @@ subroutine mld_c_base_onelev_check(lv,info)
goto 9999
end if
if (allocated(lv%sm2a)) then
call lv%sm2a%check(info)
else
info=3111
call psb_errpush(info,name)
goto 9999
end if
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
mlprec/impl/level/mld_c_base_onelev_csetc.f90
+8 -9
View File
@@ -71,24 +71,23 @@ subroutine mld_c_base_onelev_csetc(lv,what,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end if
mlprec/impl/level/mld_c_base_onelev_cseti.F90
+26 -46
View File
@@ -47,9 +47,6 @@ subroutine mld_c_base_onelev_cseti(lv,what,val,info,pos)
use mld_c_ilu_solver
use mld_c_id_solver
use mld_c_gs_solver
#if defined(HAVE_SLUDIST_)
use mld_c_sludist_solver
#endif
#if defined(HAVE_SLU_)
use mld_c_slu_solver
#endif
@@ -76,9 +73,6 @@ subroutine mld_c_base_onelev_cseti(lv,what,val,info,pos)
type(mld_c_id_solver_type) :: mld_c_id_solver_mold
type(mld_c_gs_solver_type) :: mld_c_gs_solver_mold
type(mld_c_bwgs_solver_type) :: mld_c_bwgs_solver_mold
#if defined(HAVE_SLUDIST_)
type(mld_c_sludist_solver_type) :: mld_c_sludist_solver_mold
#endif
#if defined(HAVE_SLU_)
type(mld_c_slu_solver_type) :: mld_c_slu_solver_mold
#endif
@@ -96,10 +90,10 @@ subroutine mld_c_base_onelev_cseti(lv,what,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case (psb_toupper(what))
@@ -132,9 +126,10 @@ subroutine mld_c_base_onelev_cseti(lv,what,val,info,pos)
! Do nothing and hope for the best :)
!
end select
if (ipos_==mld_pre_smooth_) then
if ((ipos_==mld_pre_smooth_).or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) call lv%sm%default()
else if (ipos_==mld_post_smooth_) then
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm2a)) call lv%sm2a%default()
end if
@@ -156,24 +151,17 @@ subroutine mld_c_base_onelev_cseti(lv,what,val,info,pos)
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
call lv%set(mld_c_ilu_solver_mold,info,pos=pos)
if (info == 0) then
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
call lv%sm%sv%set('SUB_SOLVE',val,info)
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end if
#ifdef HAVE_SLU_
case (mld_slu_)
call lv%set(mld_c_slu_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_SLUDIST_
case (mld_sludist_)
call lv%set(mld_c_sludist_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_MUMPS_
case (mld_mumps_)
call lv%set(mld_c_mumps_solver_mold,info,pos=pos)
@@ -186,34 +174,29 @@ subroutine mld_c_base_onelev_cseti(lv,what,val,info,pos)
case ('SMOOTHER_SWEEPS')
lv%parms%sweeps = val
lv%parms%sweeps_pre = val
lv%parms%sweeps_post = val
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) &
& lv%parms%sweeps_pre = val
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_)) &
& lv%parms%sweeps_post = val
case ('SMOOTHER_SWEEPS_PRE')
lv%parms%sweeps_pre = val
case ('ML_CYCLE')
lv%parms%ml_cycle = val
case ('SMOOTHER_SWEEPS_POST')
lv%parms%sweeps_post = val
case ('ML_TYPE')
lv%parms%ml_type = val
case ('AGGR_ALG')
lv%parms%aggr_alg = val
case ('PAR_AGGR_ALG')
lv%parms%par_aggr_alg = val
case ('AGGR_ORD')
lv%parms%aggr_ord = val
case ('AGGR_KIND')
lv%parms%aggr_kind = val
case ('AGGR_TYPE')
lv%parms%aggr_type = val
case ('AGGR_PROL')
lv%parms%aggr_prol = val
case ('COARSE_MAT')
lv%parms%coarse_mat = val
case ('SMOOTHER_POS')
lv%parms%smoother_pos = val
case ('AGGR_OMEGA_ALG')
lv%parms%aggr_omega_alg= val
@@ -227,19 +210,16 @@ subroutine mld_c_base_onelev_cseti(lv,what,val,info,pos)
lv%parms%coarse_solve = val
case default
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end select
if (info /= psb_success_) goto 9999
mlprec/impl/level/mld_c_base_onelev_csetr.f90
+7 -12
View File
@@ -67,9 +67,6 @@ subroutine mld_c_base_onelev_csetr(lv,what,val,info,pos)
case ('AGGR_THRESH')
lv%parms%aggr_thresh = val
case ('AGGR_SCALE')
lv%parms%aggr_scale = val
case default
if (present(pos)) then
@@ -79,24 +76,22 @@ subroutine mld_c_base_onelev_csetr(lv,what,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end select
if (info /= psb_success_) goto 9999
mlprec/impl/level/mld_c_base_onelev_setc.f90
+14 -15
View File
@@ -38,7 +38,7 @@
!
!
subroutine mld_c_base_onelev_setc(lv,what,val,info,pos)
use psb_base_mod
use mld_c_onelev_mod, mld_protect_name => mld_c_base_onelev_setc
@@ -63,7 +63,7 @@ subroutine mld_c_base_onelev_setc(lv,what,val,info,pos)
if (ival >= 0) then
call lv%set(what,ival,info,pos=pos)
else
if (present(pos)) then
select case(psb_toupper(trim(pos)))
case('PRE')
@@ -71,32 +71,31 @@ subroutine mld_c_base_onelev_setc(lv,what,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end if
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine mld_c_base_onelev_setc
mlprec/impl/level/mld_c_base_onelev_seti.F90
+26 -46
View File
@@ -47,9 +47,6 @@ subroutine mld_c_base_onelev_seti(lv,what,val,info,pos)
use mld_c_ilu_solver
use mld_c_id_solver
use mld_c_gs_solver
#if defined(HAVE_SLUDIST_)
use mld_c_sludist_solver
#endif
#if defined(HAVE_SLU_)
use mld_c_slu_solver
#endif
@@ -76,9 +73,6 @@ subroutine mld_c_base_onelev_seti(lv,what,val,info,pos)
type(mld_c_id_solver_type) :: mld_c_id_solver_mold
type(mld_c_gs_solver_type) :: mld_c_gs_solver_mold
type(mld_c_bwgs_solver_type) :: mld_c_bwgs_solver_mold
#if defined(HAVE_SLUDIST_)
type(mld_c_sludist_solver_type) :: mld_c_sludist_solver_mold
#endif
#if defined(HAVE_SLU_)
type(mld_c_slu_solver_type) :: mld_c_slu_solver_mold
#endif
@@ -95,10 +89,10 @@ subroutine mld_c_base_onelev_seti(lv,what,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case (what)
@@ -133,9 +127,10 @@ subroutine mld_c_base_onelev_seti(lv,what,val,info,pos)
! Do nothing and hope for the best :)
!
end select
if (ipos_==mld_pre_smooth_) then
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) call lv%sm%default()
else if (ipos_==mld_post_smooth_) then
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) call lv%sm2a%default()
end if
@@ -157,24 +152,17 @@ subroutine mld_c_base_onelev_seti(lv,what,val,info,pos)
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
call lv%set(mld_c_ilu_solver_mold,info,pos=pos)
if (info == 0) then
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
call lv%sm%sv%set('SUB_SOLVE',val,info)
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end if
#ifdef HAVE_SLU_
case (mld_slu_)
call lv%set(mld_c_slu_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_SLUDIST_
case (mld_sludist_)
call lv%set(mld_c_sludist_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_MUMPS_
case (mld_mumps_)
call lv%set(mld_c_mumps_solver_mold,info,pos=pos)
@@ -186,34 +174,29 @@ subroutine mld_c_base_onelev_seti(lv,what,val,info,pos)
end select
case (mld_smoother_sweeps_)
lv%parms%sweeps = val
lv%parms%sweeps_pre = val
lv%parms%sweeps_post = val
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) &
& lv%parms%sweeps_pre = val
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_)) &
& lv%parms%sweeps_post = val
case (mld_smoother_sweeps_pre_)
lv%parms%sweeps_pre = val
case (mld_ml_cycle_)
lv%parms%ml_cycle = val
case (mld_smoother_sweeps_post_)
lv%parms%sweeps_post = val
case (mld_ml_type_)
lv%parms%ml_type = val
case (mld_aggr_alg_)
lv%parms%aggr_alg = val
case (mld_par_aggr_alg_)
lv%parms%par_aggr_alg = val
case (mld_aggr_ord_)
lv%parms%aggr_ord = val
case (mld_aggr_kind_)
lv%parms%aggr_kind = val
case (mld_aggr_type_)
lv%parms%aggr_type = val
case (mld_aggr_prol_)
lv%parms%aggr_prol = val
case (mld_coarse_mat_)
lv%parms%coarse_mat = val
case (mld_smoother_pos_)
lv%parms%smoother_pos = val
case (mld_aggr_omega_alg_)
lv%parms%aggr_omega_alg= val
@@ -228,19 +211,16 @@ subroutine mld_c_base_onelev_seti(lv,what,val,info,pos)
case default
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end select
if (info /= psb_success_) goto 9999
mlprec/impl/level/mld_c_base_onelev_setr.f90
+9 -12
View File
@@ -67,9 +67,6 @@ subroutine mld_c_base_onelev_setr(lv,what,val,info,pos)
case (mld_aggr_thresh_)
lv%parms%aggr_thresh = val
case (mld_aggr_scale_)
lv%parms%aggr_scale = val
case default
if (present(pos)) then
@@ -79,24 +76,24 @@ subroutine mld_c_base_onelev_setr(lv,what,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end select
if (info /= psb_success_) goto 9999
mlprec/impl/level/mld_c_base_onelev_setsm.F90
+13 -5
View File
@@ -63,14 +63,22 @@ subroutine mld_c_base_onelev_setsm(lev,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
if (ipos_ == mld_both_smooth_) then
if (allocated(lev%sm2a)) then
call lev%sm2a%free(info)
deallocate(lev%sm2a, stat=info)
lev%sm2 => null()
end if
end if
select case(ipos_)
case(mld_pre_smooth_)
case(mld_pre_smooth_, mld_both_smooth_)
if (allocated(lev%sm)) then
if (.not.same_type_as(lev%sm,val)) then
call lev%sm%free(info)
@@ -85,7 +93,7 @@ subroutine mld_c_base_onelev_setsm(lev,val,info,pos)
#endif
end if
call lev%sm%default()
lev%sm2 => lev%sm
if (ipos_ == mld_both_smooth_) lev%sm2 => lev%sm
case(mld_post_smooth_)
if (allocated(lev%sm2a)) then
if (.not.same_type_as(lev%sm2a,val)) then
mlprec/impl/level/mld_c_base_onelev_setsv.F90
+16 -7
View File
@@ -63,14 +63,13 @@ subroutine mld_c_base_onelev_setsv(lev,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_ == mld_pre_smooth_).or.(ipos_ == mld_both_smooth_)) then
if (allocated(lev%sm)) then
if (allocated(lev%sm%sv)) then
if (.not.same_type_as(lev%sm%sv,val)) then
@@ -103,8 +102,18 @@ subroutine mld_c_base_onelev_setsv(lev,val,info,pos)
return
end if
case(mld_post_smooth_)
end if
!
! If POS was not specified and therefore we have mld_both_smooth_
! we need to update sm2a *only* if it was already allocated,
! otherwise it is not needed (since we have just fixed %sm in the
! pre section).
!
if ((ipos_ == mld_post_smooth_).or. &
((ipos_ == mld_both_smooth_).and.(allocated(lev%sm2a)))) then
if (allocated(lev%sm2a)) then
if (allocated(lev%sm2a%sv)) then
@@ -139,7 +148,7 @@ subroutine mld_c_base_onelev_setsv(lev,val,info,pos)
end if
end select
end if
end subroutine mld_c_base_onelev_setsv
mlprec/impl/level/mld_d_base_onelev_build.f90
+2 -4
View File
@@ -91,18 +91,16 @@ subroutine mld_d_base_onelev_build(lv,info,amold,vmold,imold)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
call mld_check_def(lv%parms%sweeps,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call mld_check_def(lv%parms%sweeps_pre,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call mld_check_def(lv%parms%sweeps_post,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call lv%sm%build(lv%base_a,lv%base_desc,&
& 'F',info,amold=amold,vmold=vmold,imold=imold)
& info,amold=amold,vmold=vmold,imold=imold)
if (info == 0) then
if (allocated(lv%sm2a)) then
call lv%sm2a%build(lv%base_a,lv%base_desc,'F',info,&
call lv%sm2a%build(lv%base_a,lv%base_desc,info,&
& amold=amold,vmold=vmold,imold=imold)
lv%sm2 => lv%sm2a
else
mlprec/impl/level/mld_d_base_onelev_check.f90
+8 -3
View File
@@ -53,14 +53,11 @@ subroutine mld_d_base_onelev_check(lv,info)
call psb_erractionsave(err_act)
info = psb_success_
call mld_check_def(lv%parms%sweeps,&
& 'Jacobi sweeps',ione,is_int_non_negative)
call mld_check_def(lv%parms%sweeps_pre,&
& 'Jacobi sweeps',ione,is_int_non_negative)
call mld_check_def(lv%parms%sweeps_post,&
& 'Jacobi sweeps',ione,is_int_non_negative)
if (allocated(lv%sm)) then
call lv%sm%check(info)
else
@@ -69,6 +66,14 @@ subroutine mld_d_base_onelev_check(lv,info)
goto 9999
end if
if (allocated(lv%sm2a)) then
call lv%sm2a%check(info)
else
info=3111
call psb_errpush(info,name)
goto 9999
end if
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
mlprec/impl/level/mld_d_base_onelev_csetc.f90
+8 -9
View File
@@ -71,24 +71,23 @@ subroutine mld_d_base_onelev_csetc(lv,what,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end if
mlprec/impl/level/mld_d_base_onelev_cseti.F90
+30 -40
View File
@@ -102,10 +102,10 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case (psb_toupper(what))
@@ -138,9 +138,10 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos)
! Do nothing and hope for the best :)
!
end select
if (ipos_==mld_pre_smooth_) then
if ((ipos_==mld_pre_smooth_).or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) call lv%sm%default()
else if (ipos_==mld_post_smooth_) then
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm2a)) call lv%sm2a%default()
end if
@@ -162,28 +163,25 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos)
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
call lv%set(mld_d_ilu_solver_mold,info,pos=pos)
if (info == 0) then
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
call lv%sm%sv%set('SUB_SOLVE',val,info)
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end if
#ifdef HAVE_SLU_
case (mld_slu_)
call lv%set(mld_d_slu_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_SLUDIST_
case (mld_sludist_)
call lv%set(mld_d_sludist_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_MUMPS_
case (mld_mumps_)
call lv%set(mld_d_mumps_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_SLUDIST_
case (mld_sludist_)
call lv%set(mld_d_sludist_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_UMF_
case (mld_umf_)
call lv%set(mld_d_umf_solver_mold,info,pos=pos)
@@ -196,34 +194,29 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos)
case ('SMOOTHER_SWEEPS')
lv%parms%sweeps = val
lv%parms%sweeps_pre = val
lv%parms%sweeps_post = val
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) &
& lv%parms%sweeps_pre = val
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_)) &
& lv%parms%sweeps_post = val
case ('SMOOTHER_SWEEPS_PRE')
lv%parms%sweeps_pre = val
case ('ML_CYCLE')
lv%parms%ml_cycle = val
case ('SMOOTHER_SWEEPS_POST')
lv%parms%sweeps_post = val
case ('ML_TYPE')
lv%parms%ml_type = val
case ('AGGR_ALG')
lv%parms%aggr_alg = val
case ('PAR_AGGR_ALG')
lv%parms%par_aggr_alg = val
case ('AGGR_ORD')
lv%parms%aggr_ord = val
case ('AGGR_KIND')
lv%parms%aggr_kind = val
case ('AGGR_TYPE')
lv%parms%aggr_type = val
case ('AGGR_PROL')
lv%parms%aggr_prol = val
case ('COARSE_MAT')
lv%parms%coarse_mat = val
case ('SMOOTHER_POS')
lv%parms%smoother_pos = val
case ('AGGR_OMEGA_ALG')
lv%parms%aggr_omega_alg= val
@@ -237,19 +230,16 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos)
lv%parms%coarse_solve = val
case default
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end select
if (info /= psb_success_) goto 9999
mlprec/impl/level/mld_d_base_onelev_csetr.f90
+7 -12
View File
@@ -67,9 +67,6 @@ subroutine mld_d_base_onelev_csetr(lv,what,val,info,pos)
case ('AGGR_THRESH')
lv%parms%aggr_thresh = val
case ('AGGR_SCALE')
lv%parms%aggr_scale = val
case default
if (present(pos)) then
@@ -79,24 +76,22 @@ subroutine mld_d_base_onelev_csetr(lv,what,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end select
if (info /= psb_success_) goto 9999
mlprec/impl/level/mld_d_base_onelev_setc.f90
+14 -15
View File
@@ -38,7 +38,7 @@
!
!
subroutine mld_d_base_onelev_setc(lv,what,val,info,pos)
use psb_base_mod
use mld_d_onelev_mod, mld_protect_name => mld_d_base_onelev_setc
@@ -63,7 +63,7 @@ subroutine mld_d_base_onelev_setc(lv,what,val,info,pos)
if (ival >= 0) then
call lv%set(what,ival,info,pos=pos)
else
if (present(pos)) then
select case(psb_toupper(trim(pos)))
case('PRE')
@@ -71,32 +71,31 @@ subroutine mld_d_base_onelev_setc(lv,what,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end if
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine mld_d_base_onelev_setc
mlprec/impl/level/mld_d_base_onelev_seti.F90
+30 -40
View File
@@ -101,10 +101,10 @@ subroutine mld_d_base_onelev_seti(lv,what,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case (what)
@@ -139,9 +139,10 @@ subroutine mld_d_base_onelev_seti(lv,what,val,info,pos)
! Do nothing and hope for the best :)
!
end select
if (ipos_==mld_pre_smooth_) then
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) call lv%sm%default()
else if (ipos_==mld_post_smooth_) then
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) call lv%sm2a%default()
end if
@@ -163,28 +164,25 @@ subroutine mld_d_base_onelev_seti(lv,what,val,info,pos)
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
call lv%set(mld_d_ilu_solver_mold,info,pos=pos)
if (info == 0) then
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
call lv%sm%sv%set('SUB_SOLVE',val,info)
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end if
#ifdef HAVE_SLU_
case (mld_slu_)
call lv%set(mld_d_slu_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_SLUDIST_
case (mld_sludist_)
call lv%set(mld_d_sludist_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_MUMPS_
case (mld_mumps_)
call lv%set(mld_d_mumps_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_SLUDIST_
case (mld_sludist_)
call lv%set(mld_d_sludist_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_UMF_
case (mld_umf_)
call lv%set(mld_d_umf_solver_mold,info,pos=pos)
@@ -196,34 +194,29 @@ subroutine mld_d_base_onelev_seti(lv,what,val,info,pos)
end select
case (mld_smoother_sweeps_)
lv%parms%sweeps = val
lv%parms%sweeps_pre = val
lv%parms%sweeps_post = val
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) &
& lv%parms%sweeps_pre = val
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_)) &
& lv%parms%sweeps_post = val
case (mld_smoother_sweeps_pre_)
lv%parms%sweeps_pre = val
case (mld_ml_cycle_)
lv%parms%ml_cycle = val
case (mld_smoother_sweeps_post_)
lv%parms%sweeps_post = val
case (mld_ml_type_)
lv%parms%ml_type = val
case (mld_aggr_alg_)
lv%parms%aggr_alg = val
case (mld_par_aggr_alg_)
lv%parms%par_aggr_alg = val
case (mld_aggr_ord_)
lv%parms%aggr_ord = val
case (mld_aggr_kind_)
lv%parms%aggr_kind = val
case (mld_aggr_type_)
lv%parms%aggr_type = val
case (mld_aggr_prol_)
lv%parms%aggr_prol = val
case (mld_coarse_mat_)
lv%parms%coarse_mat = val
case (mld_smoother_pos_)
lv%parms%smoother_pos = val
case (mld_aggr_omega_alg_)
lv%parms%aggr_omega_alg= val
@@ -238,19 +231,16 @@ subroutine mld_d_base_onelev_seti(lv,what,val,info,pos)
case default
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end select
if (info /= psb_success_) goto 9999
mlprec/impl/level/mld_d_base_onelev_setr.f90
+9 -12
View File
@@ -67,9 +67,6 @@ subroutine mld_d_base_onelev_setr(lv,what,val,info,pos)
case (mld_aggr_thresh_)
lv%parms%aggr_thresh = val
case (mld_aggr_scale_)
lv%parms%aggr_scale = val
case default
if (present(pos)) then
@@ -79,24 +76,24 @@ subroutine mld_d_base_onelev_setr(lv,what,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end select
if (info /= psb_success_) goto 9999
mlprec/impl/level/mld_d_base_onelev_setsm.F90
+13 -5
View File
@@ -63,14 +63,22 @@ subroutine mld_d_base_onelev_setsm(lev,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
if (ipos_ == mld_both_smooth_) then
if (allocated(lev%sm2a)) then
call lev%sm2a%free(info)
deallocate(lev%sm2a, stat=info)
lev%sm2 => null()
end if
end if
select case(ipos_)
case(mld_pre_smooth_)
case(mld_pre_smooth_, mld_both_smooth_)
if (allocated(lev%sm)) then
if (.not.same_type_as(lev%sm,val)) then
call lev%sm%free(info)
@@ -85,7 +93,7 @@ subroutine mld_d_base_onelev_setsm(lev,val,info,pos)
#endif
end if
call lev%sm%default()
lev%sm2 => lev%sm
if (ipos_ == mld_both_smooth_) lev%sm2 => lev%sm
case(mld_post_smooth_)
if (allocated(lev%sm2a)) then
if (.not.same_type_as(lev%sm2a,val)) then
mlprec/impl/level/mld_d_base_onelev_setsv.F90
+16 -7
View File
@@ -63,14 +63,13 @@ subroutine mld_d_base_onelev_setsv(lev,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_ == mld_pre_smooth_).or.(ipos_ == mld_both_smooth_)) then
if (allocated(lev%sm)) then
if (allocated(lev%sm%sv)) then
if (.not.same_type_as(lev%sm%sv,val)) then
@@ -103,8 +102,18 @@ subroutine mld_d_base_onelev_setsv(lev,val,info,pos)
return
end if
case(mld_post_smooth_)
end if
!
! If POS was not specified and therefore we have mld_both_smooth_
! we need to update sm2a *only* if it was already allocated,
! otherwise it is not needed (since we have just fixed %sm in the
! pre section).
!
if ((ipos_ == mld_post_smooth_).or. &
((ipos_ == mld_both_smooth_).and.(allocated(lev%sm2a)))) then
if (allocated(lev%sm2a)) then
if (allocated(lev%sm2a%sv)) then
@@ -139,7 +148,7 @@ subroutine mld_d_base_onelev_setsv(lev,val,info,pos)
end if
end select
end if
end subroutine mld_d_base_onelev_setsv
mlprec/impl/level/mld_s_base_onelev_build.f90
+2 -4
View File
@@ -91,18 +91,16 @@ subroutine mld_s_base_onelev_build(lv,info,amold,vmold,imold)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
call mld_check_def(lv%parms%sweeps,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call mld_check_def(lv%parms%sweeps_pre,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call mld_check_def(lv%parms%sweeps_post,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call lv%sm%build(lv%base_a,lv%base_desc,&
& 'F',info,amold=amold,vmold=vmold,imold=imold)
& info,amold=amold,vmold=vmold,imold=imold)
if (info == 0) then
if (allocated(lv%sm2a)) then
call lv%sm2a%build(lv%base_a,lv%base_desc,'F',info,&
call lv%sm2a%build(lv%base_a,lv%base_desc,info,&
& amold=amold,vmold=vmold,imold=imold)
lv%sm2 => lv%sm2a
else
mlprec/impl/level/mld_s_base_onelev_check.f90
+8 -3
View File
@@ -53,14 +53,11 @@ subroutine mld_s_base_onelev_check(lv,info)
call psb_erractionsave(err_act)
info = psb_success_
call mld_check_def(lv%parms%sweeps,&
& 'Jacobi sweeps',ione,is_int_non_negative)
call mld_check_def(lv%parms%sweeps_pre,&
& 'Jacobi sweeps',ione,is_int_non_negative)
call mld_check_def(lv%parms%sweeps_post,&
& 'Jacobi sweeps',ione,is_int_non_negative)
if (allocated(lv%sm)) then
call lv%sm%check(info)
else
@@ -69,6 +66,14 @@ subroutine mld_s_base_onelev_check(lv,info)
goto 9999
end if
if (allocated(lv%sm2a)) then
call lv%sm2a%check(info)
else
info=3111
call psb_errpush(info,name)
goto 9999
end if
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
mlprec/impl/level/mld_s_base_onelev_csetc.f90
+8 -9
View File
@@ -71,24 +71,23 @@ subroutine mld_s_base_onelev_csetc(lv,what,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end if
mlprec/impl/level/mld_s_base_onelev_cseti.F90
+26 -46
View File
@@ -47,9 +47,6 @@ subroutine mld_s_base_onelev_cseti(lv,what,val,info,pos)
use mld_s_ilu_solver
use mld_s_id_solver
use mld_s_gs_solver
#if defined(HAVE_SLUDIST_)
use mld_s_sludist_solver
#endif
#if defined(HAVE_SLU_)
use mld_s_slu_solver
#endif
@@ -76,9 +73,6 @@ subroutine mld_s_base_onelev_cseti(lv,what,val,info,pos)
type(mld_s_id_solver_type) :: mld_s_id_solver_mold
type(mld_s_gs_solver_type) :: mld_s_gs_solver_mold
type(mld_s_bwgs_solver_type) :: mld_s_bwgs_solver_mold
#if defined(HAVE_SLUDIST_)
type(mld_s_sludist_solver_type) :: mld_s_sludist_solver_mold
#endif
#if defined(HAVE_SLU_)
type(mld_s_slu_solver_type) :: mld_s_slu_solver_mold
#endif
@@ -96,10 +90,10 @@ subroutine mld_s_base_onelev_cseti(lv,what,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case (psb_toupper(what))
@@ -132,9 +126,10 @@ subroutine mld_s_base_onelev_cseti(lv,what,val,info,pos)
! Do nothing and hope for the best :)
!
end select
if (ipos_==mld_pre_smooth_) then
if ((ipos_==mld_pre_smooth_).or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) call lv%sm%default()
else if (ipos_==mld_post_smooth_) then
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm2a)) call lv%sm2a%default()
end if
@@ -156,24 +151,17 @@ subroutine mld_s_base_onelev_cseti(lv,what,val,info,pos)
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
call lv%set(mld_s_ilu_solver_mold,info,pos=pos)
if (info == 0) then
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
call lv%sm%sv%set('SUB_SOLVE',val,info)
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end if
#ifdef HAVE_SLU_
case (mld_slu_)
call lv%set(mld_s_slu_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_SLUDIST_
case (mld_sludist_)
call lv%set(mld_s_sludist_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_MUMPS_
case (mld_mumps_)
call lv%set(mld_s_mumps_solver_mold,info,pos=pos)
@@ -186,34 +174,29 @@ subroutine mld_s_base_onelev_cseti(lv,what,val,info,pos)
case ('SMOOTHER_SWEEPS')
lv%parms%sweeps = val
lv%parms%sweeps_pre = val
lv%parms%sweeps_post = val
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) &
& lv%parms%sweeps_pre = val
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_)) &
& lv%parms%sweeps_post = val
case ('SMOOTHER_SWEEPS_PRE')
lv%parms%sweeps_pre = val
case ('ML_CYCLE')
lv%parms%ml_cycle = val
case ('SMOOTHER_SWEEPS_POST')
lv%parms%sweeps_post = val
case ('ML_TYPE')
lv%parms%ml_type = val
case ('AGGR_ALG')
lv%parms%aggr_alg = val
case ('PAR_AGGR_ALG')
lv%parms%par_aggr_alg = val
case ('AGGR_ORD')
lv%parms%aggr_ord = val
case ('AGGR_KIND')
lv%parms%aggr_kind = val
case ('AGGR_TYPE')
lv%parms%aggr_type = val
case ('AGGR_PROL')
lv%parms%aggr_prol = val
case ('COARSE_MAT')
lv%parms%coarse_mat = val
case ('SMOOTHER_POS')
lv%parms%smoother_pos = val
case ('AGGR_OMEGA_ALG')
lv%parms%aggr_omega_alg= val
@@ -227,19 +210,16 @@ subroutine mld_s_base_onelev_cseti(lv,what,val,info,pos)
lv%parms%coarse_solve = val
case default
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end select
if (info /= psb_success_) goto 9999
mlprec/impl/level/mld_s_base_onelev_csetr.f90
+7 -12
View File
@@ -67,9 +67,6 @@ subroutine mld_s_base_onelev_csetr(lv,what,val,info,pos)
case ('AGGR_THRESH')
lv%parms%aggr_thresh = val
case ('AGGR_SCALE')
lv%parms%aggr_scale = val
case default
if (present(pos)) then
@@ -79,24 +76,22 @@ subroutine mld_s_base_onelev_csetr(lv,what,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end select
if (info /= psb_success_) goto 9999
mlprec/impl/level/mld_s_base_onelev_setc.f90
+14 -15
View File
@@ -38,7 +38,7 @@
!
!
subroutine mld_s_base_onelev_setc(lv,what,val,info,pos)
use psb_base_mod
use mld_s_onelev_mod, mld_protect_name => mld_s_base_onelev_setc
@@ -63,7 +63,7 @@ subroutine mld_s_base_onelev_setc(lv,what,val,info,pos)
if (ival >= 0) then
call lv%set(what,ival,info,pos=pos)
else
if (present(pos)) then
select case(psb_toupper(trim(pos)))
case('PRE')
@@ -71,32 +71,31 @@ subroutine mld_s_base_onelev_setc(lv,what,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end if
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine mld_s_base_onelev_setc
mlprec/impl/level/mld_s_base_onelev_seti.F90
+26 -46
View File
@@ -47,9 +47,6 @@ subroutine mld_s_base_onelev_seti(lv,what,val,info,pos)
use mld_s_ilu_solver
use mld_s_id_solver
use mld_s_gs_solver
#if defined(HAVE_SLUDIST_)
use mld_s_sludist_solver
#endif
#if defined(HAVE_SLU_)
use mld_s_slu_solver
#endif
@@ -76,9 +73,6 @@ subroutine mld_s_base_onelev_seti(lv,what,val,info,pos)
type(mld_s_id_solver_type) :: mld_s_id_solver_mold
type(mld_s_gs_solver_type) :: mld_s_gs_solver_mold
type(mld_s_bwgs_solver_type) :: mld_s_bwgs_solver_mold
#if defined(HAVE_SLUDIST_)
type(mld_s_sludist_solver_type) :: mld_s_sludist_solver_mold
#endif
#if defined(HAVE_SLU_)
type(mld_s_slu_solver_type) :: mld_s_slu_solver_mold
#endif
@@ -95,10 +89,10 @@ subroutine mld_s_base_onelev_seti(lv,what,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case (what)
@@ -133,9 +127,10 @@ subroutine mld_s_base_onelev_seti(lv,what,val,info,pos)
! Do nothing and hope for the best :)
!
end select
if (ipos_==mld_pre_smooth_) then
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) call lv%sm%default()
else if (ipos_==mld_post_smooth_) then
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) call lv%sm2a%default()
end if
@@ -157,24 +152,17 @@ subroutine mld_s_base_onelev_seti(lv,what,val,info,pos)
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
call lv%set(mld_s_ilu_solver_mold,info,pos=pos)
if (info == 0) then
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
call lv%sm%sv%set('SUB_SOLVE',val,info)
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end if
#ifdef HAVE_SLU_
case (mld_slu_)
call lv%set(mld_s_slu_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_SLUDIST_
case (mld_sludist_)
call lv%set(mld_s_sludist_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_MUMPS_
case (mld_mumps_)
call lv%set(mld_s_mumps_solver_mold,info,pos=pos)
@@ -186,34 +174,29 @@ subroutine mld_s_base_onelev_seti(lv,what,val,info,pos)
end select
case (mld_smoother_sweeps_)
lv%parms%sweeps = val
lv%parms%sweeps_pre = val
lv%parms%sweeps_post = val
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) &
& lv%parms%sweeps_pre = val
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_)) &
& lv%parms%sweeps_post = val
case (mld_smoother_sweeps_pre_)
lv%parms%sweeps_pre = val
case (mld_ml_cycle_)
lv%parms%ml_cycle = val
case (mld_smoother_sweeps_post_)
lv%parms%sweeps_post = val
case (mld_ml_type_)
lv%parms%ml_type = val
case (mld_aggr_alg_)
lv%parms%aggr_alg = val
case (mld_par_aggr_alg_)
lv%parms%par_aggr_alg = val
case (mld_aggr_ord_)
lv%parms%aggr_ord = val
case (mld_aggr_kind_)
lv%parms%aggr_kind = val
case (mld_aggr_type_)
lv%parms%aggr_type = val
case (mld_aggr_prol_)
lv%parms%aggr_prol = val
case (mld_coarse_mat_)
lv%parms%coarse_mat = val
case (mld_smoother_pos_)
lv%parms%smoother_pos = val
case (mld_aggr_omega_alg_)
lv%parms%aggr_omega_alg= val
@@ -228,19 +211,16 @@ subroutine mld_s_base_onelev_seti(lv,what,val,info,pos)
case default
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end select
if (info /= psb_success_) goto 9999
mlprec/impl/level/mld_s_base_onelev_setr.f90
+9 -12
View File
@@ -67,9 +67,6 @@ subroutine mld_s_base_onelev_setr(lv,what,val,info,pos)
case (mld_aggr_thresh_)
lv%parms%aggr_thresh = val
case (mld_aggr_scale_)
lv%parms%aggr_scale = val
case default
if (present(pos)) then
@@ -79,24 +76,24 @@ subroutine mld_s_base_onelev_setr(lv,what,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end select
if (info /= psb_success_) goto 9999
mlprec/impl/level/mld_s_base_onelev_setsm.F90
+13 -5
View File
@@ -63,14 +63,22 @@ subroutine mld_s_base_onelev_setsm(lev,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
if (ipos_ == mld_both_smooth_) then
if (allocated(lev%sm2a)) then
call lev%sm2a%free(info)
deallocate(lev%sm2a, stat=info)
lev%sm2 => null()
end if
end if
select case(ipos_)
case(mld_pre_smooth_)
case(mld_pre_smooth_, mld_both_smooth_)
if (allocated(lev%sm)) then
if (.not.same_type_as(lev%sm,val)) then
call lev%sm%free(info)
@@ -85,7 +93,7 @@ subroutine mld_s_base_onelev_setsm(lev,val,info,pos)
#endif
end if
call lev%sm%default()
lev%sm2 => lev%sm
if (ipos_ == mld_both_smooth_) lev%sm2 => lev%sm
case(mld_post_smooth_)
if (allocated(lev%sm2a)) then
if (.not.same_type_as(lev%sm2a,val)) then
mlprec/impl/level/mld_s_base_onelev_setsv.F90
+16 -7
View File
@@ -63,14 +63,13 @@ subroutine mld_s_base_onelev_setsv(lev,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_ == mld_pre_smooth_).or.(ipos_ == mld_both_smooth_)) then
if (allocated(lev%sm)) then
if (allocated(lev%sm%sv)) then
if (.not.same_type_as(lev%sm%sv,val)) then
@@ -103,8 +102,18 @@ subroutine mld_s_base_onelev_setsv(lev,val,info,pos)
return
end if
case(mld_post_smooth_)
end if
!
! If POS was not specified and therefore we have mld_both_smooth_
! we need to update sm2a *only* if it was already allocated,
! otherwise it is not needed (since we have just fixed %sm in the
! pre section).
!
if ((ipos_ == mld_post_smooth_).or. &
((ipos_ == mld_both_smooth_).and.(allocated(lev%sm2a)))) then
if (allocated(lev%sm2a)) then
if (allocated(lev%sm2a%sv)) then
@@ -139,7 +148,7 @@ subroutine mld_s_base_onelev_setsv(lev,val,info,pos)
end if
end select
end if
end subroutine mld_s_base_onelev_setsv
mlprec/impl/level/mld_z_base_onelev_build.f90
+2 -4
View File
@@ -91,18 +91,16 @@ subroutine mld_z_base_onelev_build(lv,info,amold,vmold,imold)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
call mld_check_def(lv%parms%sweeps,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call mld_check_def(lv%parms%sweeps_pre,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call mld_check_def(lv%parms%sweeps_post,&
& 'Jacobi sweeps',izero,is_int_non_negative)
call lv%sm%build(lv%base_a,lv%base_desc,&
& 'F',info,amold=amold,vmold=vmold,imold=imold)
& info,amold=amold,vmold=vmold,imold=imold)
if (info == 0) then
if (allocated(lv%sm2a)) then
call lv%sm2a%build(lv%base_a,lv%base_desc,'F',info,&
call lv%sm2a%build(lv%base_a,lv%base_desc,info,&
& amold=amold,vmold=vmold,imold=imold)
lv%sm2 => lv%sm2a
else
mlprec/impl/level/mld_z_base_onelev_check.f90
+8 -3
View File
@@ -53,14 +53,11 @@ subroutine mld_z_base_onelev_check(lv,info)
call psb_erractionsave(err_act)
info = psb_success_
call mld_check_def(lv%parms%sweeps,&
& 'Jacobi sweeps',ione,is_int_non_negative)
call mld_check_def(lv%parms%sweeps_pre,&
& 'Jacobi sweeps',ione,is_int_non_negative)
call mld_check_def(lv%parms%sweeps_post,&
& 'Jacobi sweeps',ione,is_int_non_negative)
if (allocated(lv%sm)) then
call lv%sm%check(info)
else
@@ -69,6 +66,14 @@ subroutine mld_z_base_onelev_check(lv,info)
goto 9999
end if
if (allocated(lv%sm2a)) then
call lv%sm2a%check(info)
else
info=3111
call psb_errpush(info,name)
goto 9999
end if
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
mlprec/impl/level/mld_z_base_onelev_csetc.f90
+8 -9
View File
@@ -71,24 +71,23 @@ subroutine mld_z_base_onelev_csetc(lv,what,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end if
mlprec/impl/level/mld_z_base_onelev_cseti.F90
+30 -40
View File
@@ -102,10 +102,10 @@ subroutine mld_z_base_onelev_cseti(lv,what,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case (psb_toupper(what))
@@ -138,9 +138,10 @@ subroutine mld_z_base_onelev_cseti(lv,what,val,info,pos)
! Do nothing and hope for the best :)
!
end select
if (ipos_==mld_pre_smooth_) then
if ((ipos_==mld_pre_smooth_).or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) call lv%sm%default()
else if (ipos_==mld_post_smooth_) then
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm2a)) call lv%sm2a%default()
end if
@@ -162,28 +163,25 @@ subroutine mld_z_base_onelev_cseti(lv,what,val,info,pos)
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
call lv%set(mld_z_ilu_solver_mold,info,pos=pos)
if (info == 0) then
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
call lv%sm%sv%set('SUB_SOLVE',val,info)
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end if
#ifdef HAVE_SLU_
case (mld_slu_)
call lv%set(mld_z_slu_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_SLUDIST_
case (mld_sludist_)
call lv%set(mld_z_sludist_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_MUMPS_
case (mld_mumps_)
call lv%set(mld_z_mumps_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_SLUDIST_
case (mld_sludist_)
call lv%set(mld_z_sludist_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_UMF_
case (mld_umf_)
call lv%set(mld_z_umf_solver_mold,info,pos=pos)
@@ -196,34 +194,29 @@ subroutine mld_z_base_onelev_cseti(lv,what,val,info,pos)
case ('SMOOTHER_SWEEPS')
lv%parms%sweeps = val
lv%parms%sweeps_pre = val
lv%parms%sweeps_post = val
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) &
& lv%parms%sweeps_pre = val
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_)) &
& lv%parms%sweeps_post = val
case ('SMOOTHER_SWEEPS_PRE')
lv%parms%sweeps_pre = val
case ('ML_CYCLE')
lv%parms%ml_cycle = val
case ('SMOOTHER_SWEEPS_POST')
lv%parms%sweeps_post = val
case ('ML_TYPE')
lv%parms%ml_type = val
case ('AGGR_ALG')
lv%parms%aggr_alg = val
case ('PAR_AGGR_ALG')
lv%parms%par_aggr_alg = val
case ('AGGR_ORD')
lv%parms%aggr_ord = val
case ('AGGR_KIND')
lv%parms%aggr_kind = val
case ('AGGR_TYPE')
lv%parms%aggr_type = val
case ('AGGR_PROL')
lv%parms%aggr_prol = val
case ('COARSE_MAT')
lv%parms%coarse_mat = val
case ('SMOOTHER_POS')
lv%parms%smoother_pos = val
case ('AGGR_OMEGA_ALG')
lv%parms%aggr_omega_alg= val
@@ -237,19 +230,16 @@ subroutine mld_z_base_onelev_cseti(lv,what,val,info,pos)
lv%parms%coarse_solve = val
case default
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end select
if (info /= psb_success_) goto 9999
mlprec/impl/level/mld_z_base_onelev_csetr.f90
+7 -12
View File
@@ -67,9 +67,6 @@ subroutine mld_z_base_onelev_csetr(lv,what,val,info,pos)
case ('AGGR_THRESH')
lv%parms%aggr_thresh = val
case ('AGGR_SCALE')
lv%parms%aggr_scale = val
case default
if (present(pos)) then
@@ -79,24 +76,22 @@ subroutine mld_z_base_onelev_csetr(lv,what,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end select
if (info /= psb_success_) goto 9999
mlprec/impl/level/mld_z_base_onelev_setc.f90
+14 -15
View File
@@ -38,7 +38,7 @@
!
!
subroutine mld_z_base_onelev_setc(lv,what,val,info,pos)
use psb_base_mod
use mld_z_onelev_mod, mld_protect_name => mld_z_base_onelev_setc
@@ -63,7 +63,7 @@ subroutine mld_z_base_onelev_setc(lv,what,val,info,pos)
if (ival >= 0) then
call lv%set(what,ival,info,pos=pos)
else
if (present(pos)) then
select case(psb_toupper(trim(pos)))
case('PRE')
@@ -71,32 +71,31 @@ subroutine mld_z_base_onelev_setc(lv,what,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end if
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine mld_z_base_onelev_setc
mlprec/impl/level/mld_z_base_onelev_seti.F90
+30 -40
View File
@@ -101,10 +101,10 @@ subroutine mld_z_base_onelev_seti(lv,what,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case (what)
@@ -139,9 +139,10 @@ subroutine mld_z_base_onelev_seti(lv,what,val,info,pos)
! Do nothing and hope for the best :)
!
end select
if (ipos_==mld_pre_smooth_) then
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) call lv%sm%default()
else if (ipos_==mld_post_smooth_) then
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) call lv%sm2a%default()
end if
@@ -163,28 +164,25 @@ subroutine mld_z_base_onelev_seti(lv,what,val,info,pos)
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
call lv%set(mld_z_ilu_solver_mold,info,pos=pos)
if (info == 0) then
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
call lv%sm%sv%set('SUB_SOLVE',val,info)
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end if
#ifdef HAVE_SLU_
case (mld_slu_)
call lv%set(mld_z_slu_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_SLUDIST_
case (mld_sludist_)
call lv%set(mld_z_sludist_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_MUMPS_
case (mld_mumps_)
call lv%set(mld_z_mumps_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_SLUDIST_
case (mld_sludist_)
call lv%set(mld_z_sludist_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_UMF_
case (mld_umf_)
call lv%set(mld_z_umf_solver_mold,info,pos=pos)
@@ -196,34 +194,29 @@ subroutine mld_z_base_onelev_seti(lv,what,val,info,pos)
end select
case (mld_smoother_sweeps_)
lv%parms%sweeps = val
lv%parms%sweeps_pre = val
lv%parms%sweeps_post = val
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) &
& lv%parms%sweeps_pre = val
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_)) &
& lv%parms%sweeps_post = val
case (mld_smoother_sweeps_pre_)
lv%parms%sweeps_pre = val
case (mld_ml_cycle_)
lv%parms%ml_cycle = val
case (mld_smoother_sweeps_post_)
lv%parms%sweeps_post = val
case (mld_ml_type_)
lv%parms%ml_type = val
case (mld_aggr_alg_)
lv%parms%aggr_alg = val
case (mld_par_aggr_alg_)
lv%parms%par_aggr_alg = val
case (mld_aggr_ord_)
lv%parms%aggr_ord = val
case (mld_aggr_kind_)
lv%parms%aggr_kind = val
case (mld_aggr_type_)
lv%parms%aggr_type = val
case (mld_aggr_prol_)
lv%parms%aggr_prol = val
case (mld_coarse_mat_)
lv%parms%coarse_mat = val
case (mld_smoother_pos_)
lv%parms%smoother_pos = val
case (mld_aggr_omega_alg_)
lv%parms%aggr_omega_alg= val
@@ -238,19 +231,16 @@ subroutine mld_z_base_onelev_seti(lv,what,val,info,pos)
case default
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end select
if (info /= psb_success_) goto 9999
mlprec/impl/level/mld_z_base_onelev_setr.f90
+9 -12
View File
@@ -67,9 +67,6 @@ subroutine mld_z_base_onelev_setr(lv,what,val,info,pos)
case (mld_aggr_thresh_)
lv%parms%aggr_thresh = val
case (mld_aggr_scale_)
lv%parms%aggr_scale = val
case default
if (present(pos)) then
@@ -79,24 +76,24 @@ subroutine mld_z_base_onelev_setr(lv,what,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_==mld_pre_smooth_) .or.(ipos_==mld_both_smooth_)) then
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
end if
if ((ipos_==mld_post_smooth_).or.(ipos_==mld_both_smooth_))then
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
end select
if (info /= psb_success_) goto 9999
mlprec/impl/level/mld_z_base_onelev_setsm.F90
+13 -5
View File
@@ -63,14 +63,22 @@ subroutine mld_z_base_onelev_setsm(lev,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
if (ipos_ == mld_both_smooth_) then
if (allocated(lev%sm2a)) then
call lev%sm2a%free(info)
deallocate(lev%sm2a, stat=info)
lev%sm2 => null()
end if
end if
select case(ipos_)
case(mld_pre_smooth_)
case(mld_pre_smooth_, mld_both_smooth_)
if (allocated(lev%sm)) then
if (.not.same_type_as(lev%sm,val)) then
call lev%sm%free(info)
@@ -85,7 +93,7 @@ subroutine mld_z_base_onelev_setsm(lev,val,info,pos)
#endif
end if
call lev%sm%default()
lev%sm2 => lev%sm
if (ipos_ == mld_both_smooth_) lev%sm2 => lev%sm
case(mld_post_smooth_)
if (allocated(lev%sm2a)) then
if (.not.same_type_as(lev%sm2a,val)) then
mlprec/impl/level/mld_z_base_onelev_setsv.F90
+16 -7
View File
@@ -63,14 +63,13 @@ subroutine mld_z_base_onelev_setsv(lev,val,info,pos)
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end select
else
ipos_ = mld_pre_smooth_
ipos_ = mld_both_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if ((ipos_ == mld_pre_smooth_).or.(ipos_ == mld_both_smooth_)) then
if (allocated(lev%sm)) then
if (allocated(lev%sm%sv)) then
if (.not.same_type_as(lev%sm%sv,val)) then
@@ -103,8 +102,18 @@ subroutine mld_z_base_onelev_setsv(lev,val,info,pos)
return
end if
case(mld_post_smooth_)
end if
!
! If POS was not specified and therefore we have mld_both_smooth_
! we need to update sm2a *only* if it was already allocated,
! otherwise it is not needed (since we have just fixed %sm in the
! pre section).
!
if ((ipos_ == mld_post_smooth_).or. &
((ipos_ == mld_both_smooth_).and.(allocated(lev%sm2a)))) then
if (allocated(lev%sm2a)) then
if (allocated(lev%sm2a%sv)) then
@@ -139,7 +148,7 @@ subroutine mld_z_base_onelev_setsv(lev,val,info,pos)
end if
end select
end if
end subroutine mld_z_base_onelev_setsv
mlprec/impl/mld_c_extprol_bld.f90
+14 -15
View File
@@ -154,10 +154,9 @@ subroutine mld_c_extprol_bld(a,desc_a,p,prolv,restrv,info,amold,vmold,imold)
! Check to ensure all procs have the same
!
newsz = -1
casize = p%coarse_aggr_size
mxplevs = p%max_prec_levs
mnaggratio = p%min_aggr_ratio
casize = p%coarse_aggr_size
mxplevs = p%max_levs
mnaggratio = p%min_cr_ratio
casize = p%min_coarse_size
iszv = size(p%precv)
nprolv = size(prolv)
nrestrv = size(restrv)
@@ -167,19 +166,19 @@ subroutine mld_c_extprol_bld(a,desc_a,p,prolv,restrv,info,amold,vmold,imold)
call psb_bcast(ictxt,mnaggratio)
call psb_bcast(ictxt,nprolv)
call psb_bcast(ictxt,nrestrv)
if (casize /= p%coarse_aggr_size) then
if (casize /= p%min_coarse_size) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent coarse_aggr_size')
call psb_errpush(info,name,a_err='Inconsistent min_coarse_size')
goto 9999
end if
if (mxplevs /= p%max_prec_levs) then
if (mxplevs /= p%max_levs) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent max_prec_levs')
call psb_errpush(info,name,a_err='Inconsistent max_levs')
goto 9999
end if
if (mnaggratio /= p%min_aggr_ratio) then
if (mnaggratio /= p%min_cr_ratio) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent min_aggr_ratio')
call psb_errpush(info,name,a_err='Inconsistent min_cr_ratio')
goto 9999
end if
if (iszv /= size(p%precv)) then
@@ -220,8 +219,8 @@ subroutine mld_c_extprol_bld(a,desc_a,p,prolv,restrv,info,amold,vmold,imold)
endif
!
nplevs = nrestrv + 1
p%max_prec_levs = nplevs
nplevs = nrestrv + 1
p%max_levs = nplevs
!
! Fixed number of levels.
@@ -366,9 +365,9 @@ contains
allocate(nlaggr(np),ilaggr(1))
nlaggr = 0
ilaggr = 0
p%parms%aggr_alg = mld_ext_aggr_
call mld_check_def(p%parms%ml_type,'Multilevel type',&
& mld_mult_ml_,is_legal_ml_type)
p%parms%par_aggr_alg = mld_ext_aggr_
call mld_check_def(p%parms%ml_cycle,'Multilevel cycle',&
& mld_mult_ml_,is_legal_ml_cycle)
call mld_check_def(p%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_legal_ml_coarse_mat)
mlprec/impl/mld_c_hierarchy_bld.f90
+19 -35
View File
@@ -78,19 +78,19 @@ subroutine mld_c_hierarchy_bld(a,desc_a,prec,info)
type(psb_desc_type), intent(inout), target :: desc_a
class(mld_cprec_type),intent(inout),target :: prec
integer(psb_ipk_), intent(out) :: info
!!$ character, intent(in), optional :: upd
! Local Variables
integer(psb_ipk_) :: ictxt, me,np
integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs, iaggsize
real(psb_spk_) :: mnaggratio, sizeratio, athresh, ascale, aomega
class(mld_c_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm, base_sm2, med_sm2, coarse_sm2
integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize,&
& nplevs, mxplevs, iaggsize
real(psb_spk_) :: mnaggratio, sizeratio, athresh, aomega
class(mld_c_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm, &
& base_sm2, med_sm2, coarse_sm2
type(mld_sml_parms) :: baseparms, medparms, coarseparms
integer(psb_ipk_), allocatable :: ilaggr(:), nlaggr(:)
type(psb_cspmat_type) :: op_prol
type(mld_c_onelev_type), allocatable :: tprecv(:)
integer(psb_ipk_) :: int_err(5)
character :: upd_
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name, ch_err
@@ -111,21 +111,6 @@ subroutine mld_c_hierarchy_bld(a,desc_a,prec,info)
& write(debug_unit,*) me,' ',trim(name),&
& 'Entering '
!
! For the time being we are commenting out the UPDATE argument
! we plan to resurrect it later.
! !$ if (present(upd)) then
! !$ if (debug_level >= psb_debug_outer_) &
! !$ & write(debug_unit,*) me,' ',trim(name),'UPD ', upd
! !$
! !$ if ((psb_toupper(upd).eq.'F').or.(psb_toupper(upd).eq.'T')) then
! !$ upd_=psb_toupper(upd)
! !$ else
! !$ upd_='F'
! !$ endif
! !$ else
! !$ upd_='F'
! !$ endif
upd_ = 'F'
if (.not.allocated(prec%precv)) then
!! Error: should have called mld_cprecinit
@@ -138,28 +123,27 @@ subroutine mld_c_hierarchy_bld(a,desc_a,prec,info)
! Check to ensure all procs have the same
!
newsz = -1
casize = prec%coarse_aggr_size
mxplevs = prec%max_prec_levs
mnaggratio = prec%min_aggr_ratio
casize = prec%coarse_aggr_size
mxplevs = prec%max_levs
mnaggratio = prec%min_cr_ratio
casize = prec%min_coarse_size
iszv = size(prec%precv)
call psb_bcast(ictxt,iszv)
call psb_bcast(ictxt,casize)
call psb_bcast(ictxt,mxplevs)
call psb_bcast(ictxt,mnaggratio)
if (casize /= prec%coarse_aggr_size) then
if (casize /= prec%min_coarse_size) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent coarse_aggr_size')
call psb_errpush(info,name,a_err='Inconsistent min_coarse_size')
goto 9999
end if
if (mxplevs /= prec%max_prec_levs) then
if (mxplevs /= prec%max_levs) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent max_prec_levs')
call psb_errpush(info,name,a_err='Inconsistent max_levs')
goto 9999
end if
if (mnaggratio /= prec%min_aggr_ratio) then
if (mnaggratio /= prec%min_cr_ratio) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent min_aggr_ratio')
call psb_errpush(info,name,a_err='Inconsistent min_cr_ratio')
goto 9999
end if
if (iszv /= size(prec%precv)) then
@@ -198,18 +182,20 @@ subroutine mld_c_hierarchy_bld(a,desc_a,prec,info)
! 3. If the size of the array is different from target number of levels,
! reallocate;
! 4. Build the matrix hierarchy, stopping early if either the target
! coarse size is hit, or the gain falls below the min_aggr_ratio
! coarse size is hit, or the gain falls below the min_cr_ratio
! threshold.
!
if (casize <=0) then
if (casize < 0) then
!
! Default to the cubic root of the size at base level.
!
casize = desc_a%get_global_rows()
casize = int((sone*casize)**(sone/(sone*3)),psb_ipk_)
casize = max(casize,ione)
casize = casize*40_psb_ipk_
casize = casize*40_psb_ipk_
call psb_bcast(ictxt,casize)
prec%min_coarse_size = casize
end if
nplevs = max(itwo,mxplevs)
@@ -357,11 +343,9 @@ subroutine mld_c_hierarchy_bld(a,desc_a,prec,info)
! of distr/repl matrix at coarse level. Should be rethought.
!
athresh = prec%precv(newsz)%parms%aggr_thresh
ascale = prec%precv(newsz)%parms%aggr_scale
aomega = prec%precv(newsz)%parms%aggr_omega_val
if (info == 0) prec%precv(newsz)%parms = coarseparms
prec%precv(newsz)%parms%aggr_thresh = athresh
prec%precv(newsz)%parms%aggr_scale = ascale
prec%precv(newsz)%parms%aggr_omega_val = aomega
if (info == 0) call restore_smoothers(prec%precv(newsz),coarse_sm,coarse_sm2,info)
mlprec/impl/mld_c_lev_aggrmap_bld.f90
+8 -8
View File
@@ -108,15 +108,15 @@ subroutine mld_c_lev_aggrmap_bld(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
ictxt = desc_a%get_context()
call psb_info(ictxt,me,np)
call mld_check_def(p%parms%ml_type,'Multilevel type',&
& mld_mult_ml_,is_legal_ml_type)
call mld_check_def(p%parms%aggr_alg,'Aggregation',&
& mld_dec_aggr_,is_legal_ml_aggr_alg)
call mld_check_def(p%parms%ml_cycle,'Multilevel cycle',&
& mld_mult_ml_,is_legal_ml_cycle)
call mld_check_def(p%parms%par_aggr_alg,'Aggregation',&
& mld_dec_aggr_,is_legal_ml_par_aggr_alg)
call mld_check_def(p%parms%aggr_ord,'Ordering',&
& mld_aggr_ord_nat_,is_legal_ml_aggr_ord)
call mld_check_def(p%parms%aggr_thresh,'Aggr_Thresh',szero,is_legal_s_aggr_thrs)
select case(p%parms%aggr_alg)
select case(p%parms%par_aggr_alg)
case (mld_dec_aggr_, mld_sym_dec_aggr_)
!
@@ -125,7 +125,7 @@ subroutine mld_c_lev_aggrmap_bld(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
! aggregation algorithm. This also defines a tentative prolongator from
! the coarse to the fine level.
!
call mld_aggrmap_bld(p%parms%aggr_alg,p%parms%aggr_ord,p%parms%aggr_thresh,&
call mld_aggrmap_bld(p%parms%par_aggr_alg,p%parms%aggr_ord,p%parms%aggr_thresh,&
& a,desc_a,ilaggr,nlaggr,op_prol,info)
if (info /= psb_success_) then
@@ -137,14 +137,14 @@ subroutine mld_c_lev_aggrmap_bld(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
write(0,*) 'Matching is not implemented yet '
info = -1111
call psb_errpush(psb_err_input_value_invalid_i_,name,&
& i_err=(/ione,p%parms%aggr_alg,izero,izero,izero/))
& i_err=(/ione,p%parms%par_aggr_alg,izero,izero,izero/))
goto 9999
case default
info = -1
call psb_errpush(psb_err_input_value_invalid_i_,name,&
& i_err=(/ione,p%parms%aggr_alg,izero,izero,izero/))
& i_err=(/ione,p%parms%par_aggr_alg,izero,izero,izero/))
goto 9999
end select
mlprec/impl/mld_c_lev_aggrmat_asb.f90
+3 -5
View File
@@ -121,14 +121,12 @@ subroutine mld_c_lev_aggrmat_asb(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
ictxt = desc_a%get_context()
call psb_info(ictxt,me,np)
call mld_check_def(p%parms%aggr_kind,'Smoother',&
& mld_smooth_prol_,is_legal_ml_aggr_kind)
call mld_check_def(p%parms%aggr_prol,'Smoother',&
& mld_smooth_prol_,is_legal_ml_aggr_prol)
call mld_check_def(p%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_legal_ml_coarse_mat)
call mld_check_def(p%parms%aggr_filter,'Use filtered matrix',&
& mld_no_filter_mat_,is_legal_aggr_filter)
call mld_check_def(p%parms%smoother_pos,'smooth_pos',&
& mld_pre_smooth_,is_legal_ml_smooth_pos)
call mld_check_def(p%parms%aggr_omega_alg,'Omega Alg.',&
& mld_eig_est_,is_legal_ml_aggr_omega_alg)
call mld_check_def(p%parms%aggr_eig,'Eigenvalue estimate',&
@@ -139,7 +137,7 @@ subroutine mld_c_lev_aggrmat_asb(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
!
! Build the coarse-level matrix from the fine-level one, starting from
! the mapping defined by mld_aggrmap_bld and applying the aggregation
! algorithm specified by p%iprcparm(mld_aggr_kind_)
! algorithm specified by p%iprcparm(mld_aggr_prol_)
!
call mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p%parms,ac,op_prol,op_restr,info)
mlprec/impl/mld_c_smoothers_bld.f90
+95 -21
View File
@@ -1,3 +1,5 @@
!
!
! MLD2P4 version 2.1
@@ -95,15 +97,13 @@ subroutine mld_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
class(psb_c_base_sparse_mat), intent(in), optional :: amold
class(psb_c_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
!!$ character, intent(in), optional :: upd
! Local Variables
integer(psb_ipk_) :: ictxt, me,np
integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs
real(psb_spk_) :: mnaggratio
integer(psb_ipk_) :: ipv(mld_ifpsz_), val
integer(psb_ipk_) :: ipv(mld_ifpsz_), val, coarse_solve_id
integer(psb_ipk_) :: int_err(5)
character :: upd_
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name, ch_err
@@ -124,22 +124,6 @@ subroutine mld_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& write(debug_unit,*) me,' ',trim(name),&
& 'Entering '
!
! For the time being we are commenting out the UPDATE argument
! we plan to resurrect it later.
! !$ if (present(upd)) then
! !$ if (debug_level >= psb_debug_outer_) &
! !$ & write(debug_unit,*) me,' ',trim(name),'UPD ', upd
! !$
! !$ if ((psb_toupper(upd).eq.'F').or.(psb_toupper(upd).eq.'T')) then
! !$ upd_=psb_toupper(upd)
! !$ else
! !$ upd_='F'
! !$ endif
! !$ else
! !$ upd_='F'
! !$ endif
upd_ = 'F'
if (.not.allocated(prec%precv)) then
!! Error: should have called mld_cprecinit
info=3111
@@ -165,7 +149,7 @@ subroutine mld_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
!
! Now do the real build.
!
@@ -184,7 +168,97 @@ subroutine mld_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
endif
end do
!
! Issue a warning for inconsistent changes to COARSE_SOLVE
!
if (me == psb_root_) then
coarse_solve_id = prec%precv(iszv)%parms%coarse_solve
select case (coarse_solve_id)
case(mld_umf_,mld_slu_)
if (prec%precv(iszv)%sm%sv%get_id() /= coarse_solve_id) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id)
write(psb_err_unit,*) ' but I am building ',&
& mld_fact_names(prec%precv(iszv)%sm%sv%get_id())
write(psb_err_unit,*) 'This may happen if: '
write(psb_err_unit,*) ' 1. coarse_subsolve has been reset, or '
write(psb_err_unit,*) ' 2. the solver ', mld_fact_names(coarse_solve_id),&
& ' was not configured at MLD2P4 build time, or'
write(psb_err_unit,*) ' 3. an unsupported solver setup was specified.'
end if
if (prec%precv(iszv)%parms%coarse_mat /= mld_repl_mat_) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to distributed'
end if
case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
if (prec%precv(iszv)%sm%sv%get_id() /= mld_ilu_n_) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id)
write(psb_err_unit,*) ' but I am building ',&
& mld_fact_names(prec%precv(iszv)%sm%sv%get_id())
write(psb_err_unit,*) &
&'This may happen if coarse_subsolve has been reset'
end if
if (prec%precv(iszv)%parms%coarse_mat /= mld_repl_mat_) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to distributed'
end if
case(mld_mumps_)
if (prec%precv(iszv)%sm%sv%get_id() /= mld_mumps_) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id)
write(psb_err_unit,*) ' but I am building ',&
& mld_fact_names(prec%precv(iszv)%sm%sv%get_id())
write(psb_err_unit,*) &
&'This may happen if coarse_subsolve has been reset'
end if
case(mld_sludist_)
if (prec%precv(iszv)%sm%sv%get_id() /= coarse_solve_id) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id)
write(psb_err_unit,*) ' but I am building ',&
& mld_fact_names(prec%precv(iszv)%sm%sv%get_id())
write(psb_err_unit,*) 'This may happen if: '
write(psb_err_unit,*) ' 1. coarse_subsolve has been reset, or '
write(psb_err_unit,*) ' 2. the solver ', mld_fact_names(coarse_solve_id), &
& ' was not configured at MLD2P4 build time, or'
write(psb_err_unit,*) ' 3. an unsupported solver setup was specified.'
end if
if (prec%precv(iszv)%parms%coarse_mat /= mld_distr_mat_) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to replicated'
end if
case(mld_bjac_)
if (prec%precv(iszv)%parms%coarse_mat /= mld_distr_mat_) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to replicated'
end if
case default
! We should never get here.
info=psb_err_from_subroutine_
ch_err='unkn coarse_solve'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end select
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Exiting with',iszv,' levels'
mlprec/impl/mld_caggrmat_asb.f90
+2 -2
View File
@@ -52,7 +52,7 @@
! A mapping from the nodes of the adjacency graph of A to the nodes of the
! adjacency graph of A_C has been computed by the mld_aggrmap_bld subroutine.
! The prolongator P_C is built here from this mapping, according to the
! value of p%iprcparm(mld_aggr_kind_), specified by the user through
! value of p%iprcparm(mld_aggr_prol_), specified by the user through
! mld_cprecinit and mld_zprecset.
! On output from this routine the entries of AC, op_prol, op_restr
! are still in "global numbering" mode; this is fixed in the calling routine
@@ -153,7 +153,7 @@ subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,inf
call psb_info(ictxt, me, np)
select case (parms%aggr_kind)
select case (parms%aggr_prol)
case (mld_no_smooth_)
call mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,&
mlprec/impl/mld_caggrmat_biz_asb.f90
+1 -1
View File
@@ -342,7 +342,7 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
call psb_numbmm(a,tmp_prol,am3)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_
& 'Done NUMBMM 2',parms%aggr_prol, mld_smooth_prol_
call tmp_prol%transp(op_restr)
if (debug_level >= psb_debug_outer_) &
mlprec/impl/mld_caggrmat_smth_asb.f90
+1 -1
View File
@@ -352,7 +352,7 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done SPSPMM 2',parms%aggr_kind, mld_smooth_prol_
& 'Done SPSPMM 2',parms%aggr_prol, mld_smooth_prol_
call tmp_prol%cp_to(tmpcoo)
call tmpcoo%transp()
mlprec/impl/mld_ccprecset.F90
+15 -31
View File
@@ -135,11 +135,11 @@ subroutine mld_ccprecseti(p,what,val,info,ilev,ilmax,pos)
select case(psb_toupper(what))
case ('COARSE_AGGR_SIZE')
p%coarse_aggr_size = max(val,-1)
case ('MIN_COARSE_SIZE')
p%min_coarse_size = max(val,-1)
return
case('MAX_PREC_LEVS')
p%max_prec_levs = max(val,1)
case('MAX_LEVS')
p%max_levs = max(val,1)
return
case ('OUTER_SWEEPS')
p%outer_sweeps = max(val,1)
@@ -162,11 +162,9 @@ subroutine mld_ccprecseti(p,what,val,info,ilev,ilmax,pos)
select case(psb_toupper(what))
case('SMOOTHER_TYPE','SUB_SOLVE','SMOOTHER_SWEEPS',&
& 'ML_TYPE','AGGR_ALG','AGGR_ORD',&
& 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',&
& 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',&
& 'SMOOTHER_SWEEPS_POST',&
& 'SUB_RESTR','SUB_PROL', &
& 'ML_CYCLE','PAR_AGGR_ALG','AGGR_ORD',&
& 'AGGR_TYPE','AGGR_PROL','AGGR_OMEGA_ALG',&
& 'AGGR_EIG','SUB_RESTR','SUB_PROL', &
& 'SUB_REN','SUB_OVR','SUB_FILLIN',&
& 'COARSE_MAT')
call p%precv(ilev_)%set(what,val,info,pos=pos)
@@ -200,11 +198,11 @@ subroutine mld_ccprecseti(p,what,val,info,ilev,ilmax,pos)
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
#endif
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
case(mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
case(mld_sludist_,mld_mumps_)
case(mld_mumps_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
@@ -253,10 +251,8 @@ subroutine mld_ccprecseti(p,what,val,info,ilev,ilmax,pos)
if (info /= 0) return
end do
case('ML_TYPE','AGGR_ALG','AGGR_ORD','AGGR_KIND',&
& 'SMOOTHER_SWEEPS_PRE','SMOOTHER_SWEEPS_POST',&
& 'SMOOTHER_POS','AGGR_OMEGA_ALG',&
& 'AGGR_EIG','AGGR_FILTER')
case('ML_CYCLE','PAR_AGGR_ALG','AGGR_ORD','AGGR_PROL','AGGR_TYPE',&
& 'AGGR_OMEGA_ALG','AGGR_EIG','AGGR_FILTER')
do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info,pos=pos)
if (info /= 0) return
@@ -281,11 +277,11 @@ subroutine mld_ccprecseti(p,what,val,info,ilev,ilmax,pos)
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
#endif
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
case(mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
case(mld_sludist_,mld_mumps_)
case(mld_mumps_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
@@ -478,8 +474,8 @@ subroutine mld_ccprecsetr(p,what,val,info,ilev,ilmax,pos)
end if
select case(psb_toupper(what))
case ('MIN_AGGR_RATIO')
p%min_aggr_ratio = max(sone,val)
case ('MIN_CR_RATIO')
p%min_cr_ratio = max(sone,val)
return
end select
@@ -517,18 +513,6 @@ subroutine mld_ccprecsetr(p,what,val,info,ilev,ilmax,pos)
ilev_=nlev_
call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos)
case('AGGR_SCALE')
do ilev_ = 2, nlev_
call p%precv(ilev_)%set('AGGR_SCALE',val,info,pos=pos)
end do
case('AGGR_THRESH')
thr = val
do ilev_ = 2, nlev_
call p%precv(ilev_)%set('AGGR_THRESH',thr,info,pos=pos)
thr = thr * p%precv(ilev_)%parms%aggr_scale
end do
case default
do ilev_=1,nlev_
mlprec/impl/mld_cmlprec_aply.f90
+18 -82
View File
@@ -518,7 +518,7 @@ contains
write(debug_unit,*) me,' Start inner_ml_aply at level ',level
end if
select case(p%precv(level)%parms%ml_type)
select case(p%precv(level)%parms%ml_cycle)
case(mld_no_ml_)
!
@@ -532,39 +532,7 @@ contains
call mld_c_inner_add(p, mlprec_wrk, level, trans, work)
case(mld_mult_ml_)
!
! Multiplicative multilevel (multiplicative among the levels, additive inside
! each level)
!
! Pre/post-smoothing versions.
! Note that the transpose switches pre <-> post.
!
select case(p%precv(level)%parms%smoother_pos)
case(mld_post_smooth_)
p%precv(level)%parms%sweeps_pre = 0
call mld_c_inner_mult(p, mlprec_wrk, level, trans, work)
case(mld_pre_smooth_)
p%precv(level)%parms%sweeps_post = 0
call mld_c_inner_mult(p, mlprec_wrk, level, trans, work)
case(mld_twoside_smooth_)
call mld_c_inner_mult(p, mlprec_wrk, level, trans, work)
case default
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='invalid smooth_pos',&
& i_Err=(/p%precv(level)%parms%smoother_pos,izero,izero,izero,izero/))
goto 9999
end select
case(mld_vcycle_ml_, mld_wcycle_ml_)
case(mld_mult_ml_,mld_vcycle_ml_, mld_wcycle_ml_)
call mld_c_inner_mult(p, mlprec_wrk, level, trans, work)
@@ -574,8 +542,8 @@ contains
case default
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='invalid mltype',&
& i_Err=(/p%precv(level)%parms%ml_type,izero,izero,izero,izero/))
call psb_errpush(info,name,a_err='invalid ml_cycle',&
& i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
goto 9999
end select
@@ -643,7 +611,7 @@ contains
goto 9999
end if
sweeps = p%precv(level)%parms%sweeps
sweeps = p%precv(level)%parms%sweeps_pre
call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
@@ -821,7 +789,7 @@ contains
goto 9999
end if
if (p%precv(level)%parms%ml_type == mld_wcycle_ml_) then
if (p%precv(level)%parms%ml_cycle == mld_wcycle_ml_) then
call psb_geaxpby(cone,mlprec_wrk(level)%vx2l,&
& czero,mlprec_wrk(level)%vty,&
@@ -894,7 +862,7 @@ contains
else if (level == nlev) then
sweeps = p%precv(level)%parms%sweeps
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
@@ -976,7 +944,7 @@ contains
!
! Apply smoother
!
sweeps = p%precv(level)%parms%sweeps
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
@@ -1036,13 +1004,13 @@ contains
!Set the preconditioner
if (level <= nlev - 2 ) then
if (p%precv(level)%parms%ml_type == mld_kcyclesym_ml_) then
if (p%precv(level)%parms%ml_cycle == mld_kcyclesym_ml_) then
call mld_cinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'FCG')
elseif (p%precv(level)%parms%ml_type == mld_kcycle_ml_) then
elseif (p%precv(level)%parms%ml_cycle == mld_kcycle_ml_) then
call mld_cinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'GCR')
else
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Bad value for ml_type')
& a_err='Bad value for ml_cycle')
goto 9999
endif
else
@@ -1466,7 +1434,7 @@ contains
write(debug_unit,*) me,' inner_ml_aply at level ',level
end if
select case(p%precv(level)%parms%ml_type)
select case(p%precv(level)%parms%ml_cycle)
case(mld_no_ml_)
!
@@ -1480,39 +1448,7 @@ contains
call mld_c_inner_add(p, mlprec_wrk, level, trans, work)
case(mld_mult_ml_)
!
! Multiplicative multilevel (multiplicative among the levels, additive inside
! each level)
!
! Pre/post-smoothing versions.
! Note that the transpose switches pre <-> post.
!
select case(p%precv(level)%parms%smoother_pos)
case(mld_post_smooth_)
p%precv(level)%parms%sweeps_pre = 0
call mld_c_inner_mult(p, mlprec_wrk, level, trans, work)
case(mld_pre_smooth_)
p%precv(level)%parms%sweeps_post = 0
call mld_c_inner_mult(p, mlprec_wrk, level, trans, work)
case(mld_twoside_smooth_)
call mld_c_inner_mult(p, mlprec_wrk, level, trans, work)
case default
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='invalid smooth_pos',&
& i_Err=(/p%precv(level)%parms%smoother_pos,izero,izero,izero,izero/))
goto 9999
end select
case(mld_vcycle_ml_, mld_wcycle_ml_)
case(mld_mult_ml_, mld_vcycle_ml_, mld_wcycle_ml_)
call mld_c_inner_mult(p, mlprec_wrk, level, trans, work)
@@ -1522,8 +1458,8 @@ contains
case default
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='invalid mltype',&
& i_Err=(/p%precv(level)%parms%ml_type,izero,izero,izero,izero/))
call psb_errpush(info,name,a_err='invalid ml_cycle',&
& i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
goto 9999
end select
@@ -1588,7 +1524,7 @@ contains
goto 9999
end if
sweeps = p%precv(level)%parms%sweeps
sweeps = p%precv(level)%parms%sweeps_pre
call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
@@ -1766,7 +1702,7 @@ contains
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (p%precv(level)%parms%ml_type == mld_wcycle_ml_) then
if (p%precv(level)%parms%ml_cycle == mld_wcycle_ml_) then
! On second call will use output y2l as initial guess
if (info == psb_success_) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
endif
@@ -1832,7 +1768,7 @@ contains
else if (level == nlev) then
sweeps = p%precv(level)%parms%sweeps
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
mlprec/impl/mld_cmlprec_bld.f90
-2
View File
@@ -94,7 +94,6 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold,imold)
class(psb_c_base_sparse_mat), intent(in), optional :: amold
class(psb_c_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
!!$ character, intent(in), optional :: upd
! Local Variables
integer(psb_ipk_) :: ictxt, me,np
@@ -102,7 +101,6 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold,imold)
real(psb_spk_) :: mnaggratio
integer(psb_ipk_) :: ipv(mld_ifpsz_), val
integer(psb_ipk_) :: int_err(5)
character :: upd_
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name, ch_err
mlprec/impl/mld_cprecaply.f90
+6 -3
View File
@@ -144,7 +144,8 @@ subroutine mld_cprecaply(prec,x,y,desc_data,info,trans,work)
! Number of levels = 1: apply the base preconditioner
!
call prec%precv(1)%sm%apply(cone,x,czero,y,desc_data,trans_,&
& prec%precv(1)%parms%sweeps, work_,info)
& max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post), &
& work_,info)
else
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='Invalid size of precv',&
@@ -336,7 +337,8 @@ subroutine mld_cprecaply2_vect(prec,x,y,desc_data,info,trans,work)
! Number of levels = 1: apply the base preconditioner
!
call prec%precv(1)%sm%apply(cone,x,czero,y,desc_data,trans_,&
& prec%precv(1)%parms%sweeps, work_,info)
& max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post),&
& work_,info)
else
@@ -438,7 +440,8 @@ subroutine mld_cprecaply1_vect(prec,x,desc_data,info,trans,work)
! Number of levels = 1: apply the base preconditioner
!
call prec%precv(1)%sm%apply(cone,x,czero,ww,desc_data,trans_,&
& prec%precv(1)%parms%sweeps, work_,info)
& max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post),&
& work_,info)
else
mlprec/impl/mld_cprecbld.f90
+1 -18
View File
@@ -74,7 +74,6 @@ subroutine mld_cprecbld(a,desc_a,prec,info,amold,vmold,imold)
class(psb_c_base_sparse_mat), intent(in), optional :: amold
class(psb_c_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
!!$ character, intent(in), optional :: upd
! Local Variables
type(mld_cprec_type) :: t_prec
@@ -82,7 +81,6 @@ subroutine mld_cprecbld(a,desc_a,prec,info,amold,vmold,imold)
integer(psb_ipk_) :: err,i,k,err_act, iszv, newsz
integer(psb_ipk_) :: ipv(mld_ifpsz_), val
integer(psb_ipk_) :: int_err(5)
character :: upd_
type(mld_dml_parms) :: prm
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name, ch_err
@@ -105,21 +103,6 @@ subroutine mld_cprecbld(a,desc_a,prec,info,amold,vmold,imold)
& write(debug_unit,*) me,' ',trim(name),&
& 'Entering '
!
! For the time being we are commenting out the UPDATE argument
! we plan to resurrect it later.
!!$ if (present(upd)) then
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),'UPD ', upd
!!$
!!$ if ((psb_toupper(upd).eq.'F').or.(psb_toupper(upd).eq.'T')) then
!!$ upd_=psb_toupper(upd)
!!$ else
!!$ upd_='F'
!!$ endif
!!$ else
!!$ upd_='F'
!!$ endif
upd_ = 'F'
if (.not.allocated(prec%precv)) then
!! Error: should have called mld_cprecinit
@@ -174,7 +157,7 @@ subroutine mld_cprecbld(a,desc_a,prec,info,amold,vmold,imold)
goto 9999
endif
call prec%precv(1)%sm%build(a,desc_a,upd_,info,&
call prec%precv(1)%sm%build(a,desc_a,info,&
& amold=amold,vmold=vmold,imold=imold)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
mlprec/impl/mld_cprecinit.F90
+22 -7
View File
@@ -108,7 +108,7 @@ subroutine mld_cprecinit(prec,ptype,info)
! Local variables
integer(psb_ipk_) :: nlev_, ilev_
real(psb_spk_) :: thr, scale
real(psb_spk_) :: thr
character(len=*), parameter :: name='mld_precinit'
info = psb_success_
@@ -118,7 +118,7 @@ subroutine mld_cprecinit(prec,ptype,info)
! Do we want to do something?
endif
endif
prec%coarse_aggr_size = -1
prec%min_coarse_size = -1
select case(psb_toupper(ptype(1:len_trim(ptype))))
case ('NOPREC','NONE')
@@ -160,9 +160,26 @@ subroutine mld_cprecinit(prec,ptype,info)
case ('ML')
nlev_ = prec%max_prec_levs
nlev_ = prec%max_levs
ilev_ = 1
allocate(prec%precv(nlev_),stat=info)
allocate(prec%precv(nlev_),stat=info)
#if 1
do ilev_ = 1, nlev_
call prec%precv(ilev_)%default()
end do
call prec%set('ML_CYCLE','VCYCLE',info)
call prec%set('SMOOTHER_TYPE','FBGS',info)
#if defined(HAVE_MUMPS_)
call prec%set('COARSE_SOLVE','MUMPS',info)
#elif defined(HAVE_SLU_)
call prec%set('COARSE_SOLVE','SLU',info)
#else
call prec%set('COARSE_SOLVE','ILU',info)
#endif
!call prec%precv(nlev_)%default()
#else
allocate(mld_c_as_smoother_type :: prec%precv(ilev_)%sm, stat=info)
if (info /= psb_success_) return
allocate(mld_c_ilu_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
@@ -193,13 +210,11 @@ subroutine mld_cprecinit(prec,ptype,info)
call prec%precv(ilev_)%set(mld_sub_ovr_,izero,info)
thr = 0.05_psb_spk_
scale = 1.0_psb_spk_
do ilev_=1,nlev_
call prec%precv(ilev_)%set(mld_aggr_thresh_,thr,info)
call prec%precv(ilev_)%set(mld_aggr_scale_,scale,info)
call prec%precv(ilev_)%set(mld_aggr_filter_,mld_filter_mat_,info)
end do
#endif
case default
write(psb_err_unit,*) name,&
&': Warning: Unknown preconditioner type request "',ptype,'"'
mlprec/impl/mld_cprecset.F90
+12 -32
View File
@@ -134,11 +134,11 @@ subroutine mld_cprecseti(p,what,val,info,ilev,ilmax,pos)
select case(what)
case (mld_coarse_aggr_size_)
p%coarse_aggr_size = max(val,-1)
case (mld_min_coarse_size_)
p%min_coarse_size = max(val,-1)
return
case(mld_max_prec_levs_)
p%max_prec_levs = max(val,1)
case(mld_max_levs_)
p%max_levs = max(val,1)
return
case(mld_outer_sweeps_)
p%outer_sweeps = max(val,1)
@@ -158,10 +158,8 @@ subroutine mld_cprecseti(p,what,val,info,ilev,ilmax,pos)
select case(what)
case(mld_smoother_type_,mld_sub_solve_,mld_smoother_sweeps_,&
& mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,&
& mld_aggr_kind_,mld_smoother_pos_,&
& mld_aggr_omega_alg_,mld_aggr_eig_,&
& mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,&
& mld_ml_cycle_,mld_par_aggr_alg_,mld_aggr_ord_,mld_aggr_type_,&
& mld_aggr_prol_, mld_aggr_omega_alg_,mld_aggr_eig_,&
& mld_sub_restr_,mld_sub_prol_, &
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,&
& mld_coarse_mat_)
@@ -196,11 +194,11 @@ subroutine mld_cprecseti(p,what,val,info,ilev,ilmax,pos)
call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos)
#endif
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
case(mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos)
case(mld_sludist_,mld_mumps_)
case(mld_mumps_)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
@@ -248,9 +246,7 @@ subroutine mld_cprecseti(p,what,val,info,ilev,ilmax,pos)
if (info /= 0) return
end do
case(mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,mld_aggr_kind_,&
& mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,&
& mld_smoother_pos_,mld_aggr_omega_alg_,&
case(mld_ml_cycle_,mld_par_aggr_alg_,mld_aggr_ord_,mld_aggr_type_,mld_aggr_prol_,&
& mld_aggr_eig_,mld_aggr_filter_)
do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info,pos=pos)
@@ -274,14 +270,10 @@ subroutine mld_cprecseti(p,what,val,info,ilev,ilmax,pos)
call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos)
#endif
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
case(mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos)
case(mld_sludist_)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_mumps_)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
@@ -574,8 +566,8 @@ subroutine mld_cprecsetr(p,what,val,info,ilev,ilmax,pos)
info = psb_success_
select case(what)
case (mld_min_aggr_ratio_)
p%min_aggr_ratio = max(sone,val)
case (mld_min_cr_ratio_)
p%min_cr_ratio = max(sone,val)
return
end select
@@ -619,18 +611,6 @@ subroutine mld_cprecsetr(p,what,val,info,ilev,ilmax,pos)
ilev_=nlev_
call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info,pos=pos)
case(mld_aggr_scale_)
do ilev_ = 2, nlev_
call p%precv(ilev_)%set(mld_aggr_scale_,val,info,pos=pos)
end do
case(mld_aggr_thresh_)
thr = val
do ilev_ = 2, nlev_
call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info,pos=pos)
thr = thr * p%precv(ilev_)%parms%aggr_scale
end do
case default
do ilev_=1,nlev_
mlprec/impl/mld_cslud_interface.c
-356
View File
@@ -1,356 +0,0 @@
/*
*
* MLD2P4 version 2.0
* MultiLevel Domain Decomposition Parallel Preconditioners Package
* based on PSBLAS (Parallel Sparse BLAS version 3.3)
*
* (C) Copyright 2008, 2010, 2012, 2015, 2017
*
* Salvatore Filippone Cranfield University
* Ambra Abdullahi Hassan University of Rome Tor Vergata
* Alfredo Buttari CNRS-IRIT, Toulouse
* Pasqua D'Ambra ICAR-CNR, Naples
* Daniela di Serafino University of Campania "L. Vanvitelli", Caserta
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions, and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
* 3. The name of the MLD2P4 group or the names of its contributors may
* not be used to endorse or promote products derived from this
* software without specific written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
* ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
* BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*
*
* File: mld_cslud_interface.c
*
* Functions: mld_csludist_fact, mld_csludist_solve, mld_csludist_free.
*
* This file is an interface to the SuperLU_dist routines for sparse factorization and
* solve. It was obtained by modifying the c_fortran_zgssv.c file from the SuperLU_dist
* source distribution; original copyright terms are reproduced below.
*
*/
/* =====================
Copyright (c) 2003, The Regents of the University of California, through
Lawrence Berkeley National Laboratory (subject to receipt of any required
approvals from U.S. Dept. of Energy)
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
(1) Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
(2) Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
(3) Neither the name of Lawrence Berkeley National Laboratory, U.S. Dept. of
Energy nor the names of its contributors may be used to endorse or promote
products derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*/
/*
* -- Distributed SuperLU routine (version 2.0) --
* Lawrence Berkeley National Lab, Univ. of California Berkeley.
* March 15, 2003
*
*/
/* as of v 3.3 SLUDist does not have a single precision interface */
#ifdef Have_SLUDist_
#undef Have_SLUDist_
#endif
#ifdef Have_SLUDist_
#include <math.h>
#include "superlu_zdefs.h"
#define HANDLE_SIZE 8
typedef struct {
SuperMatrix *A;
LUstruct_t *LUstruct;
gridinfo_t *grid;
ScalePermstruct_t *ScalePermstruct;
} factors_t;
#else
#include <stdio.h>
#endif
int mld_csludist_fact(int n, int nl, int nnzl, int ffstr,
#ifdef Have_SLUDist_
complex *values, int *rowptr, int *colind,
void **f_factors,
#else
void *values, int *rowptr, int *colind,
void **f_factors,
#endif
int nprow, int npcol)
{
/*
* This routine can be called from Fortran.
* performs LU decomposition.
*
* f_factors (input/output) void**
* On output contains the pointer pointing to
* the structure of the factored matrices.
*
*/
#ifdef Have_SLUDist_
SuperMatrix *A;
NRformat_loc *Astore;
ScalePermstruct_t *ScalePermstruct;
LUstruct_t *LUstruct;
SOLVEstruct_t SOLVEstruct;
gridinfo_t *grid;
int i, panel_size, permc_spec, relax, info;
trans_t trans;
float drop_tol = 0.0,berr[1];
mem_usage_t mem_usage;
superlu_options_t options;
SuperLUStat_t stat;
factors_t *LUfactors;
int fst_row;
int *icol,*irpt;
complex *ival,b[1];
trans = NOTRANS;
grid = (gridinfo_t *) SUPERLU_MALLOC(sizeof(gridinfo_t));
superlu_gridinit(MPI_COMM_WORLD, nprow, npcol, grid);
/* Initialize the statistics variables. */
PStatInit(&stat);
fst_row = (ffstr);
A = (SuperMatrix *) malloc(sizeof(SuperMatrix));
zCreate_CompRowLoc_Matrix_dist(A, n, n, nnzl, nl, fst_row,
values, colind, rowptr,
SLU_NR_loc, SLU_Z, SLU_GE);
/* Initialize ScalePermstruct and LUstruct. */
ScalePermstruct = (ScalePermstruct_t *) SUPERLU_MALLOC(sizeof(ScalePermstruct_t));
LUstruct = (LUstruct_t *) SUPERLU_MALLOC(sizeof(LUstruct_t));
ScalePermstructInit(n,n, ScalePermstruct);
#if defined(SLUD_VERSION_4)
LUstructInit(n, LUstruct);
#elif defined(SLUD_VERSION_3)
LUstructInit(n,n, LUstruct);
#else
choke_on_me;
#endif
/* Set the default input options. */
set_default_options_dist(&options);
options.IterRefine=NO;
options.PrintStat=NO;
pzgssvx(&options, A, ScalePermstruct, b, nl, 0,
grid, LUstruct, &SOLVEstruct, berr, &stat, &info);
if ( info == 0 ) {
;
} else {
printf("pzgssvx() error returns INFO= %d\n", info);
if ( info <= n ) { /* factorization completes */
;
}
}
if (options.SolveInitialized) {
zSolveFinalize(&options,&SOLVEstruct);
}
/* Save the LU factors in the factors handle */
LUfactors = (factors_t *) SUPERLU_MALLOC(sizeof(factors_t));
LUfactors->LUstruct = LUstruct;
LUfactors->grid = grid;
LUfactors->A = A;
LUfactors->ScalePermstruct = ScalePermstruct;
/* fprintf(stderr,"slud factor: LUFactors %p \n",LUfactors); */
/* fprintf(stderr,"slud factor: A %p %p\n",A,LUfactors->A); */
/* fprintf(stderr,"slud factor: grid %p %p\n",grid,LUfactors->grid); */
/* fprintf(stderr,"slud factor: LUstruct %p %p\n",LUstruct,LUfactors->LUstruct); */
*f_factors = (void *) LUfactors;
PStatFree(&stat);
return(info);
#else
fprintf(stderr," SLUDist does not have single precision, sorry.\n");
return(-1);
#endif
}
int mld_csludist_solve(int itrans, int n, int nrhs,
#ifdef Have_SLUDist_
complex *b,
#else
void *b,
#endif
int ldb, void *f_factors)
{
/*
* This routine can be called from Fortran.
* performs triangular solve
*
*/
#ifdef Have_SLUDist_
SuperMatrix *A;
ScalePermstruct_t *ScalePermstruct;
LUstruct_t *LUstruct;
SOLVEstruct_t SOLVEstruct;
gridinfo_t *grid;
int i, panel_size, permc_spec, relax, info;
trans_t trans;
float drop_tol = 0.0;
float *berr;
mem_usage_t mem_usage;
superlu_options_t options;
SuperLUStat_t stat;
factors_t *LUfactors;
LUfactors = (factors_t *) f_factors ;
A = LUfactors->A ;
LUstruct = LUfactors->LUstruct ;
grid = LUfactors->grid ;
ScalePermstruct = LUfactors->ScalePermstruct;
/* fprintf(stderr,"slud solve: LUFactors %p \n",LUfactors); */
/* fprintf(stderr,"slud solve: A %p %p\n",A,LUfactors->A); */
/* fprintf(stderr,"slud solve: grid %p %p\n",grid,LUfactors->grid); */
/* fprintf(stderr,"slud solve: LUstruct %p %p\n",LUstruct,LUfactors->LUstruct); */
if (itrans == 0) {
trans = NOTRANS;
} else if (itrans ==1) {
trans = TRANS;
} else if (itrans ==2) {
trans = CONJ;
} else {
trans = NOTRANS;
}
/* fprintf(stderr,"Entry to sludist_solve\n"); */
berr = (float *) malloc((nrhs) *sizeof(float));
/* Initialize the statistics variables. */
PStatInit(&stat);
/* Set the default input options. */
set_default_options_dist(&options);
options.IterRefine = NO;
options.Fact = FACTORED;
options.PrintStat = NO;
pzgssvx(&options, A, ScalePermstruct, b, ldb, nrhs,
grid, LUstruct, &SOLVEstruct, berr, &stat, &info);
/* fprintf(stderr,"Float check: after solve %d %lf\n",*info,berr[0]); */
if (options.SolveInitialized) {
zSolveFinalize(&options,&SOLVEstruct);
}
PStatFree(&stat);
free(berr);
return(info);
#else
fprintf(stderr," SLUDist does not have single precision, sorry.\n");
return(-1);
#endif
}
int mld_csludist_free(void *f_factors)
{
/*
* This routine can be called from Fortran.
*
* free all storage in the end
*
*/
#ifdef Have_SLUDist_
SuperMatrix *A;
ScalePermstruct_t *ScalePermstruct;
LUstruct_t *LUstruct;
SOLVEstruct_t SOLVEstruct;
gridinfo_t *grid;
int i, panel_size, permc_spec, relax;
trans_t trans;
float drop_tol = 0.0;
float *berr;
mem_usage_t mem_usage;
superlu_options_t options;
SuperLUStat_t stat;
factors_t *LUfactors;
if (f_factors == NULL)
return(0);
LUfactors = (factors_t *) f_factors ;
A = LUfactors->A ;
LUstruct = LUfactors->LUstruct ;
grid = LUfactors->grid ;
ScalePermstruct = LUfactors->ScalePermstruct;
// Memory leak: with SuperLU_Dist 3.3
// we either have a leak or a segfault here.
// To be investigated further.
//Destroy_CompRowLoc_Matrix_dist(A);
ScalePermstructFree(ScalePermstruct);
LUstructFree(LUstruct);
superlu_gridexit(grid);
free(grid);
free(LUstruct);
free(LUfactors);
return(0);
#else
fprintf(stderr," SLUDist does not have single precision, sorry.\n");
return(-1);
#endif
}
mlprec/impl/mld_d_extprol_bld.f90
+14 -15
View File
@@ -154,10 +154,9 @@ subroutine mld_d_extprol_bld(a,desc_a,p,prolv,restrv,info,amold,vmold,imold)
! Check to ensure all procs have the same
!
newsz = -1
casize = p%coarse_aggr_size
mxplevs = p%max_prec_levs
mnaggratio = p%min_aggr_ratio
casize = p%coarse_aggr_size
mxplevs = p%max_levs
mnaggratio = p%min_cr_ratio
casize = p%min_coarse_size
iszv = size(p%precv)
nprolv = size(prolv)
nrestrv = size(restrv)
@@ -167,19 +166,19 @@ subroutine mld_d_extprol_bld(a,desc_a,p,prolv,restrv,info,amold,vmold,imold)
call psb_bcast(ictxt,mnaggratio)
call psb_bcast(ictxt,nprolv)
call psb_bcast(ictxt,nrestrv)
if (casize /= p%coarse_aggr_size) then
if (casize /= p%min_coarse_size) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent coarse_aggr_size')
call psb_errpush(info,name,a_err='Inconsistent min_coarse_size')
goto 9999
end if
if (mxplevs /= p%max_prec_levs) then
if (mxplevs /= p%max_levs) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent max_prec_levs')
call psb_errpush(info,name,a_err='Inconsistent max_levs')
goto 9999
end if
if (mnaggratio /= p%min_aggr_ratio) then
if (mnaggratio /= p%min_cr_ratio) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent min_aggr_ratio')
call psb_errpush(info,name,a_err='Inconsistent min_cr_ratio')
goto 9999
end if
if (iszv /= size(p%precv)) then
@@ -220,8 +219,8 @@ subroutine mld_d_extprol_bld(a,desc_a,p,prolv,restrv,info,amold,vmold,imold)
endif
!
nplevs = nrestrv + 1
p%max_prec_levs = nplevs
nplevs = nrestrv + 1
p%max_levs = nplevs
!
! Fixed number of levels.
@@ -366,9 +365,9 @@ contains
allocate(nlaggr(np),ilaggr(1))
nlaggr = 0
ilaggr = 0
p%parms%aggr_alg = mld_ext_aggr_
call mld_check_def(p%parms%ml_type,'Multilevel type',&
& mld_mult_ml_,is_legal_ml_type)
p%parms%par_aggr_alg = mld_ext_aggr_
call mld_check_def(p%parms%ml_cycle,'Multilevel cycle',&
& mld_mult_ml_,is_legal_ml_cycle)
call mld_check_def(p%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_legal_ml_coarse_mat)
mlprec/impl/mld_d_hierarchy_bld.f90
+19 -35
View File
@@ -78,19 +78,19 @@ subroutine mld_d_hierarchy_bld(a,desc_a,prec,info)
type(psb_desc_type), intent(inout), target :: desc_a
class(mld_dprec_type),intent(inout),target :: prec
integer(psb_ipk_), intent(out) :: info
!!$ character, intent(in), optional :: upd
! Local Variables
integer(psb_ipk_) :: ictxt, me,np
integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs, iaggsize
real(psb_dpk_) :: mnaggratio, sizeratio, athresh, ascale, aomega
class(mld_d_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm, base_sm2, med_sm2, coarse_sm2
integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize,&
& nplevs, mxplevs, iaggsize
real(psb_dpk_) :: mnaggratio, sizeratio, athresh, aomega
class(mld_d_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm, &
& base_sm2, med_sm2, coarse_sm2
type(mld_dml_parms) :: baseparms, medparms, coarseparms
integer(psb_ipk_), allocatable :: ilaggr(:), nlaggr(:)
type(psb_dspmat_type) :: op_prol
type(mld_d_onelev_type), allocatable :: tprecv(:)
integer(psb_ipk_) :: int_err(5)
character :: upd_
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name, ch_err
@@ -111,21 +111,6 @@ subroutine mld_d_hierarchy_bld(a,desc_a,prec,info)
& write(debug_unit,*) me,' ',trim(name),&
& 'Entering '
!
! For the time being we are commenting out the UPDATE argument
! we plan to resurrect it later.
! !$ if (present(upd)) then
! !$ if (debug_level >= psb_debug_outer_) &
! !$ & write(debug_unit,*) me,' ',trim(name),'UPD ', upd
! !$
! !$ if ((psb_toupper(upd).eq.'F').or.(psb_toupper(upd).eq.'T')) then
! !$ upd_=psb_toupper(upd)
! !$ else
! !$ upd_='F'
! !$ endif
! !$ else
! !$ upd_='F'
! !$ endif
upd_ = 'F'
if (.not.allocated(prec%precv)) then
!! Error: should have called mld_dprecinit
@@ -138,28 +123,27 @@ subroutine mld_d_hierarchy_bld(a,desc_a,prec,info)
! Check to ensure all procs have the same
!
newsz = -1
casize = prec%coarse_aggr_size
mxplevs = prec%max_prec_levs
mnaggratio = prec%min_aggr_ratio
casize = prec%coarse_aggr_size
mxplevs = prec%max_levs
mnaggratio = prec%min_cr_ratio
casize = prec%min_coarse_size
iszv = size(prec%precv)
call psb_bcast(ictxt,iszv)
call psb_bcast(ictxt,casize)
call psb_bcast(ictxt,mxplevs)
call psb_bcast(ictxt,mnaggratio)
if (casize /= prec%coarse_aggr_size) then
if (casize /= prec%min_coarse_size) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent coarse_aggr_size')
call psb_errpush(info,name,a_err='Inconsistent min_coarse_size')
goto 9999
end if
if (mxplevs /= prec%max_prec_levs) then
if (mxplevs /= prec%max_levs) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent max_prec_levs')
call psb_errpush(info,name,a_err='Inconsistent max_levs')
goto 9999
end if
if (mnaggratio /= prec%min_aggr_ratio) then
if (mnaggratio /= prec%min_cr_ratio) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent min_aggr_ratio')
call psb_errpush(info,name,a_err='Inconsistent min_cr_ratio')
goto 9999
end if
if (iszv /= size(prec%precv)) then
@@ -198,18 +182,20 @@ subroutine mld_d_hierarchy_bld(a,desc_a,prec,info)
! 3. If the size of the array is different from target number of levels,
! reallocate;
! 4. Build the matrix hierarchy, stopping early if either the target
! coarse size is hit, or the gain falls below the min_aggr_ratio
! coarse size is hit, or the gain falls below the min_cr_ratio
! threshold.
!
if (casize <=0) then
if (casize < 0) then
!
! Default to the cubic root of the size at base level.
!
casize = desc_a%get_global_rows()
casize = int((done*casize)**(done/(done*3)),psb_ipk_)
casize = max(casize,ione)
casize = casize*40_psb_ipk_
casize = casize*40_psb_ipk_
call psb_bcast(ictxt,casize)
prec%min_coarse_size = casize
end if
nplevs = max(itwo,mxplevs)
@@ -357,11 +343,9 @@ subroutine mld_d_hierarchy_bld(a,desc_a,prec,info)
! of distr/repl matrix at coarse level. Should be rethought.
!
athresh = prec%precv(newsz)%parms%aggr_thresh
ascale = prec%precv(newsz)%parms%aggr_scale
aomega = prec%precv(newsz)%parms%aggr_omega_val
if (info == 0) prec%precv(newsz)%parms = coarseparms
prec%precv(newsz)%parms%aggr_thresh = athresh
prec%precv(newsz)%parms%aggr_scale = ascale
prec%precv(newsz)%parms%aggr_omega_val = aomega
if (info == 0) call restore_smoothers(prec%precv(newsz),coarse_sm,coarse_sm2,info)
mlprec/impl/mld_d_lev_aggrmap_bld.f90
+8 -8
View File
@@ -108,15 +108,15 @@ subroutine mld_d_lev_aggrmap_bld(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
ictxt = desc_a%get_context()
call psb_info(ictxt,me,np)
call mld_check_def(p%parms%ml_type,'Multilevel type',&
& mld_mult_ml_,is_legal_ml_type)
call mld_check_def(p%parms%aggr_alg,'Aggregation',&
& mld_dec_aggr_,is_legal_ml_aggr_alg)
call mld_check_def(p%parms%ml_cycle,'Multilevel cycle',&
& mld_mult_ml_,is_legal_ml_cycle)
call mld_check_def(p%parms%par_aggr_alg,'Aggregation',&
& mld_dec_aggr_,is_legal_ml_par_aggr_alg)
call mld_check_def(p%parms%aggr_ord,'Ordering',&
& mld_aggr_ord_nat_,is_legal_ml_aggr_ord)
call mld_check_def(p%parms%aggr_thresh,'Aggr_Thresh',dzero,is_legal_d_aggr_thrs)
select case(p%parms%aggr_alg)
select case(p%parms%par_aggr_alg)
case (mld_dec_aggr_, mld_sym_dec_aggr_)
!
@@ -125,7 +125,7 @@ subroutine mld_d_lev_aggrmap_bld(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
! aggregation algorithm. This also defines a tentative prolongator from
! the coarse to the fine level.
!
call mld_aggrmap_bld(p%parms%aggr_alg,p%parms%aggr_ord,p%parms%aggr_thresh,&
call mld_aggrmap_bld(p%parms%par_aggr_alg,p%parms%aggr_ord,p%parms%aggr_thresh,&
& a,desc_a,ilaggr,nlaggr,op_prol,info)
if (info /= psb_success_) then
@@ -137,14 +137,14 @@ subroutine mld_d_lev_aggrmap_bld(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
write(0,*) 'Matching is not implemented yet '
info = -1111
call psb_errpush(psb_err_input_value_invalid_i_,name,&
& i_err=(/ione,p%parms%aggr_alg,izero,izero,izero/))
& i_err=(/ione,p%parms%par_aggr_alg,izero,izero,izero/))
goto 9999
case default
info = -1
call psb_errpush(psb_err_input_value_invalid_i_,name,&
& i_err=(/ione,p%parms%aggr_alg,izero,izero,izero/))
& i_err=(/ione,p%parms%par_aggr_alg,izero,izero,izero/))
goto 9999
end select
mlprec/impl/mld_d_lev_aggrmat_asb.f90
+3 -5
View File
@@ -121,14 +121,12 @@ subroutine mld_d_lev_aggrmat_asb(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
ictxt = desc_a%get_context()
call psb_info(ictxt,me,np)
call mld_check_def(p%parms%aggr_kind,'Smoother',&
& mld_smooth_prol_,is_legal_ml_aggr_kind)
call mld_check_def(p%parms%aggr_prol,'Smoother',&
& mld_smooth_prol_,is_legal_ml_aggr_prol)
call mld_check_def(p%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_legal_ml_coarse_mat)
call mld_check_def(p%parms%aggr_filter,'Use filtered matrix',&
& mld_no_filter_mat_,is_legal_aggr_filter)
call mld_check_def(p%parms%smoother_pos,'smooth_pos',&
& mld_pre_smooth_,is_legal_ml_smooth_pos)
call mld_check_def(p%parms%aggr_omega_alg,'Omega Alg.',&
& mld_eig_est_,is_legal_ml_aggr_omega_alg)
call mld_check_def(p%parms%aggr_eig,'Eigenvalue estimate',&
@@ -139,7 +137,7 @@ subroutine mld_d_lev_aggrmat_asb(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
!
! Build the coarse-level matrix from the fine-level one, starting from
! the mapping defined by mld_aggrmap_bld and applying the aggregation
! algorithm specified by p%iprcparm(mld_aggr_kind_)
! algorithm specified by p%iprcparm(mld_aggr_prol_)
!
call mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p%parms,ac,op_prol,op_restr,info)
mlprec/impl/mld_d_smoothers_bld.f90
+95 -21
View File
@@ -1,3 +1,5 @@
!
!
! MLD2P4 version 2.1
@@ -95,15 +97,13 @@ subroutine mld_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
class(psb_d_base_sparse_mat), intent(in), optional :: amold
class(psb_d_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
!!$ character, intent(in), optional :: upd
! Local Variables
integer(psb_ipk_) :: ictxt, me,np
integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs
real(psb_dpk_) :: mnaggratio
integer(psb_ipk_) :: ipv(mld_ifpsz_), val
integer(psb_ipk_) :: ipv(mld_ifpsz_), val, coarse_solve_id
integer(psb_ipk_) :: int_err(5)
character :: upd_
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name, ch_err
@@ -124,22 +124,6 @@ subroutine mld_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& write(debug_unit,*) me,' ',trim(name),&
& 'Entering '
!
! For the time being we are commenting out the UPDATE argument
! we plan to resurrect it later.
! !$ if (present(upd)) then
! !$ if (debug_level >= psb_debug_outer_) &
! !$ & write(debug_unit,*) me,' ',trim(name),'UPD ', upd
! !$
! !$ if ((psb_toupper(upd).eq.'F').or.(psb_toupper(upd).eq.'T')) then
! !$ upd_=psb_toupper(upd)
! !$ else
! !$ upd_='F'
! !$ endif
! !$ else
! !$ upd_='F'
! !$ endif
upd_ = 'F'
if (.not.allocated(prec%precv)) then
!! Error: should have called mld_dprecinit
info=3111
@@ -165,7 +149,7 @@ subroutine mld_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
!
! Now do the real build.
!
@@ -184,7 +168,97 @@ subroutine mld_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
endif
end do
!
! Issue a warning for inconsistent changes to COARSE_SOLVE
!
if (me == psb_root_) then
coarse_solve_id = prec%precv(iszv)%parms%coarse_solve
select case (coarse_solve_id)
case(mld_umf_,mld_slu_)
if (prec%precv(iszv)%sm%sv%get_id() /= coarse_solve_id) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id)
write(psb_err_unit,*) ' but I am building ',&
& mld_fact_names(prec%precv(iszv)%sm%sv%get_id())
write(psb_err_unit,*) 'This may happen if: '
write(psb_err_unit,*) ' 1. coarse_subsolve has been reset, or '
write(psb_err_unit,*) ' 2. the solver ', mld_fact_names(coarse_solve_id),&
& ' was not configured at MLD2P4 build time, or'
write(psb_err_unit,*) ' 3. an unsupported solver setup was specified.'
end if
if (prec%precv(iszv)%parms%coarse_mat /= mld_repl_mat_) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to distributed'
end if
case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
if (prec%precv(iszv)%sm%sv%get_id() /= mld_ilu_n_) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id)
write(psb_err_unit,*) ' but I am building ',&
& mld_fact_names(prec%precv(iszv)%sm%sv%get_id())
write(psb_err_unit,*) &
&'This may happen if coarse_subsolve has been reset'
end if
if (prec%precv(iszv)%parms%coarse_mat /= mld_repl_mat_) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to distributed'
end if
case(mld_mumps_)
if (prec%precv(iszv)%sm%sv%get_id() /= mld_mumps_) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id)
write(psb_err_unit,*) ' but I am building ',&
& mld_fact_names(prec%precv(iszv)%sm%sv%get_id())
write(psb_err_unit,*) &
&'This may happen if coarse_subsolve has been reset'
end if
case(mld_sludist_)
if (prec%precv(iszv)%sm%sv%get_id() /= coarse_solve_id) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id)
write(psb_err_unit,*) ' but I am building ',&
& mld_fact_names(prec%precv(iszv)%sm%sv%get_id())
write(psb_err_unit,*) 'This may happen if: '
write(psb_err_unit,*) ' 1. coarse_subsolve has been reset, or '
write(psb_err_unit,*) ' 2. the solver ', mld_fact_names(coarse_solve_id), &
& ' was not configured at MLD2P4 build time, or'
write(psb_err_unit,*) ' 3. an unsupported solver setup was specified.'
end if
if (prec%precv(iszv)%parms%coarse_mat /= mld_distr_mat_) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to replicated'
end if
case(mld_bjac_)
if (prec%precv(iszv)%parms%coarse_mat /= mld_distr_mat_) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to replicated'
end if
case default
! We should never get here.
info=psb_err_from_subroutine_
ch_err='unkn coarse_solve'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end select
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Exiting with',iszv,' levels'
mlprec/impl/mld_daggrmat_asb.f90
+2 -2
View File
@@ -52,7 +52,7 @@
! A mapping from the nodes of the adjacency graph of A to the nodes of the
! adjacency graph of A_C has been computed by the mld_aggrmap_bld subroutine.
! The prolongator P_C is built here from this mapping, according to the
! value of p%iprcparm(mld_aggr_kind_), specified by the user through
! value of p%iprcparm(mld_aggr_prol_), specified by the user through
! mld_dprecinit and mld_zprecset.
! On output from this routine the entries of AC, op_prol, op_restr
! are still in "global numbering" mode; this is fixed in the calling routine
@@ -153,7 +153,7 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,inf
call psb_info(ictxt, me, np)
select case (parms%aggr_kind)
select case (parms%aggr_prol)
case (mld_no_smooth_)
call mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,&
mlprec/impl/mld_daggrmat_biz_asb.f90
+1 -1
View File
@@ -342,7 +342,7 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
call psb_numbmm(a,tmp_prol,am3)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_
& 'Done NUMBMM 2',parms%aggr_prol, mld_smooth_prol_
call tmp_prol%transp(op_restr)
if (debug_level >= psb_debug_outer_) &
mlprec/impl/mld_daggrmat_smth_asb.f90
+1 -1
View File
@@ -352,7 +352,7 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done SPSPMM 2',parms%aggr_kind, mld_smooth_prol_
& 'Done SPSPMM 2',parms%aggr_prol, mld_smooth_prol_
call tmp_prol%cp_to(tmpcoo)
call tmpcoo%transp()
mlprec/impl/mld_dcprecset.F90
+31 -31
View File
@@ -141,11 +141,11 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,ilmax,pos)
select case(psb_toupper(what))
case ('COARSE_AGGR_SIZE')
p%coarse_aggr_size = max(val,-1)
case ('MIN_COARSE_SIZE')
p%min_coarse_size = max(val,-1)
return
case('MAX_PREC_LEVS')
p%max_prec_levs = max(val,1)
case('MAX_LEVS')
p%max_levs = max(val,1)
return
case ('OUTER_SWEEPS')
p%outer_sweeps = max(val,1)
@@ -168,11 +168,9 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,ilmax,pos)
select case(psb_toupper(what))
case('SMOOTHER_TYPE','SUB_SOLVE','SMOOTHER_SWEEPS',&
& 'ML_TYPE','AGGR_ALG','AGGR_ORD',&
& 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',&
& 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',&
& 'SMOOTHER_SWEEPS_POST',&
& 'SUB_RESTR','SUB_PROL', &
& 'ML_CYCLE','PAR_AGGR_ALG','AGGR_ORD',&
& 'AGGR_TYPE','AGGR_PROL','AGGR_OMEGA_ALG',&
& 'AGGR_EIG','SUB_RESTR','SUB_PROL', &
& 'SUB_REN','SUB_OVR','SUB_FILLIN',&
& 'COARSE_MAT')
call p%precv(ilev_)%set(what,val,info,pos=pos)
@@ -208,11 +206,19 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,ilmax,pos)
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
#endif
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
case(mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
case(mld_sludist_,mld_mumps_)
case(mld_mumps_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
case(mld_umf_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
case(mld_sludist_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
@@ -261,10 +267,8 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,ilmax,pos)
if (info /= 0) return
end do
case('ML_TYPE','AGGR_ALG','AGGR_ORD','AGGR_KIND',&
& 'SMOOTHER_SWEEPS_PRE','SMOOTHER_SWEEPS_POST',&
& 'SMOOTHER_POS','AGGR_OMEGA_ALG',&
& 'AGGR_EIG','AGGR_FILTER')
case('ML_CYCLE','PAR_AGGR_ALG','AGGR_ORD','AGGR_PROL','AGGR_TYPE',&
& 'AGGR_OMEGA_ALG','AGGR_EIG','AGGR_FILTER')
do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info,pos=pos)
if (info /= 0) return
@@ -291,11 +295,19 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,ilmax,pos)
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
#endif
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
case(mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
case(mld_sludist_,mld_mumps_)
case(mld_mumps_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
case(mld_umf_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
case(mld_sludist_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
@@ -488,8 +500,8 @@ subroutine mld_dcprecsetr(p,what,val,info,ilev,ilmax,pos)
end if
select case(psb_toupper(what))
case ('MIN_AGGR_RATIO')
p%min_aggr_ratio = max(done,val)
case ('MIN_CR_RATIO')
p%min_cr_ratio = max(done,val)
return
end select
@@ -527,18 +539,6 @@ subroutine mld_dcprecsetr(p,what,val,info,ilev,ilmax,pos)
ilev_=nlev_
call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos)
case('AGGR_SCALE')
do ilev_ = 2, nlev_
call p%precv(ilev_)%set('AGGR_SCALE',val,info,pos=pos)
end do
case('AGGR_THRESH')
thr = val
do ilev_ = 2, nlev_
call p%precv(ilev_)%set('AGGR_THRESH',thr,info,pos=pos)
thr = thr * p%precv(ilev_)%parms%aggr_scale
end do
case default
do ilev_=1,nlev_
mlprec/impl/mld_dmlprec_aply.f90
+18 -82
View File
@@ -518,7 +518,7 @@ contains
write(debug_unit,*) me,' Start inner_ml_aply at level ',level
end if
select case(p%precv(level)%parms%ml_type)
select case(p%precv(level)%parms%ml_cycle)
case(mld_no_ml_)
!
@@ -532,39 +532,7 @@ contains
call mld_d_inner_add(p, mlprec_wrk, level, trans, work)
case(mld_mult_ml_)
!
! Multiplicative multilevel (multiplicative among the levels, additive inside
! each level)
!
! Pre/post-smoothing versions.
! Note that the transpose switches pre <-> post.
!
select case(p%precv(level)%parms%smoother_pos)
case(mld_post_smooth_)
p%precv(level)%parms%sweeps_pre = 0
call mld_d_inner_mult(p, mlprec_wrk, level, trans, work)
case(mld_pre_smooth_)
p%precv(level)%parms%sweeps_post = 0
call mld_d_inner_mult(p, mlprec_wrk, level, trans, work)
case(mld_twoside_smooth_)
call mld_d_inner_mult(p, mlprec_wrk, level, trans, work)
case default
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='invalid smooth_pos',&
& i_Err=(/p%precv(level)%parms%smoother_pos,izero,izero,izero,izero/))
goto 9999
end select
case(mld_vcycle_ml_, mld_wcycle_ml_)
case(mld_mult_ml_,mld_vcycle_ml_, mld_wcycle_ml_)
call mld_d_inner_mult(p, mlprec_wrk, level, trans, work)
@@ -574,8 +542,8 @@ contains
case default
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='invalid mltype',&
& i_Err=(/p%precv(level)%parms%ml_type,izero,izero,izero,izero/))
call psb_errpush(info,name,a_err='invalid ml_cycle',&
& i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
goto 9999
end select
@@ -643,7 +611,7 @@ contains
goto 9999
end if
sweeps = p%precv(level)%parms%sweeps
sweeps = p%precv(level)%parms%sweeps_pre
call p%precv(level)%sm%apply(done,&
& mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
@@ -821,7 +789,7 @@ contains
goto 9999
end if
if (p%precv(level)%parms%ml_type == mld_wcycle_ml_) then
if (p%precv(level)%parms%ml_cycle == mld_wcycle_ml_) then
call psb_geaxpby(done,mlprec_wrk(level)%vx2l,&
& dzero,mlprec_wrk(level)%vty,&
@@ -894,7 +862,7 @@ contains
else if (level == nlev) then
sweeps = p%precv(level)%parms%sweeps
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
& mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
@@ -976,7 +944,7 @@ contains
!
! Apply smoother
!
sweeps = p%precv(level)%parms%sweeps
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
& mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
@@ -1036,13 +1004,13 @@ contains
!Set the preconditioner
if (level <= nlev - 2 ) then
if (p%precv(level)%parms%ml_type == mld_kcyclesym_ml_) then
if (p%precv(level)%parms%ml_cycle == mld_kcyclesym_ml_) then
call mld_dinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'FCG')
elseif (p%precv(level)%parms%ml_type == mld_kcycle_ml_) then
elseif (p%precv(level)%parms%ml_cycle == mld_kcycle_ml_) then
call mld_dinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'GCR')
else
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Bad value for ml_type')
& a_err='Bad value for ml_cycle')
goto 9999
endif
else
@@ -1466,7 +1434,7 @@ contains
write(debug_unit,*) me,' inner_ml_aply at level ',level
end if
select case(p%precv(level)%parms%ml_type)
select case(p%precv(level)%parms%ml_cycle)
case(mld_no_ml_)
!
@@ -1480,39 +1448,7 @@ contains
call mld_d_inner_add(p, mlprec_wrk, level, trans, work)
case(mld_mult_ml_)
!
! Multiplicative multilevel (multiplicative among the levels, additive inside
! each level)
!
! Pre/post-smoothing versions.
! Note that the transpose switches pre <-> post.
!
select case(p%precv(level)%parms%smoother_pos)
case(mld_post_smooth_)
p%precv(level)%parms%sweeps_pre = 0
call mld_d_inner_mult(p, mlprec_wrk, level, trans, work)
case(mld_pre_smooth_)
p%precv(level)%parms%sweeps_post = 0
call mld_d_inner_mult(p, mlprec_wrk, level, trans, work)
case(mld_twoside_smooth_)
call mld_d_inner_mult(p, mlprec_wrk, level, trans, work)
case default
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='invalid smooth_pos',&
& i_Err=(/p%precv(level)%parms%smoother_pos,izero,izero,izero,izero/))
goto 9999
end select
case(mld_vcycle_ml_, mld_wcycle_ml_)
case(mld_mult_ml_, mld_vcycle_ml_, mld_wcycle_ml_)
call mld_d_inner_mult(p, mlprec_wrk, level, trans, work)
@@ -1522,8 +1458,8 @@ contains
case default
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='invalid mltype',&
& i_Err=(/p%precv(level)%parms%ml_type,izero,izero,izero,izero/))
call psb_errpush(info,name,a_err='invalid ml_cycle',&
& i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
goto 9999
end select
@@ -1588,7 +1524,7 @@ contains
goto 9999
end if
sweeps = p%precv(level)%parms%sweeps
sweeps = p%precv(level)%parms%sweeps_pre
call p%precv(level)%sm%apply(done,&
& mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
@@ -1766,7 +1702,7 @@ contains
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (p%precv(level)%parms%ml_type == mld_wcycle_ml_) then
if (p%precv(level)%parms%ml_cycle == mld_wcycle_ml_) then
! On second call will use output y2l as initial guess
if (info == psb_success_) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
endif
@@ -1832,7 +1768,7 @@ contains
else if (level == nlev) then
sweeps = p%precv(level)%parms%sweeps
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
& mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
mlprec/impl/mld_dmlprec_bld.f90
-2
View File
@@ -94,7 +94,6 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold,imold)
class(psb_d_base_sparse_mat), intent(in), optional :: amold
class(psb_d_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
!!$ character, intent(in), optional :: upd
! Local Variables
integer(psb_ipk_) :: ictxt, me,np
@@ -102,7 +101,6 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold,imold)
real(psb_dpk_) :: mnaggratio
integer(psb_ipk_) :: ipv(mld_ifpsz_), val
integer(psb_ipk_) :: int_err(5)
character :: upd_
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name, ch_err
mlprec/impl/mld_dprecaply.f90
+6 -3
View File
@@ -144,7 +144,8 @@ subroutine mld_dprecaply(prec,x,y,desc_data,info,trans,work)
! Number of levels = 1: apply the base preconditioner
!
call prec%precv(1)%sm%apply(done,x,dzero,y,desc_data,trans_,&
& prec%precv(1)%parms%sweeps, work_,info)
& max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post), &
& work_,info)
else
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='Invalid size of precv',&
@@ -336,7 +337,8 @@ subroutine mld_dprecaply2_vect(prec,x,y,desc_data,info,trans,work)
! Number of levels = 1: apply the base preconditioner
!
call prec%precv(1)%sm%apply(done,x,dzero,y,desc_data,trans_,&
& prec%precv(1)%parms%sweeps, work_,info)
& max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post),&
& work_,info)
else
@@ -438,7 +440,8 @@ subroutine mld_dprecaply1_vect(prec,x,desc_data,info,trans,work)
! Number of levels = 1: apply the base preconditioner
!
call prec%precv(1)%sm%apply(done,x,dzero,ww,desc_data,trans_,&
& prec%precv(1)%parms%sweeps, work_,info)
& max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post),&
& work_,info)
else
mlprec/impl/mld_dprecbld.f90
+1 -18
View File
@@ -74,7 +74,6 @@ subroutine mld_dprecbld(a,desc_a,prec,info,amold,vmold,imold)
class(psb_d_base_sparse_mat), intent(in), optional :: amold
class(psb_d_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
!!$ character, intent(in), optional :: upd
! Local Variables
type(mld_dprec_type) :: t_prec
@@ -82,7 +81,6 @@ subroutine mld_dprecbld(a,desc_a,prec,info,amold,vmold,imold)
integer(psb_ipk_) :: err,i,k,err_act, iszv, newsz
integer(psb_ipk_) :: ipv(mld_ifpsz_), val
integer(psb_ipk_) :: int_err(5)
character :: upd_
type(mld_dml_parms) :: prm
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name, ch_err
@@ -105,21 +103,6 @@ subroutine mld_dprecbld(a,desc_a,prec,info,amold,vmold,imold)
& write(debug_unit,*) me,' ',trim(name),&
& 'Entering '
!
! For the time being we are commenting out the UPDATE argument
! we plan to resurrect it later.
!!$ if (present(upd)) then
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),'UPD ', upd
!!$
!!$ if ((psb_toupper(upd).eq.'F').or.(psb_toupper(upd).eq.'T')) then
!!$ upd_=psb_toupper(upd)
!!$ else
!!$ upd_='F'
!!$ endif
!!$ else
!!$ upd_='F'
!!$ endif
upd_ = 'F'
if (.not.allocated(prec%precv)) then
!! Error: should have called mld_dprecinit
@@ -174,7 +157,7 @@ subroutine mld_dprecbld(a,desc_a,prec,info,amold,vmold,imold)
goto 9999
endif
call prec%precv(1)%sm%build(a,desc_a,upd_,info,&
call prec%precv(1)%sm%build(a,desc_a,info,&
& amold=amold,vmold=vmold,imold=imold)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
mlprec/impl/mld_dprecinit.F90
+24 -7
View File
@@ -111,7 +111,7 @@ subroutine mld_dprecinit(prec,ptype,info)
! Local variables
integer(psb_ipk_) :: nlev_, ilev_
real(psb_dpk_) :: thr, scale
real(psb_dpk_) :: thr
character(len=*), parameter :: name='mld_precinit'
info = psb_success_
@@ -121,7 +121,7 @@ subroutine mld_dprecinit(prec,ptype,info)
! Do we want to do something?
endif
endif
prec%coarse_aggr_size = -1
prec%min_coarse_size = -1
select case(psb_toupper(ptype(1:len_trim(ptype))))
case ('NOPREC','NONE')
@@ -163,9 +163,28 @@ subroutine mld_dprecinit(prec,ptype,info)
case ('ML')
nlev_ = prec%max_prec_levs
nlev_ = prec%max_levs
ilev_ = 1
allocate(prec%precv(nlev_),stat=info)
allocate(prec%precv(nlev_),stat=info)
#if 1
do ilev_ = 1, nlev_
call prec%precv(ilev_)%default()
end do
call prec%set('ML_CYCLE','VCYCLE',info)
call prec%set('SMOOTHER_TYPE','FBGS',info)
#if defined(HAVE_UMF_)
call prec%set('COARSE_SOLVE','UMF',info)
#elif defined(HAVE_MUMPS_)
call prec%set('COARSE_SOLVE','MUMPS',info)
#elif defined(HAVE_SLU_)
call prec%set('COARSE_SOLVE','SLU',info)
#else
call prec%set('COARSE_SOLVE','ILU',info)
#endif
!call prec%precv(nlev_)%default()
#else
allocate(mld_d_as_smoother_type :: prec%precv(ilev_)%sm, stat=info)
if (info /= psb_success_) return
allocate(mld_d_ilu_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
@@ -198,13 +217,11 @@ subroutine mld_dprecinit(prec,ptype,info)
call prec%precv(ilev_)%set(mld_sub_ovr_,izero,info)
thr = 0.05_psb_dpk_
scale = 1.0_psb_dpk_
do ilev_=1,nlev_
call prec%precv(ilev_)%set(mld_aggr_thresh_,thr,info)
call prec%precv(ilev_)%set(mld_aggr_scale_,scale,info)
call prec%precv(ilev_)%set(mld_aggr_filter_,mld_filter_mat_,info)
end do
#endif
case default
write(psb_err_unit,*) name,&
&': Warning: Unknown preconditioner type request "',ptype,'"'
mlprec/impl/mld_dprecset.F90
+28 -32
View File
@@ -140,11 +140,11 @@ subroutine mld_dprecseti(p,what,val,info,ilev,ilmax,pos)
select case(what)
case (mld_coarse_aggr_size_)
p%coarse_aggr_size = max(val,-1)
case (mld_min_coarse_size_)
p%min_coarse_size = max(val,-1)
return
case(mld_max_prec_levs_)
p%max_prec_levs = max(val,1)
case(mld_max_levs_)
p%max_levs = max(val,1)
return
case(mld_outer_sweeps_)
p%outer_sweeps = max(val,1)
@@ -164,10 +164,8 @@ subroutine mld_dprecseti(p,what,val,info,ilev,ilmax,pos)
select case(what)
case(mld_smoother_type_,mld_sub_solve_,mld_smoother_sweeps_,&
& mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,&
& mld_aggr_kind_,mld_smoother_pos_,&
& mld_aggr_omega_alg_,mld_aggr_eig_,&
& mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,&
& mld_ml_cycle_,mld_par_aggr_alg_,mld_aggr_ord_,mld_aggr_type_,&
& mld_aggr_prol_, mld_aggr_omega_alg_,mld_aggr_eig_,&
& mld_sub_restr_,mld_sub_prol_, &
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,&
& mld_coarse_mat_)
@@ -204,11 +202,19 @@ subroutine mld_dprecseti(p,what,val,info,ilev,ilmax,pos)
call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos)
#endif
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
case(mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos)
case(mld_sludist_,mld_mumps_)
case(mld_mumps_)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_umf_)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos)
case(mld_sludist_)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
@@ -256,9 +262,7 @@ subroutine mld_dprecseti(p,what,val,info,ilev,ilmax,pos)
if (info /= 0) return
end do
case(mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,mld_aggr_kind_,&
& mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,&
& mld_smoother_pos_,mld_aggr_omega_alg_,&
case(mld_ml_cycle_,mld_par_aggr_alg_,mld_aggr_ord_,mld_aggr_type_,mld_aggr_prol_,&
& mld_aggr_eig_,mld_aggr_filter_)
do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info,pos=pos)
@@ -284,7 +288,15 @@ subroutine mld_dprecseti(p,what,val,info,ilev,ilmax,pos)
call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos)
#endif
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
case(mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos)
case(mld_mumps_)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_umf_)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos)
@@ -292,10 +304,6 @@ subroutine mld_dprecseti(p,what,val,info,ilev,ilmax,pos)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_mumps_)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_jac_)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos)
@@ -584,8 +592,8 @@ subroutine mld_dprecsetr(p,what,val,info,ilev,ilmax,pos)
info = psb_success_
select case(what)
case (mld_min_aggr_ratio_)
p%min_aggr_ratio = max(done,val)
case (mld_min_cr_ratio_)
p%min_cr_ratio = max(done,val)
return
end select
@@ -629,18 +637,6 @@ subroutine mld_dprecsetr(p,what,val,info,ilev,ilmax,pos)
ilev_=nlev_
call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info,pos=pos)
case(mld_aggr_scale_)
do ilev_ = 2, nlev_
call p%precv(ilev_)%set(mld_aggr_scale_,val,info,pos=pos)
end do
case(mld_aggr_thresh_)
thr = val
do ilev_ = 2, nlev_
call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info,pos=pos)
thr = thr * p%precv(ilev_)%parms%aggr_scale
end do
case default
do ilev_=1,nlev_
mlprec/impl/mld_s_extprol_bld.f90
+14 -15
View File
@@ -154,10 +154,9 @@ subroutine mld_s_extprol_bld(a,desc_a,p,prolv,restrv,info,amold,vmold,imold)
! Check to ensure all procs have the same
!
newsz = -1
casize = p%coarse_aggr_size
mxplevs = p%max_prec_levs
mnaggratio = p%min_aggr_ratio
casize = p%coarse_aggr_size
mxplevs = p%max_levs
mnaggratio = p%min_cr_ratio
casize = p%min_coarse_size
iszv = size(p%precv)
nprolv = size(prolv)
nrestrv = size(restrv)
@@ -167,19 +166,19 @@ subroutine mld_s_extprol_bld(a,desc_a,p,prolv,restrv,info,amold,vmold,imold)
call psb_bcast(ictxt,mnaggratio)
call psb_bcast(ictxt,nprolv)
call psb_bcast(ictxt,nrestrv)
if (casize /= p%coarse_aggr_size) then
if (casize /= p%min_coarse_size) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent coarse_aggr_size')
call psb_errpush(info,name,a_err='Inconsistent min_coarse_size')
goto 9999
end if
if (mxplevs /= p%max_prec_levs) then
if (mxplevs /= p%max_levs) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent max_prec_levs')
call psb_errpush(info,name,a_err='Inconsistent max_levs')
goto 9999
end if
if (mnaggratio /= p%min_aggr_ratio) then
if (mnaggratio /= p%min_cr_ratio) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent min_aggr_ratio')
call psb_errpush(info,name,a_err='Inconsistent min_cr_ratio')
goto 9999
end if
if (iszv /= size(p%precv)) then
@@ -220,8 +219,8 @@ subroutine mld_s_extprol_bld(a,desc_a,p,prolv,restrv,info,amold,vmold,imold)
endif
!
nplevs = nrestrv + 1
p%max_prec_levs = nplevs
nplevs = nrestrv + 1
p%max_levs = nplevs
!
! Fixed number of levels.
@@ -366,9 +365,9 @@ contains
allocate(nlaggr(np),ilaggr(1))
nlaggr = 0
ilaggr = 0
p%parms%aggr_alg = mld_ext_aggr_
call mld_check_def(p%parms%ml_type,'Multilevel type',&
& mld_mult_ml_,is_legal_ml_type)
p%parms%par_aggr_alg = mld_ext_aggr_
call mld_check_def(p%parms%ml_cycle,'Multilevel cycle',&
& mld_mult_ml_,is_legal_ml_cycle)
call mld_check_def(p%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_legal_ml_coarse_mat)
mlprec/impl/mld_s_hierarchy_bld.f90
+19 -35
View File
@@ -78,19 +78,19 @@ subroutine mld_s_hierarchy_bld(a,desc_a,prec,info)
type(psb_desc_type), intent(inout), target :: desc_a
class(mld_sprec_type),intent(inout),target :: prec
integer(psb_ipk_), intent(out) :: info
!!$ character, intent(in), optional :: upd
! Local Variables
integer(psb_ipk_) :: ictxt, me,np
integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs, iaggsize
real(psb_spk_) :: mnaggratio, sizeratio, athresh, ascale, aomega
class(mld_s_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm, base_sm2, med_sm2, coarse_sm2
integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize,&
& nplevs, mxplevs, iaggsize
real(psb_spk_) :: mnaggratio, sizeratio, athresh, aomega
class(mld_s_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm, &
& base_sm2, med_sm2, coarse_sm2
type(mld_sml_parms) :: baseparms, medparms, coarseparms
integer(psb_ipk_), allocatable :: ilaggr(:), nlaggr(:)
type(psb_sspmat_type) :: op_prol
type(mld_s_onelev_type), allocatable :: tprecv(:)
integer(psb_ipk_) :: int_err(5)
character :: upd_
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name, ch_err
@@ -111,21 +111,6 @@ subroutine mld_s_hierarchy_bld(a,desc_a,prec,info)
& write(debug_unit,*) me,' ',trim(name),&
& 'Entering '
!
! For the time being we are commenting out the UPDATE argument
! we plan to resurrect it later.
! !$ if (present(upd)) then
! !$ if (debug_level >= psb_debug_outer_) &
! !$ & write(debug_unit,*) me,' ',trim(name),'UPD ', upd
! !$
! !$ if ((psb_toupper(upd).eq.'F').or.(psb_toupper(upd).eq.'T')) then
! !$ upd_=psb_toupper(upd)
! !$ else
! !$ upd_='F'
! !$ endif
! !$ else
! !$ upd_='F'
! !$ endif
upd_ = 'F'
if (.not.allocated(prec%precv)) then
!! Error: should have called mld_sprecinit
@@ -138,28 +123,27 @@ subroutine mld_s_hierarchy_bld(a,desc_a,prec,info)
! Check to ensure all procs have the same
!
newsz = -1
casize = prec%coarse_aggr_size
mxplevs = prec%max_prec_levs
mnaggratio = prec%min_aggr_ratio
casize = prec%coarse_aggr_size
mxplevs = prec%max_levs
mnaggratio = prec%min_cr_ratio
casize = prec%min_coarse_size
iszv = size(prec%precv)
call psb_bcast(ictxt,iszv)
call psb_bcast(ictxt,casize)
call psb_bcast(ictxt,mxplevs)
call psb_bcast(ictxt,mnaggratio)
if (casize /= prec%coarse_aggr_size) then
if (casize /= prec%min_coarse_size) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent coarse_aggr_size')
call psb_errpush(info,name,a_err='Inconsistent min_coarse_size')
goto 9999
end if
if (mxplevs /= prec%max_prec_levs) then
if (mxplevs /= prec%max_levs) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent max_prec_levs')
call psb_errpush(info,name,a_err='Inconsistent max_levs')
goto 9999
end if
if (mnaggratio /= prec%min_aggr_ratio) then
if (mnaggratio /= prec%min_cr_ratio) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent min_aggr_ratio')
call psb_errpush(info,name,a_err='Inconsistent min_cr_ratio')
goto 9999
end if
if (iszv /= size(prec%precv)) then
@@ -198,18 +182,20 @@ subroutine mld_s_hierarchy_bld(a,desc_a,prec,info)
! 3. If the size of the array is different from target number of levels,
! reallocate;
! 4. Build the matrix hierarchy, stopping early if either the target
! coarse size is hit, or the gain falls below the min_aggr_ratio
! coarse size is hit, or the gain falls below the min_cr_ratio
! threshold.
!
if (casize <=0) then
if (casize < 0) then
!
! Default to the cubic root of the size at base level.
!
casize = desc_a%get_global_rows()
casize = int((sone*casize)**(sone/(sone*3)),psb_ipk_)
casize = max(casize,ione)
casize = casize*40_psb_ipk_
casize = casize*40_psb_ipk_
call psb_bcast(ictxt,casize)
prec%min_coarse_size = casize
end if
nplevs = max(itwo,mxplevs)
@@ -357,11 +343,9 @@ subroutine mld_s_hierarchy_bld(a,desc_a,prec,info)
! of distr/repl matrix at coarse level. Should be rethought.
!
athresh = prec%precv(newsz)%parms%aggr_thresh
ascale = prec%precv(newsz)%parms%aggr_scale
aomega = prec%precv(newsz)%parms%aggr_omega_val
if (info == 0) prec%precv(newsz)%parms = coarseparms
prec%precv(newsz)%parms%aggr_thresh = athresh
prec%precv(newsz)%parms%aggr_scale = ascale
prec%precv(newsz)%parms%aggr_omega_val = aomega
if (info == 0) call restore_smoothers(prec%precv(newsz),coarse_sm,coarse_sm2,info)
mlprec/impl/mld_s_lev_aggrmap_bld.f90
+8 -8
View File
@@ -108,15 +108,15 @@ subroutine mld_s_lev_aggrmap_bld(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
ictxt = desc_a%get_context()
call psb_info(ictxt,me,np)
call mld_check_def(p%parms%ml_type,'Multilevel type',&
& mld_mult_ml_,is_legal_ml_type)
call mld_check_def(p%parms%aggr_alg,'Aggregation',&
& mld_dec_aggr_,is_legal_ml_aggr_alg)
call mld_check_def(p%parms%ml_cycle,'Multilevel cycle',&
& mld_mult_ml_,is_legal_ml_cycle)
call mld_check_def(p%parms%par_aggr_alg,'Aggregation',&
& mld_dec_aggr_,is_legal_ml_par_aggr_alg)
call mld_check_def(p%parms%aggr_ord,'Ordering',&
& mld_aggr_ord_nat_,is_legal_ml_aggr_ord)
call mld_check_def(p%parms%aggr_thresh,'Aggr_Thresh',szero,is_legal_s_aggr_thrs)
select case(p%parms%aggr_alg)
select case(p%parms%par_aggr_alg)
case (mld_dec_aggr_, mld_sym_dec_aggr_)
!
@@ -125,7 +125,7 @@ subroutine mld_s_lev_aggrmap_bld(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
! aggregation algorithm. This also defines a tentative prolongator from
! the coarse to the fine level.
!
call mld_aggrmap_bld(p%parms%aggr_alg,p%parms%aggr_ord,p%parms%aggr_thresh,&
call mld_aggrmap_bld(p%parms%par_aggr_alg,p%parms%aggr_ord,p%parms%aggr_thresh,&
& a,desc_a,ilaggr,nlaggr,op_prol,info)
if (info /= psb_success_) then
@@ -137,14 +137,14 @@ subroutine mld_s_lev_aggrmap_bld(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
write(0,*) 'Matching is not implemented yet '
info = -1111
call psb_errpush(psb_err_input_value_invalid_i_,name,&
& i_err=(/ione,p%parms%aggr_alg,izero,izero,izero/))
& i_err=(/ione,p%parms%par_aggr_alg,izero,izero,izero/))
goto 9999
case default
info = -1
call psb_errpush(psb_err_input_value_invalid_i_,name,&
& i_err=(/ione,p%parms%aggr_alg,izero,izero,izero/))
& i_err=(/ione,p%parms%par_aggr_alg,izero,izero,izero/))
goto 9999
end select
mlprec/impl/mld_s_lev_aggrmat_asb.f90
+3 -5
View File
@@ -121,14 +121,12 @@ subroutine mld_s_lev_aggrmat_asb(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
ictxt = desc_a%get_context()
call psb_info(ictxt,me,np)
call mld_check_def(p%parms%aggr_kind,'Smoother',&
& mld_smooth_prol_,is_legal_ml_aggr_kind)
call mld_check_def(p%parms%aggr_prol,'Smoother',&
& mld_smooth_prol_,is_legal_ml_aggr_prol)
call mld_check_def(p%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_legal_ml_coarse_mat)
call mld_check_def(p%parms%aggr_filter,'Use filtered matrix',&
& mld_no_filter_mat_,is_legal_aggr_filter)
call mld_check_def(p%parms%smoother_pos,'smooth_pos',&
& mld_pre_smooth_,is_legal_ml_smooth_pos)
call mld_check_def(p%parms%aggr_omega_alg,'Omega Alg.',&
& mld_eig_est_,is_legal_ml_aggr_omega_alg)
call mld_check_def(p%parms%aggr_eig,'Eigenvalue estimate',&
@@ -139,7 +137,7 @@ subroutine mld_s_lev_aggrmat_asb(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
!
! Build the coarse-level matrix from the fine-level one, starting from
! the mapping defined by mld_aggrmap_bld and applying the aggregation
! algorithm specified by p%iprcparm(mld_aggr_kind_)
! algorithm specified by p%iprcparm(mld_aggr_prol_)
!
call mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p%parms,ac,op_prol,op_restr,info)
mlprec/impl/mld_s_smoothers_bld.f90
+95 -21
View File
@@ -1,3 +1,5 @@
!
!
! MLD2P4 version 2.1
@@ -95,15 +97,13 @@ subroutine mld_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
class(psb_s_base_sparse_mat), intent(in), optional :: amold
class(psb_s_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
!!$ character, intent(in), optional :: upd
! Local Variables
integer(psb_ipk_) :: ictxt, me,np
integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs
real(psb_spk_) :: mnaggratio
integer(psb_ipk_) :: ipv(mld_ifpsz_), val
integer(psb_ipk_) :: ipv(mld_ifpsz_), val, coarse_solve_id
integer(psb_ipk_) :: int_err(5)
character :: upd_
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name, ch_err
@@ -124,22 +124,6 @@ subroutine mld_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& write(debug_unit,*) me,' ',trim(name),&
& 'Entering '
!
! For the time being we are commenting out the UPDATE argument
! we plan to resurrect it later.
! !$ if (present(upd)) then
! !$ if (debug_level >= psb_debug_outer_) &
! !$ & write(debug_unit,*) me,' ',trim(name),'UPD ', upd
! !$
! !$ if ((psb_toupper(upd).eq.'F').or.(psb_toupper(upd).eq.'T')) then
! !$ upd_=psb_toupper(upd)
! !$ else
! !$ upd_='F'
! !$ endif
! !$ else
! !$ upd_='F'
! !$ endif
upd_ = 'F'
if (.not.allocated(prec%precv)) then
!! Error: should have called mld_sprecinit
info=3111
@@ -165,7 +149,7 @@ subroutine mld_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
!
! Now do the real build.
!
@@ -184,7 +168,97 @@ subroutine mld_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
endif
end do
!
! Issue a warning for inconsistent changes to COARSE_SOLVE
!
if (me == psb_root_) then
coarse_solve_id = prec%precv(iszv)%parms%coarse_solve
select case (coarse_solve_id)
case(mld_umf_,mld_slu_)
if (prec%precv(iszv)%sm%sv%get_id() /= coarse_solve_id) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id)
write(psb_err_unit,*) ' but I am building ',&
& mld_fact_names(prec%precv(iszv)%sm%sv%get_id())
write(psb_err_unit,*) 'This may happen if: '
write(psb_err_unit,*) ' 1. coarse_subsolve has been reset, or '
write(psb_err_unit,*) ' 2. the solver ', mld_fact_names(coarse_solve_id),&
& ' was not configured at MLD2P4 build time, or'
write(psb_err_unit,*) ' 3. an unsupported solver setup was specified.'
end if
if (prec%precv(iszv)%parms%coarse_mat /= mld_repl_mat_) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to distributed'
end if
case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
if (prec%precv(iszv)%sm%sv%get_id() /= mld_ilu_n_) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id)
write(psb_err_unit,*) ' but I am building ',&
& mld_fact_names(prec%precv(iszv)%sm%sv%get_id())
write(psb_err_unit,*) &
&'This may happen if coarse_subsolve has been reset'
end if
if (prec%precv(iszv)%parms%coarse_mat /= mld_repl_mat_) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to distributed'
end if
case(mld_mumps_)
if (prec%precv(iszv)%sm%sv%get_id() /= mld_mumps_) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id)
write(psb_err_unit,*) ' but I am building ',&
& mld_fact_names(prec%precv(iszv)%sm%sv%get_id())
write(psb_err_unit,*) &
&'This may happen if coarse_subsolve has been reset'
end if
case(mld_sludist_)
if (prec%precv(iszv)%sm%sv%get_id() /= coarse_solve_id) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id)
write(psb_err_unit,*) ' but I am building ',&
& mld_fact_names(prec%precv(iszv)%sm%sv%get_id())
write(psb_err_unit,*) 'This may happen if: '
write(psb_err_unit,*) ' 1. coarse_subsolve has been reset, or '
write(psb_err_unit,*) ' 2. the solver ', mld_fact_names(coarse_solve_id), &
& ' was not configured at MLD2P4 build time, or'
write(psb_err_unit,*) ' 3. an unsupported solver setup was specified.'
end if
if (prec%precv(iszv)%parms%coarse_mat /= mld_distr_mat_) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to replicated'
end if
case(mld_bjac_)
if (prec%precv(iszv)%parms%coarse_mat /= mld_distr_mat_) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to replicated'
end if
case default
! We should never get here.
info=psb_err_from_subroutine_
ch_err='unkn coarse_solve'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end select
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Exiting with',iszv,' levels'
mlprec/impl/mld_saggrmat_asb.f90
+2 -2
View File
@@ -52,7 +52,7 @@
! A mapping from the nodes of the adjacency graph of A to the nodes of the
! adjacency graph of A_C has been computed by the mld_aggrmap_bld subroutine.
! The prolongator P_C is built here from this mapping, according to the
! value of p%iprcparm(mld_aggr_kind_), specified by the user through
! value of p%iprcparm(mld_aggr_prol_), specified by the user through
! mld_sprecinit and mld_zprecset.
! On output from this routine the entries of AC, op_prol, op_restr
! are still in "global numbering" mode; this is fixed in the calling routine
@@ -153,7 +153,7 @@ subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,inf
call psb_info(ictxt, me, np)
select case (parms%aggr_kind)
select case (parms%aggr_prol)
case (mld_no_smooth_)
call mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,&
mlprec/impl/mld_saggrmat_biz_asb.f90
+1 -1
View File
@@ -342,7 +342,7 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
call psb_numbmm(a,tmp_prol,am3)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_
& 'Done NUMBMM 2',parms%aggr_prol, mld_smooth_prol_
call tmp_prol%transp(op_restr)
if (debug_level >= psb_debug_outer_) &
mlprec/impl/mld_saggrmat_smth_asb.f90
+1 -1
View File
@@ -352,7 +352,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done SPSPMM 2',parms%aggr_kind, mld_smooth_prol_
& 'Done SPSPMM 2',parms%aggr_prol, mld_smooth_prol_
call tmp_prol%cp_to(tmpcoo)
call tmpcoo%transp()
mlprec/impl/mld_scprecset.F90
+15 -31
View File
@@ -135,11 +135,11 @@ subroutine mld_scprecseti(p,what,val,info,ilev,ilmax,pos)
select case(psb_toupper(what))
case ('COARSE_AGGR_SIZE')
p%coarse_aggr_size = max(val,-1)
case ('MIN_COARSE_SIZE')
p%min_coarse_size = max(val,-1)
return
case('MAX_PREC_LEVS')
p%max_prec_levs = max(val,1)
case('MAX_LEVS')
p%max_levs = max(val,1)
return
case ('OUTER_SWEEPS')
p%outer_sweeps = max(val,1)
@@ -162,11 +162,9 @@ subroutine mld_scprecseti(p,what,val,info,ilev,ilmax,pos)
select case(psb_toupper(what))
case('SMOOTHER_TYPE','SUB_SOLVE','SMOOTHER_SWEEPS',&
& 'ML_TYPE','AGGR_ALG','AGGR_ORD',&
& 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',&
& 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',&
& 'SMOOTHER_SWEEPS_POST',&
& 'SUB_RESTR','SUB_PROL', &
& 'ML_CYCLE','PAR_AGGR_ALG','AGGR_ORD',&
& 'AGGR_TYPE','AGGR_PROL','AGGR_OMEGA_ALG',&
& 'AGGR_EIG','SUB_RESTR','SUB_PROL', &
& 'SUB_REN','SUB_OVR','SUB_FILLIN',&
& 'COARSE_MAT')
call p%precv(ilev_)%set(what,val,info,pos=pos)
@@ -200,11 +198,11 @@ subroutine mld_scprecseti(p,what,val,info,ilev,ilmax,pos)
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
#endif
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
case(mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
case(mld_sludist_,mld_mumps_)
case(mld_mumps_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
@@ -253,10 +251,8 @@ subroutine mld_scprecseti(p,what,val,info,ilev,ilmax,pos)
if (info /= 0) return
end do
case('ML_TYPE','AGGR_ALG','AGGR_ORD','AGGR_KIND',&
& 'SMOOTHER_SWEEPS_PRE','SMOOTHER_SWEEPS_POST',&
& 'SMOOTHER_POS','AGGR_OMEGA_ALG',&
& 'AGGR_EIG','AGGR_FILTER')
case('ML_CYCLE','PAR_AGGR_ALG','AGGR_ORD','AGGR_PROL','AGGR_TYPE',&
& 'AGGR_OMEGA_ALG','AGGR_EIG','AGGR_FILTER')
do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info,pos=pos)
if (info /= 0) return
@@ -281,11 +277,11 @@ subroutine mld_scprecseti(p,what,val,info,ilev,ilmax,pos)
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
#endif
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
case(mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
case(mld_sludist_,mld_mumps_)
case(mld_mumps_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
@@ -478,8 +474,8 @@ subroutine mld_scprecsetr(p,what,val,info,ilev,ilmax,pos)
end if
select case(psb_toupper(what))
case ('MIN_AGGR_RATIO')
p%min_aggr_ratio = max(sone,val)
case ('MIN_CR_RATIO')
p%min_cr_ratio = max(sone,val)
return
end select
@@ -517,18 +513,6 @@ subroutine mld_scprecsetr(p,what,val,info,ilev,ilmax,pos)
ilev_=nlev_
call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos)
case('AGGR_SCALE')
do ilev_ = 2, nlev_
call p%precv(ilev_)%set('AGGR_SCALE',val,info,pos=pos)
end do
case('AGGR_THRESH')
thr = val
do ilev_ = 2, nlev_
call p%precv(ilev_)%set('AGGR_THRESH',thr,info,pos=pos)
thr = thr * p%precv(ilev_)%parms%aggr_scale
end do
case default
do ilev_=1,nlev_
mlprec/impl/mld_smlprec_aply.f90
+18 -82
View File
@@ -518,7 +518,7 @@ contains
write(debug_unit,*) me,' Start inner_ml_aply at level ',level
end if
select case(p%precv(level)%parms%ml_type)
select case(p%precv(level)%parms%ml_cycle)
case(mld_no_ml_)
!
@@ -532,39 +532,7 @@ contains
call mld_s_inner_add(p, mlprec_wrk, level, trans, work)
case(mld_mult_ml_)
!
! Multiplicative multilevel (multiplicative among the levels, additive inside
! each level)
!
! Pre/post-smoothing versions.
! Note that the transpose switches pre <-> post.
!
select case(p%precv(level)%parms%smoother_pos)
case(mld_post_smooth_)
p%precv(level)%parms%sweeps_pre = 0
call mld_s_inner_mult(p, mlprec_wrk, level, trans, work)
case(mld_pre_smooth_)
p%precv(level)%parms%sweeps_post = 0
call mld_s_inner_mult(p, mlprec_wrk, level, trans, work)
case(mld_twoside_smooth_)
call mld_s_inner_mult(p, mlprec_wrk, level, trans, work)
case default
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='invalid smooth_pos',&
& i_Err=(/p%precv(level)%parms%smoother_pos,izero,izero,izero,izero/))
goto 9999
end select
case(mld_vcycle_ml_, mld_wcycle_ml_)
case(mld_mult_ml_,mld_vcycle_ml_, mld_wcycle_ml_)
call mld_s_inner_mult(p, mlprec_wrk, level, trans, work)
@@ -574,8 +542,8 @@ contains
case default
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='invalid mltype',&
& i_Err=(/p%precv(level)%parms%ml_type,izero,izero,izero,izero/))
call psb_errpush(info,name,a_err='invalid ml_cycle',&
& i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
goto 9999
end select
@@ -643,7 +611,7 @@ contains
goto 9999
end if
sweeps = p%precv(level)%parms%sweeps
sweeps = p%precv(level)%parms%sweeps_pre
call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
@@ -821,7 +789,7 @@ contains
goto 9999
end if
if (p%precv(level)%parms%ml_type == mld_wcycle_ml_) then
if (p%precv(level)%parms%ml_cycle == mld_wcycle_ml_) then
call psb_geaxpby(sone,mlprec_wrk(level)%vx2l,&
& szero,mlprec_wrk(level)%vty,&
@@ -894,7 +862,7 @@ contains
else if (level == nlev) then
sweeps = p%precv(level)%parms%sweeps
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
@@ -976,7 +944,7 @@ contains
!
! Apply smoother
!
sweeps = p%precv(level)%parms%sweeps
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
@@ -1036,13 +1004,13 @@ contains
!Set the preconditioner
if (level <= nlev - 2 ) then
if (p%precv(level)%parms%ml_type == mld_kcyclesym_ml_) then
if (p%precv(level)%parms%ml_cycle == mld_kcyclesym_ml_) then
call mld_sinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'FCG')
elseif (p%precv(level)%parms%ml_type == mld_kcycle_ml_) then
elseif (p%precv(level)%parms%ml_cycle == mld_kcycle_ml_) then
call mld_sinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'GCR')
else
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Bad value for ml_type')
& a_err='Bad value for ml_cycle')
goto 9999
endif
else
@@ -1466,7 +1434,7 @@ contains
write(debug_unit,*) me,' inner_ml_aply at level ',level
end if
select case(p%precv(level)%parms%ml_type)
select case(p%precv(level)%parms%ml_cycle)
case(mld_no_ml_)
!
@@ -1480,39 +1448,7 @@ contains
call mld_s_inner_add(p, mlprec_wrk, level, trans, work)
case(mld_mult_ml_)
!
! Multiplicative multilevel (multiplicative among the levels, additive inside
! each level)
!
! Pre/post-smoothing versions.
! Note that the transpose switches pre <-> post.
!
select case(p%precv(level)%parms%smoother_pos)
case(mld_post_smooth_)
p%precv(level)%parms%sweeps_pre = 0
call mld_s_inner_mult(p, mlprec_wrk, level, trans, work)
case(mld_pre_smooth_)
p%precv(level)%parms%sweeps_post = 0
call mld_s_inner_mult(p, mlprec_wrk, level, trans, work)
case(mld_twoside_smooth_)
call mld_s_inner_mult(p, mlprec_wrk, level, trans, work)
case default
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='invalid smooth_pos',&
& i_Err=(/p%precv(level)%parms%smoother_pos,izero,izero,izero,izero/))
goto 9999
end select
case(mld_vcycle_ml_, mld_wcycle_ml_)
case(mld_mult_ml_, mld_vcycle_ml_, mld_wcycle_ml_)
call mld_s_inner_mult(p, mlprec_wrk, level, trans, work)
@@ -1522,8 +1458,8 @@ contains
case default
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='invalid mltype',&
& i_Err=(/p%precv(level)%parms%ml_type,izero,izero,izero,izero/))
call psb_errpush(info,name,a_err='invalid ml_cycle',&
& i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
goto 9999
end select
@@ -1588,7 +1524,7 @@ contains
goto 9999
end if
sweeps = p%precv(level)%parms%sweeps
sweeps = p%precv(level)%parms%sweeps_pre
call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
@@ -1766,7 +1702,7 @@ contains
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (p%precv(level)%parms%ml_type == mld_wcycle_ml_) then
if (p%precv(level)%parms%ml_cycle == mld_wcycle_ml_) then
! On second call will use output y2l as initial guess
if (info == psb_success_) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
endif
@@ -1832,7 +1768,7 @@ contains
else if (level == nlev) then
sweeps = p%precv(level)%parms%sweeps
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
mlprec/impl/mld_smlprec_bld.f90
-2
View File
@@ -94,7 +94,6 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold,imold)
class(psb_s_base_sparse_mat), intent(in), optional :: amold
class(psb_s_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
!!$ character, intent(in), optional :: upd
! Local Variables
integer(psb_ipk_) :: ictxt, me,np
@@ -102,7 +101,6 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold,imold)
real(psb_spk_) :: mnaggratio
integer(psb_ipk_) :: ipv(mld_ifpsz_), val
integer(psb_ipk_) :: int_err(5)
character :: upd_
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name, ch_err
mlprec/impl/mld_sprecaply.f90
+6 -3
View File
@@ -144,7 +144,8 @@ subroutine mld_sprecaply(prec,x,y,desc_data,info,trans,work)
! Number of levels = 1: apply the base preconditioner
!
call prec%precv(1)%sm%apply(sone,x,szero,y,desc_data,trans_,&
& prec%precv(1)%parms%sweeps, work_,info)
& max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post), &
& work_,info)
else
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='Invalid size of precv',&
@@ -336,7 +337,8 @@ subroutine mld_sprecaply2_vect(prec,x,y,desc_data,info,trans,work)
! Number of levels = 1: apply the base preconditioner
!
call prec%precv(1)%sm%apply(sone,x,szero,y,desc_data,trans_,&
& prec%precv(1)%parms%sweeps, work_,info)
& max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post),&
& work_,info)
else
@@ -438,7 +440,8 @@ subroutine mld_sprecaply1_vect(prec,x,desc_data,info,trans,work)
! Number of levels = 1: apply the base preconditioner
!
call prec%precv(1)%sm%apply(sone,x,szero,ww,desc_data,trans_,&
& prec%precv(1)%parms%sweeps, work_,info)
& max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post),&
& work_,info)
else
mlprec/impl/mld_sprecbld.f90
+1 -18
View File
@@ -74,7 +74,6 @@ subroutine mld_sprecbld(a,desc_a,prec,info,amold,vmold,imold)
class(psb_s_base_sparse_mat), intent(in), optional :: amold
class(psb_s_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
!!$ character, intent(in), optional :: upd
! Local Variables
type(mld_sprec_type) :: t_prec
@@ -82,7 +81,6 @@ subroutine mld_sprecbld(a,desc_a,prec,info,amold,vmold,imold)
integer(psb_ipk_) :: err,i,k,err_act, iszv, newsz
integer(psb_ipk_) :: ipv(mld_ifpsz_), val
integer(psb_ipk_) :: int_err(5)
character :: upd_
type(mld_dml_parms) :: prm
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name, ch_err
@@ -105,21 +103,6 @@ subroutine mld_sprecbld(a,desc_a,prec,info,amold,vmold,imold)
& write(debug_unit,*) me,' ',trim(name),&
& 'Entering '
!
! For the time being we are commenting out the UPDATE argument
! we plan to resurrect it later.
!!$ if (present(upd)) then
!!$ if (debug_level >= psb_debug_outer_) &
!!$ & write(debug_unit,*) me,' ',trim(name),'UPD ', upd
!!$
!!$ if ((psb_toupper(upd).eq.'F').or.(psb_toupper(upd).eq.'T')) then
!!$ upd_=psb_toupper(upd)
!!$ else
!!$ upd_='F'
!!$ endif
!!$ else
!!$ upd_='F'
!!$ endif
upd_ = 'F'
if (.not.allocated(prec%precv)) then
!! Error: should have called mld_sprecinit
@@ -174,7 +157,7 @@ subroutine mld_sprecbld(a,desc_a,prec,info,amold,vmold,imold)
goto 9999
endif
call prec%precv(1)%sm%build(a,desc_a,upd_,info,&
call prec%precv(1)%sm%build(a,desc_a,info,&
& amold=amold,vmold=vmold,imold=imold)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
mlprec/impl/mld_sprecinit.F90
+22 -7
View File
@@ -108,7 +108,7 @@ subroutine mld_sprecinit(prec,ptype,info)
! Local variables
integer(psb_ipk_) :: nlev_, ilev_
real(psb_spk_) :: thr, scale
real(psb_spk_) :: thr
character(len=*), parameter :: name='mld_precinit'
info = psb_success_
@@ -118,7 +118,7 @@ subroutine mld_sprecinit(prec,ptype,info)
! Do we want to do something?
endif
endif
prec%coarse_aggr_size = -1
prec%min_coarse_size = -1
select case(psb_toupper(ptype(1:len_trim(ptype))))
case ('NOPREC','NONE')
@@ -160,9 +160,26 @@ subroutine mld_sprecinit(prec,ptype,info)
case ('ML')
nlev_ = prec%max_prec_levs
nlev_ = prec%max_levs
ilev_ = 1
allocate(prec%precv(nlev_),stat=info)
allocate(prec%precv(nlev_),stat=info)
#if 1
do ilev_ = 1, nlev_
call prec%precv(ilev_)%default()
end do
call prec%set('ML_CYCLE','VCYCLE',info)
call prec%set('SMOOTHER_TYPE','FBGS',info)
#if defined(HAVE_MUMPS_)
call prec%set('COARSE_SOLVE','MUMPS',info)
#elif defined(HAVE_SLU_)
call prec%set('COARSE_SOLVE','SLU',info)
#else
call prec%set('COARSE_SOLVE','ILU',info)
#endif
!call prec%precv(nlev_)%default()
#else
allocate(mld_s_as_smoother_type :: prec%precv(ilev_)%sm, stat=info)
if (info /= psb_success_) return
allocate(mld_s_ilu_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
@@ -193,13 +210,11 @@ subroutine mld_sprecinit(prec,ptype,info)
call prec%precv(ilev_)%set(mld_sub_ovr_,izero,info)
thr = 0.05_psb_spk_
scale = 1.0_psb_spk_
do ilev_=1,nlev_
call prec%precv(ilev_)%set(mld_aggr_thresh_,thr,info)
call prec%precv(ilev_)%set(mld_aggr_scale_,scale,info)
call prec%precv(ilev_)%set(mld_aggr_filter_,mld_filter_mat_,info)
end do
#endif
case default
write(psb_err_unit,*) name,&
&': Warning: Unknown preconditioner type request "',ptype,'"'
mlprec/impl/mld_sprecset.F90
+12 -32
View File
@@ -134,11 +134,11 @@ subroutine mld_sprecseti(p,what,val,info,ilev,ilmax,pos)
select case(what)
case (mld_coarse_aggr_size_)
p%coarse_aggr_size = max(val,-1)
case (mld_min_coarse_size_)
p%min_coarse_size = max(val,-1)
return
case(mld_max_prec_levs_)
p%max_prec_levs = max(val,1)
case(mld_max_levs_)
p%max_levs = max(val,1)
return
case(mld_outer_sweeps_)
p%outer_sweeps = max(val,1)
@@ -158,10 +158,8 @@ subroutine mld_sprecseti(p,what,val,info,ilev,ilmax,pos)
select case(what)
case(mld_smoother_type_,mld_sub_solve_,mld_smoother_sweeps_,&
& mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,&
& mld_aggr_kind_,mld_smoother_pos_,&
& mld_aggr_omega_alg_,mld_aggr_eig_,&
& mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,&
& mld_ml_cycle_,mld_par_aggr_alg_,mld_aggr_ord_,mld_aggr_type_,&
& mld_aggr_prol_, mld_aggr_omega_alg_,mld_aggr_eig_,&
& mld_sub_restr_,mld_sub_prol_, &
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,&
& mld_coarse_mat_)
@@ -196,11 +194,11 @@ subroutine mld_sprecseti(p,what,val,info,ilev,ilmax,pos)
call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos)
#endif
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
case(mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos)
case(mld_sludist_,mld_mumps_)
case(mld_mumps_)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
@@ -248,9 +246,7 @@ subroutine mld_sprecseti(p,what,val,info,ilev,ilmax,pos)
if (info /= 0) return
end do
case(mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,mld_aggr_kind_,&
& mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,&
& mld_smoother_pos_,mld_aggr_omega_alg_,&
case(mld_ml_cycle_,mld_par_aggr_alg_,mld_aggr_ord_,mld_aggr_type_,mld_aggr_prol_,&
& mld_aggr_eig_,mld_aggr_filter_)
do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info,pos=pos)
@@ -274,14 +270,10 @@ subroutine mld_sprecseti(p,what,val,info,ilev,ilmax,pos)
call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos)
#endif
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
case(mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos)
case(mld_sludist_)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_mumps_)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
@@ -574,8 +566,8 @@ subroutine mld_sprecsetr(p,what,val,info,ilev,ilmax,pos)
info = psb_success_
select case(what)
case (mld_min_aggr_ratio_)
p%min_aggr_ratio = max(sone,val)
case (mld_min_cr_ratio_)
p%min_cr_ratio = max(sone,val)
return
end select
@@ -619,18 +611,6 @@ subroutine mld_sprecsetr(p,what,val,info,ilev,ilmax,pos)
ilev_=nlev_
call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info,pos=pos)
case(mld_aggr_scale_)
do ilev_ = 2, nlev_
call p%precv(ilev_)%set(mld_aggr_scale_,val,info,pos=pos)
end do
case(mld_aggr_thresh_)
thr = val
do ilev_ = 2, nlev_
call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info,pos=pos)
thr = thr * p%precv(ilev_)%parms%aggr_scale
end do
case default
do ilev_=1,nlev_
mlprec/impl/mld_sslud_interface.c
-345
View File
@@ -1,345 +0,0 @@
/*
*
* MLD2P4 version 2.0
* MultiLevel Domain Decomposition Parallel Preconditioners Package
* based on PSBLAS (Parallel Sparse BLAS version 3.3)
*
* (C) Copyright 2008, 2010, 2012, 2015, 2017
*
* Salvatore Filippone Cranfield University
* Ambra Abdullahi Hassan University of Rome Tor Vergata
* Alfredo Buttari CNRS-IRIT, Toulouse
* Pasqua D'Ambra ICAR-CNR, Naples
* Daniela di Serafino University of Campania "L. Vanvitelli", Caserta
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions, and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
* 3. The name of the MLD2P4 group or the names of its contributors may
* not be used to endorse or promote products derived from this
* software without specific written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
* ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
* BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*
*
* File: mld_slud_interface.c
*
* Functions: mld_ssludist_fact, mld_ssludist_solve, mld_ssludist_free.
*
* This file is an interface to the SuperLU_dist routines for sparse factorization and
* solve. It was obtained by modifying the c_fortran_dgssv.c file from the SuperLU_dist
* source distribution; original copyright terms are reproduced below.
*
*/
/* =====================
Copyright (c) 2003, The Regents of the University of California, through
Lawrence Berkeley National Laboratory (subject to receipt of any required
approvals from U.S. Dept. of Energy)
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
(1) Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
(2) Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
(3) Neither the name of Lawrence Berkeley National Laboratory, U.S. Dept. of
Energy nor the names of its contributors may be used to endorse or promote
products derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*/
/*
* -- Distributed SuperLU routine (version 2.0) --
* Lawrence Berkeley National Lab, Univ. of California Berkeley.
* March 15, 2003
*
*/
/* as of v 3.3 SLUDist does not have a single precision interface */
#ifdef Have_SLUDist_
#undef Have_SLUDist_
#endif
#ifdef Have_SLUDist_
#include <math.h>
#include "superlu_sdefs.h"
#define HANDLE_SIZE 8
typedef struct {
SuperMatrix *A;
LUstruct_t *LUstruct;
gridinfo_t *grid;
ScalePermstruct_t *ScalePermstruct;
} factors_t;
#else
#include <stdio.h>
#endif
int mld_ssludist_fact(int n, int nl, int nnzl, int ffstr,
float *values, int *rowptr, int *colind,
void **f_factors, int nprow, int npcol)
{
/*
* This routine can be called from Fortran.
* performs LU decomposition.
*
* f_factors (input/output) void**
* On output contains the pointer pointing to
* the structure of the factored matrices.
*
*/
#ifdef Have_SLUDist_
SuperMatrix *A;
NRformat_loc *Astore;
ScalePermstruct_t *ScalePermstruct;
LUstruct_t *LUstruct;
SOLVEstruct_t SOLVEstruct;
gridinfo_t *grid;
int i, panel_size, permc_spec, relax, info;
trans_t trans;
float drop_tol = 0.0, b[1], berr[1];
mem_usage_t mem_usage;
superlu_options_t options;
SuperLUStat_t stat;
factors_t *LUfactors;
int fst_row;
int *icol,*irpt;
float *ival;
trans = NOTRANS;
grid = (gridinfo_t *) SUPERLU_MALLOC(sizeof(gridinfo_t));
superlu_gridinit(MPI_COMM_WORLD, nprow, npcol, grid);
/* Initialize the statistics variables. */
PStatInit(&stat);
fst_row = (ffstr);
A = (SuperMatrix *) malloc(sizeof(SuperMatrix));
dCreate_CompRowLoc_Matrix_dist(A, n, n, nnzl, nl, fst_row,
values, colind, rowptr,
SLU_NR_loc, SLU_D, SLU_GE);
/* Initialize ScalePermstruct and LUstruct. */
ScalePermstruct = (ScalePermstruct_t *) SUPERLU_MALLOC(sizeof(ScalePermstruct_t));
LUstruct = (LUstruct_t *) SUPERLU_MALLOC(sizeof(LUstruct_t));
ScalePermstructInit(n,n, ScalePermstruct);
#if defined(SLUD_VERSION_4)
LUstructInit(n, LUstruct);
#elif defined(SLUD_VERSION_3)
LUstructInit(n,n, LUstruct);
#else
choke_on_me;
#endif
/* Set the default input options. */
set_default_options_dist(&options);
options.IterRefine=NO;
options.PrintStat=NO;
pdgssvx(&options, A, ScalePermstruct, b, nl, 0,
grid, LUstruct, &SOLVEstruct, berr, &stat, &info);
if ( info == 0 ) {
;
} else {
printf("pdgssvx() error returns INFO= %d\n", info);
if ( info <= n ) { /* factorization completes */
;
}
}
if (options.SolveInitialized) {
dSolveFinalize(&options,&SOLVEstruct);
}
/* Save the LU factors in the factors handle */
LUfactors = (factors_t *) SUPERLU_MALLOC(sizeof(factors_t));
LUfactors->LUstruct = LUstruct;
LUfactors->grid = grid;
LUfactors->A = A;
LUfactors->ScalePermstruct = ScalePermstruct;
/* fprintf(stderr,"slud factor: LUFactors %p \n",LUfactors); */
/* fprintf(stderr,"slud factor: A %p %p\n",A,LUfactors->A); */
/* fprintf(stderr,"slud factor: grid %p %p\n",grid,LUfactors->grid); */
/* fprintf(stderr,"slud factor: LUstruct %p %p\n",LUstruct,LUfactors->LUstruct); */
*f_factors = (void *) LUfactors;
PStatFree(&stat);
return(info);
#else
fprintf(stderr," SLUDist does not have single precision, sorry.\n");
return(-1);
#endif
}
int mld_ssludist_solve(int itrans, int n, int nrhs,
float *b, int ldb, void *f_factors)
{
/*
* This routine can be called from Fortran.
* performs triangular solve
*
*/
#ifdef Have_SLUDist_
SuperMatrix *A;
ScalePermstruct_t *ScalePermstruct;
LUstruct_t *LUstruct;
SOLVEstruct_t SOLVEstruct;
gridinfo_t *grid;
int i, panel_size, permc_spec, relax, info;
trans_t trans;
float drop_tol = 0.0;
float *berr;
mem_usage_t mem_usage;
superlu_options_t options;
SuperLUStat_t stat;
factors_t *LUfactors;
LUfactors = (factors_t *) f_factors ;
A = LUfactors->A ;
LUstruct = LUfactors->LUstruct ;
grid = LUfactors->grid ;
ScalePermstruct = LUfactors->ScalePermstruct;
fprintf(stderr,"slud solve: ldb %d n %d \n",ldb,n);
/* fprintf(stderr,"slud solve: LUFactors %p \n",LUfactors); */
/* fprintf(stderr,"slud solve: A %p %p\n",A,LUfactors->A); */
/* fprintf(stderr,"slud solve: grid %p %p\n",grid,LUfactors->grid); */
/* fprintf(stderr,"slud solve: LUstruct %p %p\n",LUstruct,LUfactors->LUstruct); */
if (itrans == 0) {
trans = NOTRANS;
} else if (itrans ==1) {
trans = TRANS;
} else if (itrans ==2) {
trans = CONJ;
} else {
trans = NOTRANS;
}
/* fprintf(stderr,"Entry to sludist_solve\n"); */
berr = (float *) malloc((nrhs) *sizeof(float));
/* Initialize the statistics variables. */
PStatInit(&stat);
/* Set the default input options. */
set_default_options_dist(&options);
options.IterRefine = NO;
options.Fact = FACTORED;
options.PrintStat = NO;
pdgssvx(&options, A, ScalePermstruct, b, ldb, nrhs,
grid, LUstruct, &SOLVEstruct, berr, &stat, &info);
/* fprintf(stderr,"Float check: after solve %d %lf\n",*info,berr[0]); */
if (options.SolveInitialized) {
dSolveFinalize(&options,&SOLVEstruct);
}
PStatFree(&stat);
free(berr);
return(info);
#else
fprintf(stderr," SLUDist does not have single precision, sorry.\n");
return(-1);
#endif
}
int mld_ssludist_free(void *f_factors)
{
/*
* This routine can be called from Fortran.
*
* free all storage in the end
*
*/
#ifdef Have_SLUDist_
SuperMatrix *A;
ScalePermstruct_t *ScalePermstruct;
LUstruct_t *LUstruct;
SOLVEstruct_t SOLVEstruct;
gridinfo_t *grid;
int i, panel_size, permc_spec, relax;
trans_t trans;
float drop_tol = 0.0;
float *berr;
mem_usage_t mem_usage;
superlu_options_t options;
SuperLUStat_t stat;
factors_t *LUfactors;
if (f_factors == NULL)
return(0);
LUfactors = (factors_t *) f_factors ;
A = LUfactors->A ;
LUstruct = LUfactors->LUstruct ;
grid = LUfactors->grid ;
ScalePermstruct = LUfactors->ScalePermstruct;
// Memory leak: with SuperLU_Dist 3.3
// we either have a leak or a segfault here.
// To be investigated further.
//Destroy_CompRowLoc_Matrix_dist(A);
ScalePermstructFree(ScalePermstruct);
LUstructFree(LUstruct);
superlu_gridexit(grid);
free(grid);
free(LUstruct);
free(LUfactors);
return(0);
#else
fprintf(stderr," SLUDist does not have single precision, sorry.\n");
return(-1);
#endif
}
mlprec/impl/mld_z_extprol_bld.f90
+14 -15
View File
@@ -154,10 +154,9 @@ subroutine mld_z_extprol_bld(a,desc_a,p,prolv,restrv,info,amold,vmold,imold)
! Check to ensure all procs have the same
!
newsz = -1
casize = p%coarse_aggr_size
mxplevs = p%max_prec_levs
mnaggratio = p%min_aggr_ratio
casize = p%coarse_aggr_size
mxplevs = p%max_levs
mnaggratio = p%min_cr_ratio
casize = p%min_coarse_size
iszv = size(p%precv)
nprolv = size(prolv)
nrestrv = size(restrv)
@@ -167,19 +166,19 @@ subroutine mld_z_extprol_bld(a,desc_a,p,prolv,restrv,info,amold,vmold,imold)
call psb_bcast(ictxt,mnaggratio)
call psb_bcast(ictxt,nprolv)
call psb_bcast(ictxt,nrestrv)
if (casize /= p%coarse_aggr_size) then
if (casize /= p%min_coarse_size) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent coarse_aggr_size')
call psb_errpush(info,name,a_err='Inconsistent min_coarse_size')
goto 9999
end if
if (mxplevs /= p%max_prec_levs) then
if (mxplevs /= p%max_levs) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent max_prec_levs')
call psb_errpush(info,name,a_err='Inconsistent max_levs')
goto 9999
end if
if (mnaggratio /= p%min_aggr_ratio) then
if (mnaggratio /= p%min_cr_ratio) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent min_aggr_ratio')
call psb_errpush(info,name,a_err='Inconsistent min_cr_ratio')
goto 9999
end if
if (iszv /= size(p%precv)) then
@@ -220,8 +219,8 @@ subroutine mld_z_extprol_bld(a,desc_a,p,prolv,restrv,info,amold,vmold,imold)
endif
!
nplevs = nrestrv + 1
p%max_prec_levs = nplevs
nplevs = nrestrv + 1
p%max_levs = nplevs
!
! Fixed number of levels.
@@ -366,9 +365,9 @@ contains
allocate(nlaggr(np),ilaggr(1))
nlaggr = 0
ilaggr = 0
p%parms%aggr_alg = mld_ext_aggr_
call mld_check_def(p%parms%ml_type,'Multilevel type',&
& mld_mult_ml_,is_legal_ml_type)
p%parms%par_aggr_alg = mld_ext_aggr_
call mld_check_def(p%parms%ml_cycle,'Multilevel cycle',&
& mld_mult_ml_,is_legal_ml_cycle)
call mld_check_def(p%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_legal_ml_coarse_mat)
mlprec/impl/mld_z_hierarchy_bld.f90
+19 -35
View File
@@ -78,19 +78,19 @@ subroutine mld_z_hierarchy_bld(a,desc_a,prec,info)
type(psb_desc_type), intent(inout), target :: desc_a
class(mld_zprec_type),intent(inout),target :: prec
integer(psb_ipk_), intent(out) :: info
!!$ character, intent(in), optional :: upd
! Local Variables
integer(psb_ipk_) :: ictxt, me,np
integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs, iaggsize
real(psb_dpk_) :: mnaggratio, sizeratio, athresh, ascale, aomega
class(mld_z_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm, base_sm2, med_sm2, coarse_sm2
integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize,&
& nplevs, mxplevs, iaggsize
real(psb_dpk_) :: mnaggratio, sizeratio, athresh, aomega
class(mld_z_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm, &
& base_sm2, med_sm2, coarse_sm2
type(mld_dml_parms) :: baseparms, medparms, coarseparms
integer(psb_ipk_), allocatable :: ilaggr(:), nlaggr(:)
type(psb_zspmat_type) :: op_prol
type(mld_z_onelev_type), allocatable :: tprecv(:)
integer(psb_ipk_) :: int_err(5)
character :: upd_
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name, ch_err
@@ -111,21 +111,6 @@ subroutine mld_z_hierarchy_bld(a,desc_a,prec,info)
& write(debug_unit,*) me,' ',trim(name),&
& 'Entering '
!
! For the time being we are commenting out the UPDATE argument
! we plan to resurrect it later.
! !$ if (present(upd)) then
! !$ if (debug_level >= psb_debug_outer_) &
! !$ & write(debug_unit,*) me,' ',trim(name),'UPD ', upd
! !$
! !$ if ((psb_toupper(upd).eq.'F').or.(psb_toupper(upd).eq.'T')) then
! !$ upd_=psb_toupper(upd)
! !$ else
! !$ upd_='F'
! !$ endif
! !$ else
! !$ upd_='F'
! !$ endif
upd_ = 'F'
if (.not.allocated(prec%precv)) then
!! Error: should have called mld_zprecinit
@@ -138,28 +123,27 @@ subroutine mld_z_hierarchy_bld(a,desc_a,prec,info)
! Check to ensure all procs have the same
!
newsz = -1
casize = prec%coarse_aggr_size
mxplevs = prec%max_prec_levs
mnaggratio = prec%min_aggr_ratio
casize = prec%coarse_aggr_size
mxplevs = prec%max_levs
mnaggratio = prec%min_cr_ratio
casize = prec%min_coarse_size
iszv = size(prec%precv)
call psb_bcast(ictxt,iszv)
call psb_bcast(ictxt,casize)
call psb_bcast(ictxt,mxplevs)
call psb_bcast(ictxt,mnaggratio)
if (casize /= prec%coarse_aggr_size) then
if (casize /= prec%min_coarse_size) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent coarse_aggr_size')
call psb_errpush(info,name,a_err='Inconsistent min_coarse_size')
goto 9999
end if
if (mxplevs /= prec%max_prec_levs) then
if (mxplevs /= prec%max_levs) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent max_prec_levs')
call psb_errpush(info,name,a_err='Inconsistent max_levs')
goto 9999
end if
if (mnaggratio /= prec%min_aggr_ratio) then
if (mnaggratio /= prec%min_cr_ratio) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent min_aggr_ratio')
call psb_errpush(info,name,a_err='Inconsistent min_cr_ratio')
goto 9999
end if
if (iszv /= size(prec%precv)) then
@@ -198,18 +182,20 @@ subroutine mld_z_hierarchy_bld(a,desc_a,prec,info)
! 3. If the size of the array is different from target number of levels,
! reallocate;
! 4. Build the matrix hierarchy, stopping early if either the target
! coarse size is hit, or the gain falls below the min_aggr_ratio
! coarse size is hit, or the gain falls below the min_cr_ratio
! threshold.
!
if (casize <=0) then
if (casize < 0) then
!
! Default to the cubic root of the size at base level.
!
casize = desc_a%get_global_rows()
casize = int((done*casize)**(done/(done*3)),psb_ipk_)
casize = max(casize,ione)
casize = casize*40_psb_ipk_
casize = casize*40_psb_ipk_
call psb_bcast(ictxt,casize)
prec%min_coarse_size = casize
end if
nplevs = max(itwo,mxplevs)
@@ -357,11 +343,9 @@ subroutine mld_z_hierarchy_bld(a,desc_a,prec,info)
! of distr/repl matrix at coarse level. Should be rethought.
!
athresh = prec%precv(newsz)%parms%aggr_thresh
ascale = prec%precv(newsz)%parms%aggr_scale
aomega = prec%precv(newsz)%parms%aggr_omega_val
if (info == 0) prec%precv(newsz)%parms = coarseparms
prec%precv(newsz)%parms%aggr_thresh = athresh
prec%precv(newsz)%parms%aggr_scale = ascale
prec%precv(newsz)%parms%aggr_omega_val = aomega
if (info == 0) call restore_smoothers(prec%precv(newsz),coarse_sm,coarse_sm2,info)
mlprec/impl/mld_z_lev_aggrmap_bld.f90
+8 -8
View File
@@ -108,15 +108,15 @@ subroutine mld_z_lev_aggrmap_bld(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
ictxt = desc_a%get_context()
call psb_info(ictxt,me,np)
call mld_check_def(p%parms%ml_type,'Multilevel type',&
& mld_mult_ml_,is_legal_ml_type)
call mld_check_def(p%parms%aggr_alg,'Aggregation',&
& mld_dec_aggr_,is_legal_ml_aggr_alg)
call mld_check_def(p%parms%ml_cycle,'Multilevel cycle',&
& mld_mult_ml_,is_legal_ml_cycle)
call mld_check_def(p%parms%par_aggr_alg,'Aggregation',&
& mld_dec_aggr_,is_legal_ml_par_aggr_alg)
call mld_check_def(p%parms%aggr_ord,'Ordering',&
& mld_aggr_ord_nat_,is_legal_ml_aggr_ord)
call mld_check_def(p%parms%aggr_thresh,'Aggr_Thresh',dzero,is_legal_d_aggr_thrs)
select case(p%parms%aggr_alg)
select case(p%parms%par_aggr_alg)
case (mld_dec_aggr_, mld_sym_dec_aggr_)
!
@@ -125,7 +125,7 @@ subroutine mld_z_lev_aggrmap_bld(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
! aggregation algorithm. This also defines a tentative prolongator from
! the coarse to the fine level.
!
call mld_aggrmap_bld(p%parms%aggr_alg,p%parms%aggr_ord,p%parms%aggr_thresh,&
call mld_aggrmap_bld(p%parms%par_aggr_alg,p%parms%aggr_ord,p%parms%aggr_thresh,&
& a,desc_a,ilaggr,nlaggr,op_prol,info)
if (info /= psb_success_) then
@@ -137,14 +137,14 @@ subroutine mld_z_lev_aggrmap_bld(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
write(0,*) 'Matching is not implemented yet '
info = -1111
call psb_errpush(psb_err_input_value_invalid_i_,name,&
& i_err=(/ione,p%parms%aggr_alg,izero,izero,izero/))
& i_err=(/ione,p%parms%par_aggr_alg,izero,izero,izero/))
goto 9999
case default
info = -1
call psb_errpush(psb_err_input_value_invalid_i_,name,&
& i_err=(/ione,p%parms%aggr_alg,izero,izero,izero/))
& i_err=(/ione,p%parms%par_aggr_alg,izero,izero,izero/))
goto 9999
end select
mlprec/impl/mld_z_lev_aggrmat_asb.f90
+3 -5
View File
@@ -121,14 +121,12 @@ subroutine mld_z_lev_aggrmat_asb(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
ictxt = desc_a%get_context()
call psb_info(ictxt,me,np)
call mld_check_def(p%parms%aggr_kind,'Smoother',&
& mld_smooth_prol_,is_legal_ml_aggr_kind)
call mld_check_def(p%parms%aggr_prol,'Smoother',&
& mld_smooth_prol_,is_legal_ml_aggr_prol)
call mld_check_def(p%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_legal_ml_coarse_mat)
call mld_check_def(p%parms%aggr_filter,'Use filtered matrix',&
& mld_no_filter_mat_,is_legal_aggr_filter)
call mld_check_def(p%parms%smoother_pos,'smooth_pos',&
& mld_pre_smooth_,is_legal_ml_smooth_pos)
call mld_check_def(p%parms%aggr_omega_alg,'Omega Alg.',&
& mld_eig_est_,is_legal_ml_aggr_omega_alg)
call mld_check_def(p%parms%aggr_eig,'Eigenvalue estimate',&
@@ -139,7 +137,7 @@ subroutine mld_z_lev_aggrmat_asb(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
!
! Build the coarse-level matrix from the fine-level one, starting from
! the mapping defined by mld_aggrmap_bld and applying the aggregation
! algorithm specified by p%iprcparm(mld_aggr_kind_)
! algorithm specified by p%iprcparm(mld_aggr_prol_)
!
call mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p%parms,ac,op_prol,op_restr,info)
mlprec/impl/mld_z_smoothers_bld.f90
+95 -21
View File
@@ -1,3 +1,5 @@
!
!
! MLD2P4 version 2.1
@@ -95,15 +97,13 @@ subroutine mld_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
class(psb_z_base_sparse_mat), intent(in), optional :: amold
class(psb_z_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
!!$ character, intent(in), optional :: upd
! Local Variables
integer(psb_ipk_) :: ictxt, me,np
integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs
real(psb_dpk_) :: mnaggratio
integer(psb_ipk_) :: ipv(mld_ifpsz_), val
integer(psb_ipk_) :: ipv(mld_ifpsz_), val, coarse_solve_id
integer(psb_ipk_) :: int_err(5)
character :: upd_
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name, ch_err
@@ -124,22 +124,6 @@ subroutine mld_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& write(debug_unit,*) me,' ',trim(name),&
& 'Entering '
!
! For the time being we are commenting out the UPDATE argument
! we plan to resurrect it later.
! !$ if (present(upd)) then
! !$ if (debug_level >= psb_debug_outer_) &
! !$ & write(debug_unit,*) me,' ',trim(name),'UPD ', upd
! !$
! !$ if ((psb_toupper(upd).eq.'F').or.(psb_toupper(upd).eq.'T')) then
! !$ upd_=psb_toupper(upd)
! !$ else
! !$ upd_='F'
! !$ endif
! !$ else
! !$ upd_='F'
! !$ endif
upd_ = 'F'
if (.not.allocated(prec%precv)) then
!! Error: should have called mld_zprecinit
info=3111
@@ -165,7 +149,7 @@ subroutine mld_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
!
! Now do the real build.
!
@@ -184,7 +168,97 @@ subroutine mld_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
endif
end do
!
! Issue a warning for inconsistent changes to COARSE_SOLVE
!
if (me == psb_root_) then
coarse_solve_id = prec%precv(iszv)%parms%coarse_solve
select case (coarse_solve_id)
case(mld_umf_,mld_slu_)
if (prec%precv(iszv)%sm%sv%get_id() /= coarse_solve_id) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id)
write(psb_err_unit,*) ' but I am building ',&
& mld_fact_names(prec%precv(iszv)%sm%sv%get_id())
write(psb_err_unit,*) 'This may happen if: '
write(psb_err_unit,*) ' 1. coarse_subsolve has been reset, or '
write(psb_err_unit,*) ' 2. the solver ', mld_fact_names(coarse_solve_id),&
& ' was not configured at MLD2P4 build time, or'
write(psb_err_unit,*) ' 3. an unsupported solver setup was specified.'
end if
if (prec%precv(iszv)%parms%coarse_mat /= mld_repl_mat_) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to distributed'
end if
case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
if (prec%precv(iszv)%sm%sv%get_id() /= mld_ilu_n_) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id)
write(psb_err_unit,*) ' but I am building ',&
& mld_fact_names(prec%precv(iszv)%sm%sv%get_id())
write(psb_err_unit,*) &
&'This may happen if coarse_subsolve has been reset'
end if
if (prec%precv(iszv)%parms%coarse_mat /= mld_repl_mat_) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to distributed'
end if
case(mld_mumps_)
if (prec%precv(iszv)%sm%sv%get_id() /= mld_mumps_) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id)
write(psb_err_unit,*) ' but I am building ',&
& mld_fact_names(prec%precv(iszv)%sm%sv%get_id())
write(psb_err_unit,*) &
&'This may happen if coarse_subsolve has been reset'
end if
case(mld_sludist_)
if (prec%precv(iszv)%sm%sv%get_id() /= coarse_solve_id) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id)
write(psb_err_unit,*) ' but I am building ',&
& mld_fact_names(prec%precv(iszv)%sm%sv%get_id())
write(psb_err_unit,*) 'This may happen if: '
write(psb_err_unit,*) ' 1. coarse_subsolve has been reset, or '
write(psb_err_unit,*) ' 2. the solver ', mld_fact_names(coarse_solve_id), &
& ' was not configured at MLD2P4 build time, or'
write(psb_err_unit,*) ' 3. an unsupported solver setup was specified.'
end if
if (prec%precv(iszv)%parms%coarse_mat /= mld_distr_mat_) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to replicated'
end if
case(mld_bjac_)
if (prec%precv(iszv)%parms%coarse_mat /= mld_distr_mat_) then
write(psb_err_unit,*) &
& 'MLD2P4: Warning: original coarse solver was requested as ',&
& mld_fact_names(coarse_solve_id),&
& ' but the coarse matrix has been changed to replicated'
end if
case default
! We should never get here.
info=psb_err_from_subroutine_
ch_err='unkn coarse_solve'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end select
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Exiting with',iszv,' levels'
mlprec/impl/mld_zaggrmat_asb.f90
+2 -2
View File
@@ -52,7 +52,7 @@
! A mapping from the nodes of the adjacency graph of A to the nodes of the
! adjacency graph of A_C has been computed by the mld_aggrmap_bld subroutine.
! The prolongator P_C is built here from this mapping, according to the
! value of p%iprcparm(mld_aggr_kind_), specified by the user through
! value of p%iprcparm(mld_aggr_prol_), specified by the user through
! mld_zprecinit and mld_zprecset.
! On output from this routine the entries of AC, op_prol, op_restr
! are still in "global numbering" mode; this is fixed in the calling routine
@@ -153,7 +153,7 @@ subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,inf
call psb_info(ictxt, me, np)
select case (parms%aggr_kind)
select case (parms%aggr_prol)
case (mld_no_smooth_)
call mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,&
mlprec/impl/mld_zaggrmat_biz_asb.f90
+1 -1
View File
@@ -342,7 +342,7 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
call psb_numbmm(a,tmp_prol,am3)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_
& 'Done NUMBMM 2',parms%aggr_prol, mld_smooth_prol_
call tmp_prol%transp(op_restr)
if (debug_level >= psb_debug_outer_) &
mlprec/impl/mld_zaggrmat_smth_asb.f90
+1 -1
View File
@@ -352,7 +352,7 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done SPSPMM 2',parms%aggr_kind, mld_smooth_prol_
& 'Done SPSPMM 2',parms%aggr_prol, mld_smooth_prol_
call tmp_prol%cp_to(tmpcoo)
call tmpcoo%transp()
mlprec/impl/mld_zcprecset.F90
+31 -31
View File
@@ -141,11 +141,11 @@ subroutine mld_zcprecseti(p,what,val,info,ilev,ilmax,pos)
select case(psb_toupper(what))
case ('COARSE_AGGR_SIZE')
p%coarse_aggr_size = max(val,-1)
case ('MIN_COARSE_SIZE')
p%min_coarse_size = max(val,-1)
return
case('MAX_PREC_LEVS')
p%max_prec_levs = max(val,1)
case('MAX_LEVS')
p%max_levs = max(val,1)
return
case ('OUTER_SWEEPS')
p%outer_sweeps = max(val,1)
@@ -168,11 +168,9 @@ subroutine mld_zcprecseti(p,what,val,info,ilev,ilmax,pos)
select case(psb_toupper(what))
case('SMOOTHER_TYPE','SUB_SOLVE','SMOOTHER_SWEEPS',&
& 'ML_TYPE','AGGR_ALG','AGGR_ORD',&
& 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',&
& 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',&
& 'SMOOTHER_SWEEPS_POST',&
& 'SUB_RESTR','SUB_PROL', &
& 'ML_CYCLE','PAR_AGGR_ALG','AGGR_ORD',&
& 'AGGR_TYPE','AGGR_PROL','AGGR_OMEGA_ALG',&
& 'AGGR_EIG','SUB_RESTR','SUB_PROL', &
& 'SUB_REN','SUB_OVR','SUB_FILLIN',&
& 'COARSE_MAT')
call p%precv(ilev_)%set(what,val,info,pos=pos)
@@ -208,11 +206,19 @@ subroutine mld_zcprecseti(p,what,val,info,ilev,ilmax,pos)
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
#endif
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
case(mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
case(mld_sludist_,mld_mumps_)
case(mld_mumps_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
case(mld_umf_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
case(mld_sludist_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
@@ -261,10 +267,8 @@ subroutine mld_zcprecseti(p,what,val,info,ilev,ilmax,pos)
if (info /= 0) return
end do
case('ML_TYPE','AGGR_ALG','AGGR_ORD','AGGR_KIND',&
& 'SMOOTHER_SWEEPS_PRE','SMOOTHER_SWEEPS_POST',&
& 'SMOOTHER_POS','AGGR_OMEGA_ALG',&
& 'AGGR_EIG','AGGR_FILTER')
case('ML_CYCLE','PAR_AGGR_ALG','AGGR_ORD','AGGR_PROL','AGGR_TYPE',&
& 'AGGR_OMEGA_ALG','AGGR_EIG','AGGR_FILTER')
do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info,pos=pos)
if (info /= 0) return
@@ -291,11 +295,19 @@ subroutine mld_zcprecseti(p,what,val,info,ilev,ilmax,pos)
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
#endif
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
case(mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
case(mld_sludist_,mld_mumps_)
case(mld_mumps_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
case(mld_umf_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
case(mld_sludist_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
@@ -488,8 +500,8 @@ subroutine mld_zcprecsetr(p,what,val,info,ilev,ilmax,pos)
end if
select case(psb_toupper(what))
case ('MIN_AGGR_RATIO')
p%min_aggr_ratio = max(done,val)
case ('MIN_CR_RATIO')
p%min_cr_ratio = max(done,val)
return
end select
@@ -527,18 +539,6 @@ subroutine mld_zcprecsetr(p,what,val,info,ilev,ilmax,pos)
ilev_=nlev_
call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos)
case('AGGR_SCALE')
do ilev_ = 2, nlev_
call p%precv(ilev_)%set('AGGR_SCALE',val,info,pos=pos)
end do
case('AGGR_THRESH')
thr = val
do ilev_ = 2, nlev_
call p%precv(ilev_)%set('AGGR_THRESH',thr,info,pos=pos)
thr = thr * p%precv(ilev_)%parms%aggr_scale
end do
case default
do ilev_=1,nlev_

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