From 90e1f1cfe60b741c6f97c68cd5b13a8d6f04b53d Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 28 Aug 2020 10:36:55 +0200 Subject: [PATCH] Integration of psb_ilu & friends --- cbind/mlprec/mld_dprec_cbind_mod.F90 | 2 +- cbind/mlprec/mld_zprec_cbind_mod.F90 | 2 +- mlprec/Makefile | 6 +- mlprec/impl/level/mld_c_base_onelev_cseti.F90 | 2 +- mlprec/impl/level/mld_d_base_onelev_cseti.F90 | 2 +- mlprec/impl/level/mld_s_base_onelev_cseti.F90 | 2 +- mlprec/impl/level/mld_z_base_onelev_cseti.F90 | 2 +- mlprec/impl/mld_c_smoothers_bld.f90 | 4 +- mlprec/impl/mld_ccprecset.F90 | 24 +- mlprec/impl/mld_d_smoothers_bld.f90 | 4 +- mlprec/impl/mld_dcprecset.F90 | 24 +- mlprec/impl/mld_s_smoothers_bld.f90 | 4 +- mlprec/impl/mld_scprecset.F90 | 24 +- mlprec/impl/mld_z_smoothers_bld.f90 | 4 +- mlprec/impl/mld_zcprecset.F90 | 24 +- mlprec/impl/solver/Makefile | 13 - mlprec/impl/solver/mld_c_ilu_solver_bld.f90 | 20 +- mlprec/impl/solver/mld_cilu0_fact.f90 | 666 --------- mlprec/impl/solver/mld_ciluk_fact.f90 | 969 -------------- mlprec/impl/solver/mld_cilut_fact.f90 | 1186 ----------------- mlprec/impl/solver/mld_d_ilu_solver_bld.f90 | 20 +- mlprec/impl/solver/mld_dilu0_fact.f90 | 666 --------- mlprec/impl/solver/mld_diluk_fact.f90 | 969 -------------- mlprec/impl/solver/mld_dilut_fact.f90 | 1186 ----------------- mlprec/impl/solver/mld_s_ilu_solver_bld.f90 | 20 +- mlprec/impl/solver/mld_silu0_fact.f90 | 666 --------- mlprec/impl/solver/mld_siluk_fact.f90 | 969 -------------- mlprec/impl/solver/mld_silut_fact.f90 | 1186 ----------------- mlprec/impl/solver/mld_z_ilu_solver_bld.f90 | 20 +- mlprec/impl/solver/mld_zilu0_fact.f90 | 666 --------- mlprec/impl/solver/mld_ziluk_fact.f90 | 969 -------------- mlprec/impl/solver/mld_zilut_fact.f90 | 1186 ----------------- mlprec/mld_base_prec_type.F90 | 18 +- mlprec/mld_c_ilu_solver.f90 | 16 +- mlprec/mld_c_mumps_solver.F90 | 6 - mlprec/mld_c_slu_solver.F90 | 6 - mlprec/mld_d_ilu_solver.f90 | 16 +- mlprec/mld_d_mumps_solver.F90 | 6 - mlprec/mld_d_slu_solver.F90 | 6 - mlprec/mld_d_sludist_solver.F90 | 6 - mlprec/mld_d_umf_solver.F90 | 6 - mlprec/mld_s_ilu_solver.f90 | 16 +- mlprec/mld_s_mumps_solver.F90 | 6 - mlprec/mld_s_slu_solver.F90 | 6 - mlprec/mld_z_ilu_solver.f90 | 16 +- mlprec/mld_z_mumps_solver.F90 | 6 - mlprec/mld_z_slu_solver.F90 | 6 - mlprec/mld_z_sludist_solver.F90 | 6 - mlprec/mld_z_umf_solver.F90 | 6 - 49 files changed, 147 insertions(+), 11514 deletions(-) delete mode 100644 mlprec/impl/solver/mld_cilu0_fact.f90 delete mode 100644 mlprec/impl/solver/mld_ciluk_fact.f90 delete mode 100644 mlprec/impl/solver/mld_cilut_fact.f90 delete mode 100644 mlprec/impl/solver/mld_dilu0_fact.f90 delete mode 100644 mlprec/impl/solver/mld_diluk_fact.f90 delete mode 100644 mlprec/impl/solver/mld_dilut_fact.f90 delete mode 100644 mlprec/impl/solver/mld_silu0_fact.f90 delete mode 100644 mlprec/impl/solver/mld_siluk_fact.f90 delete mode 100644 mlprec/impl/solver/mld_silut_fact.f90 delete mode 100644 mlprec/impl/solver/mld_zilu0_fact.f90 delete mode 100644 mlprec/impl/solver/mld_ziluk_fact.f90 delete mode 100644 mlprec/impl/solver/mld_zilut_fact.f90 diff --git a/cbind/mlprec/mld_dprec_cbind_mod.F90 b/cbind/mlprec/mld_dprec_cbind_mod.F90 index c9ce13d4..5f419d43 100644 --- a/cbind/mlprec/mld_dprec_cbind_mod.F90 +++ b/cbind/mlprec/mld_dprec_cbind_mod.F90 @@ -397,7 +397,7 @@ contains call precp%descr() - call flush(output_unit) + call flush(psb_out_unit) info = 0 res = MLDC_ERR_FILTER(info) diff --git a/cbind/mlprec/mld_zprec_cbind_mod.F90 b/cbind/mlprec/mld_zprec_cbind_mod.F90 index 14793fbe..777d5c86 100644 --- a/cbind/mlprec/mld_zprec_cbind_mod.F90 +++ b/cbind/mlprec/mld_zprec_cbind_mod.F90 @@ -397,7 +397,7 @@ contains call precp%descr() - call flush(output_unit) + call flush(psb_out_unit) info = 0 res = MLDC_ERR_FILTER(info) diff --git a/mlprec/Makefile b/mlprec/Makefile index 56fd1f4c..5964ec50 100644 --- a/mlprec/Makefile +++ b/mlprec/Makefile @@ -7,7 +7,7 @@ HERE=. FINCLUDES=$(FMFLAG)$(HERE) $(FMFLAG)$(INCDIR) $(PSBLAS_INCLUDES) -DMODOBJS=mld_d_prec_type.o mld_d_ilu_fact_mod.o \ +DMODOBJS=mld_d_prec_type.o \ mld_d_inner_mod.o mld_d_ilu_solver.o mld_d_diag_solver.o mld_d_jac_smoother.o mld_d_as_smoother.o \ mld_d_umf_solver.o mld_d_slu_solver.o mld_d_sludist_solver.o mld_d_id_solver.o\ mld_d_base_solver_mod.o mld_d_base_smoother_mod.o mld_d_onelev_mod.o \ @@ -125,8 +125,8 @@ mld_s_base_solver_mod.o mld_d_base_solver_mod.o mld_c_base_solver_mod.o mld_z_ba mld_d_mumps_solver.o mld_d_gs_solver.o mld_d_id_solver.o mld_d_sludist_solver.o mld_d_slu_solver.o \ mld_d_umf_solver.o mld_d_diag_solver.o mld_d_ilu_solver.o: mld_d_base_solver_mod.o mld_d_prec_type.o -mld_d_ilu_fact_mod.o: mld_base_prec_type.o mld_d_base_solver_mod.o -mld_d_ilu_solver.o mld_d_iluk_fact.o: mld_d_ilu_fact_mod.o +#mld_d_ilu_fact_mod.o: mld_base_prec_type.o mld_d_base_solver_mod.o +#mld_d_ilu_solver.o mld_d_iluk_fact.o: mld_d_ilu_fact_mod.o mld_d_as_smoother.o mld_d_jac_smoother.o: mld_d_base_smoother_mod.o mld_d_jac_smoother.o: mld_d_diag_solver.o mld_dprecinit.o mld_dprecset.o: mld_d_diag_solver.o mld_d_ilu_solver.o \ diff --git a/mlprec/impl/level/mld_c_base_onelev_cseti.F90 b/mlprec/impl/level/mld_c_base_onelev_cseti.F90 index b497b184..f628868e 100644 --- a/mlprec/impl/level/mld_c_base_onelev_cseti.F90 +++ b/mlprec/impl/level/mld_c_base_onelev_cseti.F90 @@ -164,7 +164,7 @@ subroutine mld_c_base_onelev_cseti(lv,what,val,info,pos,idx) case (mld_bwgs_) call lv%set(mld_c_bwgs_solver_mold,info,pos=pos) - case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + case (psb_ilu_n_,psb_milu_n_,psb_ilu_t_) call lv%set(mld_c_ilu_solver_mold,info,pos=pos) if (info == 0) then if ((ipos_==mld_smooth_pre_) .or.(ipos_==mld_smooth_both_)) then diff --git a/mlprec/impl/level/mld_d_base_onelev_cseti.F90 b/mlprec/impl/level/mld_d_base_onelev_cseti.F90 index f18df8e2..015d3421 100644 --- a/mlprec/impl/level/mld_d_base_onelev_cseti.F90 +++ b/mlprec/impl/level/mld_d_base_onelev_cseti.F90 @@ -176,7 +176,7 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos,idx) case (mld_bwgs_) call lv%set(mld_d_bwgs_solver_mold,info,pos=pos) - case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + case (psb_ilu_n_,psb_milu_n_,psb_ilu_t_) call lv%set(mld_d_ilu_solver_mold,info,pos=pos) if (info == 0) then if ((ipos_==mld_smooth_pre_) .or.(ipos_==mld_smooth_both_)) then diff --git a/mlprec/impl/level/mld_s_base_onelev_cseti.F90 b/mlprec/impl/level/mld_s_base_onelev_cseti.F90 index a0caa325..8b244216 100644 --- a/mlprec/impl/level/mld_s_base_onelev_cseti.F90 +++ b/mlprec/impl/level/mld_s_base_onelev_cseti.F90 @@ -164,7 +164,7 @@ subroutine mld_s_base_onelev_cseti(lv,what,val,info,pos,idx) case (mld_bwgs_) call lv%set(mld_s_bwgs_solver_mold,info,pos=pos) - case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + case (psb_ilu_n_,psb_milu_n_,psb_ilu_t_) call lv%set(mld_s_ilu_solver_mold,info,pos=pos) if (info == 0) then if ((ipos_==mld_smooth_pre_) .or.(ipos_==mld_smooth_both_)) then diff --git a/mlprec/impl/level/mld_z_base_onelev_cseti.F90 b/mlprec/impl/level/mld_z_base_onelev_cseti.F90 index 3ce2e08f..3c678eb8 100644 --- a/mlprec/impl/level/mld_z_base_onelev_cseti.F90 +++ b/mlprec/impl/level/mld_z_base_onelev_cseti.F90 @@ -176,7 +176,7 @@ subroutine mld_z_base_onelev_cseti(lv,what,val,info,pos,idx) case (mld_bwgs_) call lv%set(mld_z_bwgs_solver_mold,info,pos=pos) - case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + case (psb_ilu_n_,psb_milu_n_,psb_ilu_t_) call lv%set(mld_z_ilu_solver_mold,info,pos=pos) if (info == 0) then if ((ipos_==mld_smooth_pre_) .or.(ipos_==mld_smooth_both_)) then diff --git a/mlprec/impl/mld_c_smoothers_bld.f90 b/mlprec/impl/mld_c_smoothers_bld.f90 index c0ad3746..b2b3079b 100644 --- a/mlprec/impl/mld_c_smoothers_bld.f90 +++ b/mlprec/impl/mld_c_smoothers_bld.f90 @@ -181,8 +181,8 @@ subroutine mld_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold) & ' but it 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 + case(psb_ilu_n_, psb_ilu_t_,psb_milu_n_) + if (prec%precv(iszv)%sm%sv%get_id() /= psb_ilu_n_) then write(psb_err_unit,*) & & 'MLD2P4: Warning: original coarse solver was requested as ',& & mld_fact_names(coarse_solve_id) diff --git a/mlprec/impl/mld_ccprecset.F90 b/mlprec/impl/mld_ccprecset.F90 index 9043de76..11b28915 100644 --- a/mlprec/impl/mld_ccprecset.F90 +++ b/mlprec/impl/mld_ccprecset.F90 @@ -198,7 +198,7 @@ subroutine mld_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx) #elif defined(HAVE_MUMPS_) call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos) #else - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) #endif call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) case(mld_slu_) @@ -212,10 +212,10 @@ subroutine mld_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif - case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_) + case(psb_ilu_n_, psb_ilu_t_,psb_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) @@ -226,7 +226,7 @@ subroutine mld_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif case(mld_umf_) @@ -240,7 +240,7 @@ subroutine mld_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif @@ -255,7 +255,7 @@ subroutine mld_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif case(mld_jac_) @@ -344,7 +344,7 @@ subroutine mld_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx) #elif defined(HAVE_MUMPS_) call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos) #else - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) #endif call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) case(mld_slu_) @@ -358,10 +358,10 @@ subroutine mld_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif - case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_) + case(psb_ilu_n_, psb_ilu_t_,psb_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) @@ -372,7 +372,7 @@ subroutine mld_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif case(mld_umf_) @@ -386,7 +386,7 @@ subroutine mld_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif @@ -401,7 +401,7 @@ subroutine mld_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif case(mld_jac_) diff --git a/mlprec/impl/mld_d_smoothers_bld.f90 b/mlprec/impl/mld_d_smoothers_bld.f90 index f7755b37..b2ac13e1 100644 --- a/mlprec/impl/mld_d_smoothers_bld.f90 +++ b/mlprec/impl/mld_d_smoothers_bld.f90 @@ -181,8 +181,8 @@ subroutine mld_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold) & ' but it 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 + case(psb_ilu_n_, psb_ilu_t_,psb_milu_n_) + if (prec%precv(iszv)%sm%sv%get_id() /= psb_ilu_n_) then write(psb_err_unit,*) & & 'MLD2P4: Warning: original coarse solver was requested as ',& & mld_fact_names(coarse_solve_id) diff --git a/mlprec/impl/mld_dcprecset.F90 b/mlprec/impl/mld_dcprecset.F90 index 70e57e18..d92d68d7 100644 --- a/mlprec/impl/mld_dcprecset.F90 +++ b/mlprec/impl/mld_dcprecset.F90 @@ -206,7 +206,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx) #elif defined(HAVE_MUMPS_) call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos) #else - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) #endif call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) case(mld_slu_) @@ -220,10 +220,10 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif - case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_) + case(psb_ilu_n_, psb_ilu_t_,psb_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) @@ -234,7 +234,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif case(mld_umf_) @@ -252,7 +252,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif @@ -275,7 +275,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif case(mld_jac_) @@ -366,7 +366,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx) #elif defined(HAVE_MUMPS_) call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos) #else - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) #endif call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) case(mld_slu_) @@ -380,10 +380,10 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif - case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_) + case(psb_ilu_n_, psb_ilu_t_,psb_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) @@ -394,7 +394,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif case(mld_umf_) @@ -412,7 +412,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif @@ -435,7 +435,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif case(mld_jac_) diff --git a/mlprec/impl/mld_s_smoothers_bld.f90 b/mlprec/impl/mld_s_smoothers_bld.f90 index fb10abc3..0abdcdab 100644 --- a/mlprec/impl/mld_s_smoothers_bld.f90 +++ b/mlprec/impl/mld_s_smoothers_bld.f90 @@ -181,8 +181,8 @@ subroutine mld_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold) & ' but it 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 + case(psb_ilu_n_, psb_ilu_t_,psb_milu_n_) + if (prec%precv(iszv)%sm%sv%get_id() /= psb_ilu_n_) then write(psb_err_unit,*) & & 'MLD2P4: Warning: original coarse solver was requested as ',& & mld_fact_names(coarse_solve_id) diff --git a/mlprec/impl/mld_scprecset.F90 b/mlprec/impl/mld_scprecset.F90 index 71ce1f09..4575fd80 100644 --- a/mlprec/impl/mld_scprecset.F90 +++ b/mlprec/impl/mld_scprecset.F90 @@ -198,7 +198,7 @@ subroutine mld_scprecseti(p,what,val,info,ilev,ilmax,pos,idx) #elif defined(HAVE_MUMPS_) call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos) #else - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) #endif call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) case(mld_slu_) @@ -212,10 +212,10 @@ subroutine mld_scprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif - case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_) + case(psb_ilu_n_, psb_ilu_t_,psb_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) @@ -226,7 +226,7 @@ subroutine mld_scprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif case(mld_umf_) @@ -240,7 +240,7 @@ subroutine mld_scprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif @@ -255,7 +255,7 @@ subroutine mld_scprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif case(mld_jac_) @@ -344,7 +344,7 @@ subroutine mld_scprecseti(p,what,val,info,ilev,ilmax,pos,idx) #elif defined(HAVE_MUMPS_) call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos) #else - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) #endif call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) case(mld_slu_) @@ -358,10 +358,10 @@ subroutine mld_scprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif - case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_) + case(psb_ilu_n_, psb_ilu_t_,psb_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) @@ -372,7 +372,7 @@ subroutine mld_scprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif case(mld_umf_) @@ -386,7 +386,7 @@ subroutine mld_scprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif @@ -401,7 +401,7 @@ subroutine mld_scprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif case(mld_jac_) diff --git a/mlprec/impl/mld_z_smoothers_bld.f90 b/mlprec/impl/mld_z_smoothers_bld.f90 index 0c1ba6aa..8172ae76 100644 --- a/mlprec/impl/mld_z_smoothers_bld.f90 +++ b/mlprec/impl/mld_z_smoothers_bld.f90 @@ -181,8 +181,8 @@ subroutine mld_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold) & ' but it 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 + case(psb_ilu_n_, psb_ilu_t_,psb_milu_n_) + if (prec%precv(iszv)%sm%sv%get_id() /= psb_ilu_n_) then write(psb_err_unit,*) & & 'MLD2P4: Warning: original coarse solver was requested as ',& & mld_fact_names(coarse_solve_id) diff --git a/mlprec/impl/mld_zcprecset.F90 b/mlprec/impl/mld_zcprecset.F90 index b5fce826..86895701 100644 --- a/mlprec/impl/mld_zcprecset.F90 +++ b/mlprec/impl/mld_zcprecset.F90 @@ -206,7 +206,7 @@ subroutine mld_zcprecseti(p,what,val,info,ilev,ilmax,pos,idx) #elif defined(HAVE_MUMPS_) call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos) #else - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) #endif call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) case(mld_slu_) @@ -220,10 +220,10 @@ subroutine mld_zcprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif - case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_) + case(psb_ilu_n_, psb_ilu_t_,psb_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) @@ -234,7 +234,7 @@ subroutine mld_zcprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif case(mld_umf_) @@ -252,7 +252,7 @@ subroutine mld_zcprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif @@ -275,7 +275,7 @@ subroutine mld_zcprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif case(mld_jac_) @@ -366,7 +366,7 @@ subroutine mld_zcprecseti(p,what,val,info,ilev,ilmax,pos,idx) #elif defined(HAVE_MUMPS_) call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos) #else - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) #endif call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) case(mld_slu_) @@ -380,10 +380,10 @@ subroutine mld_zcprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif - case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_) + case(psb_ilu_n_, psb_ilu_t_,psb_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) @@ -394,7 +394,7 @@ subroutine mld_zcprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif case(mld_umf_) @@ -412,7 +412,7 @@ subroutine mld_zcprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif @@ -435,7 +435,7 @@ subroutine mld_zcprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #else call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) - call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) #endif case(mld_jac_) diff --git a/mlprec/impl/solver/Makefile b/mlprec/impl/solver/Makefile index f367d4e1..ad698c54 100644 --- a/mlprec/impl/solver/Makefile +++ b/mlprec/impl/solver/Makefile @@ -50,9 +50,6 @@ mld_c_ilu_solver_clear_data.o \ mld_c_ilu_solver_clone_settings.o \ mld_c_ilu_solver_cnv.o \ mld_c_ilu_solver_dmp.o \ -mld_cilu0_fact.o \ -mld_ciluk_fact.o \ -mld_cilut_fact.o \ mld_c_mumps_solver_apply.o \ mld_c_mumps_solver_apply_vect.o \ mld_c_mumps_solver_bld.o \ @@ -99,9 +96,6 @@ mld_d_ilu_solver_clear_data.o \ mld_d_ilu_solver_clone_settings.o \ mld_d_ilu_solver_cnv.o \ mld_d_ilu_solver_dmp.o \ -mld_dilu0_fact.o \ -mld_diluk_fact.o \ -mld_dilut_fact.o \ mld_d_mumps_solver_apply.o \ mld_d_mumps_solver_apply_vect.o \ mld_d_mumps_solver_bld.o \ @@ -148,9 +142,6 @@ mld_s_ilu_solver_clear_data.o \ mld_s_ilu_solver_clone_settings.o \ mld_s_ilu_solver_cnv.o \ mld_s_ilu_solver_dmp.o \ -mld_silu0_fact.o \ -mld_siluk_fact.o \ -mld_silut_fact.o \ mld_s_mumps_solver_apply.o \ mld_s_mumps_solver_apply_vect.o \ mld_s_mumps_solver_bld.o \ @@ -197,15 +188,11 @@ mld_z_ilu_solver_bld.o \ mld_z_ilu_solver_clone.o \ mld_z_ilu_solver_cnv.o \ mld_z_ilu_solver_dmp.o \ -mld_zilu0_fact.o \ -mld_ziluk_fact.o \ -mld_zilut_fact.o \ mld_z_mumps_solver_apply.o \ mld_z_mumps_solver_apply_vect.o \ mld_z_mumps_solver_bld.o \ - LIBNAME=libmld_prec.a lib: $(OBJS) diff --git a/mlprec/impl/solver/mld_c_ilu_solver_bld.f90 b/mlprec/impl/solver/mld_c_ilu_solver_bld.f90 index 7a4c7936..4974fcee 100644 --- a/mlprec/impl/solver/mld_c_ilu_solver_bld.f90 +++ b/mlprec/impl/solver/mld_c_ilu_solver_bld.f90 @@ -99,7 +99,7 @@ subroutine mld_c_ilu_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) select case(sv%fact_type) - case (mld_ilu_t_) + case (psb_ilu_t_) ! ! ILU(k,t) ! @@ -113,17 +113,17 @@ subroutine mld_c_ilu_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) case(0:) ! Fill-in >= 0 - call mld_ilut_fact(sv%fill_in,sv%thresh,& + call psb_ilut_fact(sv%fill_in,sv%thresh,& & a, sv%l,sv%u,sv%d,info,blck=b) end select if(info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='mld_ilut_fact' + ch_err='psb_ilut_fact' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - case(mld_ilu_n_,mld_milu_n_) + case(psb_ilu_n_,psb_milu_n_) ! ! ILU(k) and MILU(k) ! @@ -137,24 +137,24 @@ subroutine mld_c_ilu_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) ! Fill-in 0 ! Separate implementation of ILU(0) for better performance. ! There seems to be a problem with the separate implementation of MILU(0), - ! contained into mld_ilu0_fact. This must be investigated. For the time being, + ! contained into psb_ilu0_fact. This must be investigated. For the time being, ! resort to the implementation of MILU(k) with k=0. - if (sv%fact_type == mld_ilu_n_) then - call mld_ilu0_fact(sv%fact_type,a,sv%l,sv%u,& + if (sv%fact_type == psb_ilu_n_) then + call psb_ilu0_fact(sv%fact_type,a,sv%l,sv%u,& & sv%d,info,blck=b) else - call mld_iluk_fact(sv%fill_in,sv%fact_type,& + call psb_iluk_fact(sv%fill_in,sv%fact_type,& & a,sv%l,sv%u,sv%d,info,blck=b) endif case(1:) ! Fill-in >= 1 ! The same routine implements both ILU(k) and MILU(k) - call mld_iluk_fact(sv%fill_in,sv%fact_type,& + call psb_iluk_fact(sv%fill_in,sv%fact_type,& & a,sv%l,sv%u,sv%d,info,blck=b) end select if (info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='mld_iluk_fact' + ch_err='psb_iluk_fact' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if diff --git a/mlprec/impl/solver/mld_cilu0_fact.f90 b/mlprec/impl/solver/mld_cilu0_fact.f90 deleted file mode 100644 index d013de7c..00000000 --- a/mlprec/impl/solver/mld_cilu0_fact.f90 +++ /dev/null @@ -1,666 +0,0 @@ -! -! -! MLD2P4 version 2.2 -! MultiLevel Domain Decomposition Parallel Preconditioners Package -! based on PSBLAS (Parallel Sparse BLAS version 3.5) -! -! (C) Copyright 2008-2018 -! -! Salvatore Filippone -! Pasqua D'Ambra -! Daniela di Serafino -! -! 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_cilu0_fact.f90 -! -! Subroutine: mld_cilu0_fact -! Version: complex -! Contains: mld_cilu0_factint, ilu_copyin -! -! This routine computes either the ILU(0) or the MILU(0) factorization of -! the diagonal blocks of a distributed matrix. These factorizations are used -! to build the 'base preconditioner' (block-Jacobi preconditioner/solver, -! Additive Schwarz preconditioner) corresponding to a given level of a -! multilevel preconditioner. -! -! Details on the above factorizations can be found in -! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, -! SIAM, 2003, Chapter 10. -! -! The local matrix is stored into a and blck, as specified in the description -! of the arguments below. The storage format for both the L and U factors is CSR. -! The diagonal of the U factor is stored separately (actually, the inverse of the -! diagonal entries is stored; this is then managed in the solve stage associated -! to the ILU(0)/MILU(0) factorization). -! -! The routine copies and factors "on the fly" from a and blck into l (L factor), -! u (U factor, except its diagonal) and d (diagonal of U). -! -! This implementation of ILU(0)/MILU(0) is faster than the implementation in -! mld_ziluk_fct (the latter routine performs the more general ILU(k)/MILU(k)). -! -! -! Arguments: -! ialg - integer, input. -! The type of incomplete factorization to be performed. -! The MILU(0) factorization is computed if ialg = 2 (= mld_milu_n_); -! the ILU(0) factorization otherwise. -! a - type(psb_cspmat_type), input. -! The sparse matrix structure containing the local matrix. -! Note that if the 'base' Additive Schwarz preconditioner -! has overlap greater than 0 and the matrix has not been reordered -! (see mld_as_bld), then a contains only the 'original' local part -! of the distributed matrix, i.e. the rows of the matrix held -! by the calling process according to the initial data distribution. -! l - type(psb_cspmat_type), input/output. -! The L factor in the incomplete factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! u - type(psb_cspmat_type), input/output. -! The U factor (except its diagonal) in the incomplete factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! d - complex(psb_spk_), dimension(:), input/output. -! The inverse of the diagonal entries of the U factor in the incomplete -! factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! info - integer, output. -! Error code. -! blck - type(psb_cspmat_type), input, optional, target. -! The sparse matrix structure containing the remote rows of the -! distributed matrix, that have been retrieved by mld_as_bld -! to build an Additive Schwarz base preconditioner with overlap -! greater than 0. If the overlap is 0 or the matrix has been reordered -! (see mld_fact_bld), then blck is empty. -! -subroutine mld_cilu0_fact(ialg,a,l,u,d,info,blck, upd) - - use psb_base_mod - use mld_c_ilu_fact_mod, mld_protect_name => mld_cilu0_fact - - implicit none - - ! Arguments - integer(psb_ipk_), intent(in) :: ialg - type(psb_cspmat_type),intent(in) :: a - type(psb_cspmat_type),intent(inout) :: l,u - complex(psb_spk_), intent(inout) :: d(:) - integer(psb_ipk_), intent(out) :: info - type(psb_cspmat_type),intent(in), optional, target :: blck - character, intent(in), optional :: upd - - ! Local variables - integer(psb_ipk_) :: l1, l2, m, err_act - type(psb_cspmat_type), pointer :: blck_ - type(psb_c_csr_sparse_mat) :: ll, uu - character :: upd_ - character(len=20) :: name, ch_err - - name='mld_cilu0_fact' - info = psb_success_ - call psb_erractionsave(err_act) - - ! - ! Point to / allocate memory for the incomplete factorization - ! - if (present(blck)) then - blck_ => blck - else - allocate(blck_,stat=info) - if (info == psb_success_) call blck_%csall(izero,izero,info,ione) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='csall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - if (present(upd)) then - upd_ = psb_toupper(upd) - else - upd_ = 'F' - end if - - m = a%get_nrows() + blck_%get_nrows() - if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& - & (m > size(d)) ) then - write(0,*) 'Wrong allocation status for L,D,U? ',& - & l%get_nrows(),size(d),u%get_nrows() - info = -1 - return - end if - - call l%mv_to(ll) - call u%mv_to(uu) - ! - ! Compute the ILU(0) or the MILU(0) factorization, depending on ialg - ! - call mld_cilu0_factint(ialg,a,blck_,& - & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,upd_,info) - if(info.ne.0) then - info=psb_err_from_subroutine_ - ch_err='mld_cilu0_factint' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - ! - ! Store information on the L and U sparse matrices - ! - call l%mv_from(ll) - call l%set_triangle() - call l%set_unit() - call l%set_lower() - call u%mv_from(uu) - call u%set_triangle() - call u%set_unit() - call u%set_upper() - - ! - ! Nullify pointer / deallocate memory - ! - if (present(blck)) then - blck_ => null() - else - call blck_%free() - if(info.ne.0) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - deallocate(blck_) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -contains - - ! - ! Subroutine: mld_cilu0_factint - ! Version: complex - ! Note: internal subroutine of mld_cilu0_fact. - ! - ! This routine computes either the ILU(0) or the MILU(0) factorization of the - ! diagonal blocks of a distributed matrix. - ! These factorizations are used to build the 'base preconditioner' - ! (block-Jacobi preconditioner/solver, Additive Schwarz - ! preconditioner) corresponding to a given level of a multilevel preconditioner. - ! - ! The local matrix is stored into a and b, as specified in the - ! description of the arguments below. The storage format for both the L and U - ! factors is CSR. The diagonal of the U factor is stored separately (actually, - ! the inverse of the diagonal entries is stored; this is then managed in the - ! solve stage associated to the ILU(0)/MILU(0) factorization). - ! - ! The routine copies and factors "on the fly" from the sparse matrix structures a - ! and b into the arrays lval, uval, d (L, U without its diagonal, diagonal of U). - ! - ! - ! Arguments: - ! ialg - integer, input. - ! The type of incomplete factorization to be performed. - ! The ILU(0) factorization is computed if ialg = 1 (= mld_ilu_n_), - ! the MILU(0) one if ialg = 2 (= mld_milu_n_); other values - ! are not allowed. - ! m - integer, output. - ! The total number of rows of the local matrix to be factorized, - ! i.e. ma+mb. - ! ma - integer, input - ! The number of rows of the local submatrix stored into a. - ! a - type(psb_cspmat_type), input. - ! The sparse matrix structure containing the local matrix. - ! Note that, if the 'base' Additive Schwarz preconditioner - ! has overlap greater than 0 and the matrix has not been reordered - ! (see mld_fact_bld), then a contains only the 'original' local part - ! of the distributed matrix, i.e. the rows of the matrix held - ! by the calling process according to the initial data distribution. - ! mb - integer, input. - ! The number of rows of the local submatrix stored into b. - ! b - type(psb_cspmat_type), input. - ! The sparse matrix structure containing the remote rows of the - ! distributed matrix, that have been retrieved by mld_as_bld - ! to build an Additive Schwarz base preconditioner with overlap - ! greater than 0. If the overlap is 0 or the matrix has been - ! reordered (see mld_fact_bld), then b does not contain any row. - ! d - complex(psb_spk_), dimension(:), output. - ! The inverse of the diagonal entries of the U factor in the - ! incomplete factorization. - ! lval - complex(psb_spk_), dimension(:), input/output. - ! The entries of U are stored according to the CSR format. - ! The L factor in the incomplete factorization. - ! lja - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the L factor, - ! according to the CSR storage format. - ! lirp - integer, dimension(:), input/output. - ! The indices identifying the first nonzero entry of each row - ! of the L factor in lval, according to the CSR storage format. - ! uval - complex(psb_spk_), dimension(:), input/output. - ! The U factor in the incomplete factorization. - ! The entries of U are stored according to the CSR format. - ! uja - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the U factor, - ! according to the CSR storage format. - ! uirp - integer, dimension(:), input/output. - ! The indices identifying the first nonzero entry of each row - ! of the U factor in uval, according to the CSR storage format. - ! l1 - integer, output. - ! The number of nonzero entries in lval. - ! l2 - integer, output. - ! The number of nonzero entries in uval. - ! info - integer, output. - ! Error code. - ! - subroutine mld_cilu0_factint(ialg,a,b,& - & d,lval,lja,lirp,uval,uja,uirp,l1,l2,upd,info) - - implicit none - - ! Arguments - integer(psb_ipk_), intent(in) :: ialg - type(psb_cspmat_type),intent(in) :: a,b - integer(psb_ipk_),intent(inout) :: l1,l2,info - integer(psb_ipk_), intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) - complex(psb_spk_), intent(inout) :: lval(:),uval(:),d(:) - character, intent(in) :: upd - - ! Local variables - integer(psb_ipk_) :: i,j,k,l,low1,low2,kk,jj,ll, ktrw,err_act, m - integer(psb_ipk_) :: ma,mb - complex(psb_spk_) :: dia,temp - integer(psb_ipk_), parameter :: nrb=16 - type(psb_c_coo_sparse_mat) :: trw - integer(psb_ipk_) :: int_err(5) - character(len=20) :: name, ch_err - - name='mld_cilu0_factint' - info=psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - ma = a%get_nrows() - mb = b%get_nrows() - - select case(ialg) - case(mld_ilu_n_,mld_milu_n_) - ! Ok - case default - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,& - & i_err=(/ione,ialg,izero,izero,izero/)) - goto 9999 - end select - - call trw%allocate(izero,izero,ione) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_all' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - m = ma+mb - - if (psb_toupper(upd) == 'F' ) then - lirp(1) = 1 - uirp(1) = 1 - l1 = 0 - l2 = 0 - - ! - ! Cycle over the matrix rows - ! - do i = 1, m - - d(i) = czero - - if (i <= ma) then - ! - ! Copy the i-th local row of the matrix, stored in a, - ! into lval/d(i)/uval - ! - call ilu_copyin(i,ma,a,i,ione,m,l1,lja,lval,& - & d(i),l2,uja,uval,ktrw,trw,upd) - else - ! - ! Copy the i-th local row of the matrix, stored in b - ! (as (i-ma)-th row), into lval/d(i)/uval - ! - call ilu_copyin(i-ma,mb,b,i,ione,m,l1,lja,lval,& - & d(i),l2,uja,uval,ktrw,trw,upd) - endif - - lirp(i+1) = l1 + 1 - uirp(i+1) = l2 + 1 - - dia = d(i) - do kk = lirp(i), lirp(i+1) - 1 - ! - ! Compute entry l(i,k) (lower factor L) of the incomplete - ! factorization - ! - temp = lval(kk) - k = lja(kk) - lval(kk) = temp*d(k) - ! - ! Update the rest of row i (lower and upper factors L and U) - ! using l(i,k) - ! - low1 = kk + 1 - low2 = uirp(i) - ! - updateloop: do jj = uirp(k), uirp(k+1) - 1 - ! - j = uja(jj) - ! - if (j < i) then - ! - ! search l(i,*) (i-th row of L) for a matching index j - ! - do ll = low1, lirp(i+1) - 1 - l = lja(ll) - if (l > j) then - low1 = ll - exit - else if (l == j) then - lval(ll) = lval(ll) - temp*uval(jj) - low1 = ll + 1 - cycle updateloop - end if - enddo - - else if (j == i) then - ! - ! j=i: update the diagonal - ! - dia = dia - temp*uval(jj) - cycle updateloop - ! - else if (j > i) then - ! - ! search u(i,*) (i-th row of U) for a matching index j - ! - do ll = low2, uirp(i+1) - 1 - l = uja(ll) - if (l > j) then - low2 = ll - exit - else if (l == j) then - uval(ll) = uval(ll) - temp*uval(jj) - low2 = ll + 1 - cycle updateloop - end if - enddo - end if - ! - ! If we get here we missed the cycle updateloop, which means - ! that this entry does not match; thus we accumulate on the - ! diagonal for MILU(0). - ! - if (ialg == mld_milu_n_) then - dia = dia - temp*uval(jj) - end if - enddo updateloop - enddo - ! - ! Check the pivot size - ! - if (abs(dia) < s_epstol) then - ! - ! Too small pivot: unstable factorization - ! - info = psb_err_pivot_too_small_ - int_err(1) = i - write(ch_err,'(g20.10)') abs(dia) - call psb_errpush(info,name,i_err=int_err,a_err=ch_err) - goto 9999 - else - ! - ! Compute 1/pivot - ! - dia = cone/dia - end if - d(i) = dia - ! - ! Scale row i of upper triangle - ! - do kk = uirp(i), uirp(i+1) - 1 - uval(kk) = uval(kk)*dia - enddo - enddo - else - write(0,*) 'Update not implemented ' - info = 31 - call psb_errpush(info,name,& - & i_err=(/ione*13,izero,izero,izero,izero/),a_err=upd) - goto 9999 - - end if - - call trw%free() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine mld_cilu0_factint - - ! - ! Subroutine: ilu_copyin - ! Version: complex - ! Note: internal subroutine of mld_cilu0_fact - ! - ! This routine copies a row of a sparse matrix A, stored in the psb_cspmat_type - ! data structure a, into the arrays lval and uval and into the scalar variable - ! dia, corresponding to the lower and upper triangles of A and to the diagonal - ! entry of the row, respectively. The entries in lval and uval are stored - ! according to the CSR format; the corresponding column indices are stored in - ! the arrays lja and uja. - ! - ! If the sparse matrix is in CSR format, a 'straight' copy is performed; - ! otherwise psb_sp_getblk is used to extract a block of rows, which is then - ! copied into lval, dia, uval row by row, through successive calls to - ! ilu_copyin. - ! - ! The routine is used by mld_cilu0_factint in the computation of the ILU(0)/MILU(0) - ! factorization of a local sparse matrix. - ! - ! TODO: modify the routine to allow copying into output L and U that are - ! already filled with indices; this would allow computing an ILU(k) pattern, - ! then use the ILU(0) internal for subsequent calls with the same pattern. - ! - ! Arguments: - ! i - integer, input. - ! The local index of the row to be extracted from the - ! sparse matrix structure a. - ! m - integer, input. - ! The number of rows of the local matrix stored into a. - ! a - type(psb_cspmat_type), input. - ! The sparse matrix structure containing the row to be copied. - ! jd - integer, input. - ! The column index of the diagonal entry of the row to be - ! copied. - ! jmin - integer, input. - ! Minimum valid column index. - ! jmax - integer, input. - ! Maximum valid column index. - ! The output matrix will contain a clipped copy taken from - ! a(1:m,jmin:jmax). - ! l1 - integer, input/output. - ! Pointer to the last occupied entry of lval. - ! lja - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the lower triangle - ! copied in lval row by row (see mld_cilu0_factint), according - ! to the CSR storage format. - ! lval - complex(psb_spk_), dimension(:), input/output. - ! The array where the entries of the row corresponding to the - ! lower triangle are copied. - ! dia - complex(psb_spk_), output. - ! The diagonal entry of the copied row. - ! l2 - integer, input/output. - ! Pointer to the last occupied entry of uval. - ! uja - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the upper triangle - ! copied in uval row by row (see mld_cilu0_factint), according - ! to the CSR storage format. - ! uval - complex(psb_spk_), dimension(:), input/output. - ! The array where the entries of the row corresponding to the - ! upper triangle are copied. - ! ktrw - integer, input/output. - ! The index identifying the last entry taken from the - ! staging buffer trw. See below. - ! trw - type(psb_cspmat_type), input/output. - ! A staging buffer. If the matrix A is not in CSR format, we use - ! the psb_sp_getblk routine and store its output in trw; when we - ! need to call psb_sp_getblk we do it for a block of rows, and then - ! we consume them from trw in successive calls to this routine, - ! until we empty the buffer. Thus we will make a call to psb_sp_getblk - ! every nrb calls to copyin. If A is in CSR format it is unused. - ! - subroutine ilu_copyin(i,m,a,jd,jmin,jmax,l1,lja,lval,& - & dia,l2,uja,uval,ktrw,trw,upd) - - use psb_base_mod - - implicit none - - ! Arguments - type(psb_cspmat_type), intent(in) :: a - type(psb_c_coo_sparse_mat), intent(inout) :: trw - integer(psb_ipk_), intent(in) :: i,m,jd,jmin,jmax - integer(psb_ipk_), intent(inout) :: ktrw,l1,l2 - integer(psb_ipk_), intent(inout) :: lja(:), uja(:) - complex(psb_spk_), intent(inout) :: lval(:), uval(:), dia - character, intent(in) :: upd - ! Local variables - integer(psb_ipk_) :: k,j,info,irb, nz - integer(psb_ipk_), parameter :: nrb=40 - character(len=20), parameter :: name='ilu_copyin' - character(len=20) :: ch_err - - info=psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - if (psb_toupper(upd) == 'F') then - - select type(aa => a%a) - type is (psb_c_csr_sparse_mat) - - ! - ! Take a fast shortcut if the matrix is stored in CSR format - ! - - do j = aa%irp(i), aa%irp(i+1) - 1 - k = aa%ja(j) - ! write(0,*)'KKKKK',k - if ((k < jd).and.(k >= jmin)) then - l1 = l1 + 1 - lval(l1) = aa%val(j) - lja(l1) = k - else if (k == jd) then - dia = aa%val(j) - else if ((k > jd).and.(k <= jmax)) then - l2 = l2 + 1 - uval(l2) = aa%val(j) - uja(l2) = k - end if - enddo - - class default - - ! - ! Otherwise use psb_sp_getblk, slower but able (in principle) of - ! handling any format. In this case, a block of rows is extracted - ! instead of a single row, for performance reasons, and these - ! rows are copied one by one into lval, dia, uval, through - ! successive calls to ilu_copyin. - ! - - if ((mod(i,nrb) == 1).or.(nrb == 1)) then - irb = min(m-i+1,nrb) - call aa%csget(i,i+irb-1,trw,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='csget' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - ktrw=1 - end if - - nz = trw%get_nzeros() - do - if (ktrw > nz) exit - if (trw%ia(ktrw) > i) exit - k = trw%ja(ktrw) - if ((k < jd).and.(k >= jmin)) then - l1 = l1 + 1 - lval(l1) = trw%val(ktrw) - lja(l1) = k - else if (k == jd) then - dia = trw%val(ktrw) - else if ((k > jd).and.(k <= jmax)) then - l2 = l2 + 1 - uval(l2) = trw%val(ktrw) - uja(l2) = k - end if - ktrw = ktrw + 1 - enddo - - end select - - else - - write(0,*) 'Update not implemented ' - info = 31 - call psb_errpush(info,name,& - & i_err=(/ione*13,izero,izero,izero,izero/),a_err=upd) - goto 9999 - - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine ilu_copyin - -end subroutine mld_cilu0_fact diff --git a/mlprec/impl/solver/mld_ciluk_fact.f90 b/mlprec/impl/solver/mld_ciluk_fact.f90 deleted file mode 100644 index 43f54fe3..00000000 --- a/mlprec/impl/solver/mld_ciluk_fact.f90 +++ /dev/null @@ -1,969 +0,0 @@ -! -! -! MLD2P4 version 2.2 -! MultiLevel Domain Decomposition Parallel Preconditioners Package -! based on PSBLAS (Parallel Sparse BLAS version 3.5) -! -! (C) Copyright 2008-2018 -! -! Salvatore Filippone -! Pasqua D'Ambra -! Daniela di Serafino -! -! 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_ciluk_fact.f90 -! -! Subroutine: mld_ciluk_fact -! Version: complex -! Contains: mld_ciluk_factint, iluk_copyin, iluk_fact, iluk_copyout. -! -! This routine computes either the ILU(k) or the MILU(k) factorization of the -! diagonal blocks of a distributed matrix. These factorizations are used to -! build the 'base preconditioner' (block-Jacobi preconditioner/solver, -! Additive Schwarz preconditioner) corresponding to a certain level of a -! multilevel preconditioner. -! -! Details on the above factorizations can be found in -! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, -! SIAM, 2003, Chapter 10. -! -! The local matrix is stored into a and blck, as specified in -! the description of the arguments below. The storage format for both the L and -! U factors is CSR. The diagonal of the U factor is stored separately (actually, -! the inverse of the diagonal entries is stored; this is then managed in the solve -! stage associated to the ILU(k)/MILU(k) factorization). -! -! -! Arguments: -! fill_in - integer, input. -! The fill-in level k in ILU(k)/MILU(k). -! ialg - integer, input. -! The type of incomplete factorization to be performed. -! The ILU(k) factorization is computed if ialg = 1 (= mld_ilu_n_); -! the MILU(k) one if ialg = 2 (= mld_milu_n_); other values are -! not allowed. -! a - type(psb_cspmat_type), input. -! The sparse matrix structure containing the local matrix. -! Note that if the 'base' Additive Schwarz preconditioner -! has overlap greater than 0 and the matrix has not been reordered -! (see mld_fact_bld), then a contains only the 'original' local part -! of the distributed matrix, i.e. the rows of the matrix held -! by the calling process according to the initial data distribution. -! l - type(psb_cspmat_type), input/output. -! The L factor in the incomplete factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! u - type(psb_cspmat_type), input/output. -! The U factor (except its diagonal) in the incomplete factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! d - complex(psb_spk_), dimension(:), input/output. -! The inverse of the diagonal entries of the U factor in the incomplete -! factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! info - integer, output. -! Error code. -! blck - type(psb_cspmat_type), input, optional, target. -! The sparse matrix structure containing the remote rows of the -! distributed matrix, that have been retrieved by mld_as_bld -! to build an Additive Schwarz base preconditioner with overlap -! greater than 0. If the overlap is 0 or the matrix has been reordered -! (see mld_fact_bld), then blck does not contain any row. -! -subroutine mld_ciluk_fact(fill_in,ialg,a,l,u,d,info,blck) - - use psb_base_mod - use mld_c_ilu_fact_mod, mld_protect_name => mld_ciluk_fact - - implicit none - - ! Arguments - integer(psb_ipk_), intent(in) :: fill_in, ialg - integer(psb_ipk_), intent(out) :: info - type(psb_cspmat_type),intent(in) :: a - type(psb_cspmat_type),intent(inout) :: l,u - type(psb_cspmat_type),intent(in), optional, target :: blck - complex(psb_spk_), intent(inout) :: d(:) - ! Local Variables - integer(psb_ipk_) :: l1, l2, m, err_act - - type(psb_cspmat_type), pointer :: blck_ - type(psb_c_csr_sparse_mat) :: ll, uu - character(len=20) :: name, ch_err - - name='mld_ciluk_fact' - info = psb_success_ - call psb_erractionsave(err_act) - - ! - ! Point to / allocate memory for the incomplete factorization - ! - if (present(blck)) then - blck_ => blck - else - allocate(blck_,stat=info) - if (info == psb_success_) call blck_%csall(izero,izero,info,ione) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='csall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - - m = a%get_nrows() + blck_%get_nrows() - if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& - & (m > size(d)) ) then - write(0,*) 'Wrong allocation status for L,D,U? ',& - & l%get_nrows(),size(d),u%get_nrows() - info = -1 - return - end if - - call l%mv_to(ll) - call u%mv_to(uu) - - ! - ! Compute the ILU(k) or the MILU(k) factorization, depending on ialg - ! - call mld_ciluk_factint(fill_in,ialg,a,blck_,& - & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_ciluk_factint' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - ! - ! Store information on the L and U sparse matrices - ! - call l%mv_from(ll) - call l%set_triangle() - call l%set_unit() - call l%set_lower() - call u%mv_from(uu) - call u%set_triangle() - call u%set_unit() - call u%set_upper() - - ! - ! Nullify pointer / deallocate memory - ! - if (present(blck)) then - blck_ => null() - else - call blck_%free() - deallocate(blck_,stat=info) - if(info.ne.0) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -contains - - ! - ! Subroutine: mld_ciluk_factint - ! Version: complex - ! Note: internal subroutine of mld_ciluk_fact - ! - ! This routine computes either the ILU(k) or the MILU(k) factorization of the - ! diagonal blocks of a distributed matrix. These factorizations are used to build - ! the 'base preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz - ! preconditioner) corresponding to a certain level of a multilevel preconditioner. - ! - ! The local matrix is stored into a and b, as specified in the - ! description of the arguments below. The storage format for both the L and U - ! factors is CSR. The diagonal of the U factor is stored separately (actually, - ! the inverse of the diagonal entries is stored; this is then managed in the - ! solve stage associated to the ILU(k)/MILU(k) factorization). - ! - ! - ! Arguments: - ! fill_in - integer, input. - ! The fill-in level k in ILU(k)/MILU(k). - ! ialg - integer, input. - ! The type of incomplete factorization to be performed. - ! The MILU(k) factorization is computed if ialg = 2 (= mld_milu_n_); - ! the ILU(k) factorization otherwise. - ! m - integer, output. - ! The total number of rows of the local matrix to be factorized, - ! i.e. ma+mb. - ! a - type(psb_cspmat_type), input. - ! The sparse matrix structure containing the local matrix. - ! Note that, if the 'base' Additive Schwarz preconditioner - ! has overlap greater than 0 and the matrix has not been reordered - ! (see mld_fact_bld), then a contains only the 'original' local part - ! of the distributed matrix, i.e. the rows of the matrix held - ! by the calling process according to the initial data distribution. - ! b - type(psb_cspmat_type), input. - ! The sparse matrix structure containing the remote rows of the - ! distributed matrix, that have been retrieved by mld_as_bld - ! to build an Additive Schwarz base preconditioner with overlap - ! greater than 0. If the overlap is 0 or the matrix has been reordered - ! (see mld_fact_bld), then b does not contain any row. - ! d - complex(psb_spk_), dimension(:), output. - ! The inverse of the diagonal entries of the U factor in the incomplete - ! factorization. - ! laspk - complex(psb_spk_), dimension(:), input/output. - ! The L factor in the incomplete factorization. - ! lia1 - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the L factor, - ! according to the CSR storage format. - ! lia2 - integer, dimension(:), input/output. - ! The indices identifying the first nonzero entry of each row - ! of the L factor in laspk, according to the CSR storage format. - ! uval - complex(psb_spk_), dimension(:), input/output. - ! The U factor in the incomplete factorization. - ! The entries of U are stored according to the CSR format. - ! uja - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the U factor, - ! according to the CSR storage format. - ! uirp - integer, dimension(:), input/output. - ! The indices identifying the first nonzero entry of each row - ! of the U factor in uval, according to the CSR storage format. - ! l1 - integer, output - ! The number of nonzero entries in laspk. - ! l2 - integer, output - ! The number of nonzero entries in uval. - ! info - integer, output. - ! Error code. - ! - subroutine mld_ciluk_factint(fill_in,ialg,a,b,& - & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info) - - use psb_base_mod - - implicit none - - ! Arguments - integer(psb_ipk_), intent(in) :: fill_in, ialg - type(psb_cspmat_type),intent(in) :: a,b - integer(psb_ipk_),intent(inout) :: l1,l2,info - integer(psb_ipk_), allocatable, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) - complex(psb_spk_), allocatable, intent(inout) :: lval(:),uval(:) - complex(psb_spk_), intent(inout) :: d(:) - - ! Local variables - integer(psb_ipk_) :: ma,mb,i, ktrw,err_act,nidx, m - integer(psb_ipk_), allocatable :: uplevs(:), rowlevs(:),idxs(:) - complex(psb_spk_), allocatable :: row(:) - type(psb_i_heap) :: heap - type(psb_c_coo_sparse_mat) :: trw - character(len=20), parameter :: name='mld_ciluk_factint' - character(len=20) :: ch_err - - info=psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - - - select case(ialg) - case(mld_ilu_n_,mld_milu_n_) - ! Ok - case default - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,& - & i_err=(/itwo,ialg,izero,izero,izero/)) - goto 9999 - end select - if (fill_in < 0) then - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name, & - & i_err=(/ione,fill_in,izero,izero,izero/)) - goto 9999 - end if - - ma = a%get_nrows() - mb = b%get_nrows() - m = ma+mb - - ! - ! Allocate a temporary buffer for the iluk_copyin function - ! - - call trw%allocate(izero,izero,ione) - if (info == psb_success_) call psb_ensure_size(m+1,lirp,info) - if (info == psb_success_) call psb_ensure_size(m+1,uirp,info) - - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_sp_all') - goto 9999 - end if - - l1=0 - l2=0 - lirp(1) = 1 - uirp(1) = 1 - - ! - ! Allocate memory to hold the entries of a row and the corresponding - ! fill levels - ! - allocate(uplevs(size(uval)),rowlevs(m),row(m),stat=info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - - uplevs(:) = m+1 - row(:) = czero - rowlevs(:) = -(m+1) - - ! - ! Cycle over the matrix rows - ! - do i = 1, m - - ! - ! At each iteration of the loop we keep in a heap the column indices - ! affected by the factorization. The heap is initialized and filled - ! in the iluk_copyin routine, and updated during the elimination, in - ! the iluk_fact routine. The heap is ideal because at each step we need - ! the lowest index, but we also need to insert new items, and the heap - ! allows to do both in log time. - ! - d(i) = czero - if (i<=ma) then - ! - ! Copy into trw the i-th local row of the matrix, stored in a - ! - call iluk_copyin(i,ma,a,ione,m,row,rowlevs,heap,ktrw,trw,info) - else - ! - ! Copy into trw the i-th local row of the matrix, stored in b - ! (as (i-ma)-th row) - ! - call iluk_copyin(i-ma,mb,b,ione,m,row,rowlevs,heap,ktrw,trw,info) - endif - - ! Do an elimination step on the current row. It turns out we only - ! need to keep track of fill levels for the upper triangle, hence we - ! do not have a lowlevs variable. - ! - if (info == psb_success_) call iluk_fact(fill_in,i,row,rowlevs,heap,& - & d,uja,uirp,uval,uplevs,nidx,idxs,info) - ! - ! Copy the row into lval/d(i)/uval - ! - if (info == psb_success_) call iluk_copyout(fill_in,ialg,i,m,row,rowlevs,nidx,idxs,& - & l1,l2,lja,lirp,lval,d,uja,uirp,uval,uplevs,info) - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='Copy/factor loop') - goto 9999 - end if - end do - - ! - ! And we're done, so deallocate the memory - ! - deallocate(uplevs,rowlevs,row,stat=info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Deallocate') - goto 9999 - end if - if (info == psb_success_) call trw%free() - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine mld_ciluk_factint - - ! - ! Subroutine: iluk_copyin - ! Version: complex - ! Note: internal subroutine of mld_ciluk_fact - ! - ! This routine copies a row of a sparse matrix A, stored in the sparse matrix - ! structure a, into the array row and stores into a heap the column indices of - ! the nonzero entries of the copied row. The output array row is such that it - ! contains a full row of A, i.e. it contains also the zero entries of the row. - ! This is useful for the elimination step performed by iluk_fact after the call - ! to iluk_copyin (see mld_iluk_factint). - ! The routine also sets to zero the entries of the array rowlevs corresponding - ! to the nonzero entries of the copied row (see the description of the arguments - ! below). - ! - ! If the sparse matrix is in CSR format, a 'straight' copy is performed; - ! otherwise psb_sp_getblk is used to extract a block of rows, which is then - ! copied, row by row, into the array row, through successive calls to - ! ilu_copyin. - ! - ! This routine is used by mld_ciluk_factint in the computation of the - ! ILU(k)/MILU(k) factorization of a local sparse matrix. - ! - ! - ! Arguments: - ! i - integer, input. - ! The local index of the row to be extracted from the - ! sparse matrix structure a. - ! m - integer, input. - ! The number of rows of the local matrix stored into a. - ! a - type(psb_cspmat_type), input. - ! The sparse matrix structure containing the row to be copied. - ! jmin - integer, input. - ! The minimum valid column index. - ! jmax - integer, input. - ! The maximum valid column index. - ! The output matrix will contain a clipped copy taken from - ! a(1:m,jmin:jmax). - ! row - complex(psb_spk_), dimension(:), input/output. - ! In input it is the null vector (see mld_iluk_factint and - ! iluk_copyout). In output it contains the row extracted - ! from the matrix A. It actually contains a full row, i.e. - ! it contains also the zero entries of the row. - ! rowlevs - integer, dimension(:), input/output. - ! In input rowlevs(k) = -(m+1) for k=1,...,m. In output - ! rowlevs(k) = 0 for 1 <= k <= jmax and A(i,k) /= 0, for - ! future use in iluk_fact. - ! heap - type(psb_i_heap), input/output. - ! The heap containing the column indices of the nonzero - ! entries in the array row. - ! Note: this argument is intent(inout) and not only intent(out) - ! to retain its allocation, done by psb_init_heap inside this - ! routine. - ! ktrw - integer, input/output. - ! The index identifying the last entry taken from the - ! staging buffer trw. See below. - ! trw - type(psb_cspmat_type), input/output. - ! A staging buffer. If the matrix A is not in CSR format, we use - ! the psb_sp_getblk routine and store its output in trw; when we - ! need to call psb_sp_getblk we do it for a block of rows, and then - ! we consume them from trw in successive calls to this routine, - ! until we empty the buffer. Thus we will make a call to psb_sp_getblk - ! every nrb calls to copyin. If A is in CSR format it is unused. - ! - subroutine iluk_copyin(i,m,a,jmin,jmax,row,rowlevs,heap,ktrw,trw,info) - - use psb_base_mod - - implicit none - - ! Arguments - type(psb_cspmat_type), intent(in) :: a - type(psb_c_coo_sparse_mat), intent(inout) :: trw - integer(psb_ipk_), intent(in) :: i,m,jmin,jmax - integer(psb_ipk_), intent(inout) :: ktrw,info - integer(psb_ipk_), intent(inout) :: rowlevs(:) - complex(psb_spk_), intent(inout) :: row(:) - type(psb_i_heap), intent(inout) :: heap - - ! Local variables - integer(psb_ipk_) :: k,j,irb,err_act,nz - integer(psb_ipk_), parameter :: nrb=40 - character(len=20), parameter :: name='iluk_copyin' - character(len=20) :: ch_err - - info=psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - call heap%init(info) - - select type (aa=> a%a) - type is (psb_c_csr_sparse_mat) - ! - ! Take a fast shortcut if the matrix is stored in CSR format - ! - - do j = aa%irp(i), aa%irp(i+1) - 1 - k = aa%ja(j) - if ((jmin<=k).and.(k<=jmax)) then - row(k) = aa%val(j) - rowlevs(k) = 0 - call heap%insert(k,info) - end if - end do - - class default - - ! - ! Otherwise use psb_sp_getblk, slower but able (in principle) of - ! handling any format. In this case, a block of rows is extracted - ! instead of a single row, for performance reasons, and these - ! rows are copied one by one into the array row, through successive - ! calls to iluk_copyin. - ! - - if ((mod(i,nrb) == 1).or.(nrb == 1)) then - irb = min(m-i+1,nrb) - call aa%csget(i,i+irb-1,trw,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_getblk' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - ktrw=1 - end if - nz = trw%get_nzeros() - do - if (ktrw > nz) exit - if (trw%ia(ktrw) > i) exit - k = trw%ja(ktrw) - if ((jmin<=k).and.(k<=jmax)) then - row(k) = trw%val(ktrw) - rowlevs(k) = 0 - call heap%insert(k,info) - end if - ktrw = ktrw + 1 - enddo - end select - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine iluk_copyin - - ! - ! Subroutine: iluk_fact - ! Version: complex - ! Note: internal subroutine of mld_ciluk_fact - ! - ! This routine does an elimination step of the ILU(k) factorization on a - ! single matrix row (see the calling routine mld_iluk_factint). - ! - ! This step is also the base for a MILU(k) elimination step on the row (see - ! iluk_copyout). This routine is used by mld_ciluk_factint in the computation - ! of the ILU(k)/MILU(k) factorization of a local sparse matrix. - ! - ! NOTE: it turns out we only need to keep track of the fill levels for - ! the upper triangle. - ! - ! - ! Arguments - ! fill_in - integer, input. - ! The fill-in level k in ILU(k). - ! i - integer, input. - ! The local index of the row to which the factorization is - ! applied. - ! row - complex(psb_spk_), dimension(:), input/output. - ! In input it contains the row to which the elimination step - ! has to be applied. In output it contains the row after the - ! elimination step. It actually contains a full row, i.e. - ! it contains also the zero entries of the row. - ! rowlevs - integer, dimension(:), input/output. - ! In input rowlevs(k) = 0 if the k-th entry of the row is - ! nonzero, and rowlevs(k) = -(m+1) otherwise. In output - ! rowlevs(k) contains the fill kevel of the k-th entry of - ! the row after the current elimination step; rowlevs(k) = -(m+1) - ! means that the k-th row entry is zero throughout the elimination - ! step. - ! heap - type(psb_i_heap), input/output. - ! The heap containing the column indices of the nonzero entries - ! in the processed row. In input it contains the indices concerning - ! the row before the elimination step, while in output it contains - ! the indices concerning the transformed row. - ! d - complex(psb_spk_), input. - ! The inverse of the diagonal entries of the part of the U factor - ! above the current row (see iluk_copyout). - ! uja - integer, dimension(:), input. - ! The column indices of the nonzero entries of the part of the U - ! factor above the current row, stored in uval row by row (see - ! iluk_copyout, called by mld_ciluk_factint), according to the CSR - ! storage format. - ! uirp - integer, dimension(:), input. - ! The indices identifying the first nonzero entry of each row of - ! the U factor above the current row, stored in uval row by row - ! (see iluk_copyout, called by mld_ciluk_factint), according to - ! the CSR storage format. - ! uval - complex(psb_spk_), dimension(:), input. - ! The entries of the U factor above the current row (except the - ! diagonal ones), stored according to the CSR format. - ! uplevs - integer, dimension(:), input. - ! The fill levels of the nonzero entries in the part of the - ! U factor above the current row. - ! nidx - integer, output. - ! The number of entries of the array row that have been - ! examined during the elimination step. This will be used - ! by the routine iluk_copyout. - ! idxs - integer, dimension(:), allocatable, input/output. - ! The indices of the entries of the array row that have been - ! examined during the elimination step.This will be used by - ! by the routine iluk_copyout. - ! Note: this argument is intent(inout) and not only intent(out) - ! to retain its allocation, done by this routine. - ! - subroutine iluk_fact(fill_in,i,row,rowlevs,heap,d,uja,uirp,uval,uplevs,nidx,idxs,info) - - use psb_base_mod - - implicit none - - ! Arguments - type(psb_i_heap), intent(inout) :: heap - integer(psb_ipk_), intent(in) :: i, fill_in - integer(psb_ipk_), intent(inout) :: nidx,info - integer(psb_ipk_), intent(inout) :: rowlevs(:) - integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) - integer(psb_ipk_), intent(inout) :: uja(:),uirp(:),uplevs(:) - complex(psb_spk_), intent(inout) :: row(:), uval(:),d(:) - - ! Local variables - integer(psb_ipk_) :: k,j,lrwk,jj,lastk, iret - complex(psb_spk_) :: rwk - - info = psb_success_ - if (.not.allocated(idxs)) then - allocate(idxs(200),stat=info) - if (info /= psb_success_) return - endif - nidx = 0 - lastk = -1 - - ! - ! Do while there are indices to be processed - ! - do - ! Beware: (iret < 0) means that the heap is empty, not an error. - call heap%get_first(k,iret) - if (iret < 0) return - - ! - ! Just in case an index has been put on the heap more than once. - ! - if (k == lastk) cycle - - lastk = k - nidx = nidx + 1 - if (nidx>size(idxs)) then - call psb_realloc(nidx+psb_heap_resize,idxs,info) - if (info /= psb_success_) return - end if - idxs(nidx) = k - - if ((row(k) /= czero).and.(rowlevs(k) <= fill_in).and.(ki) then - ! - ! Copy the upper part of the row - ! - if (rowlevs(j) <= fill_in) then - l2 = l2 + 1 - if (size(uval) < l2) then - ! - ! Figure out a good reallocation size! - ! - isz = max((l2/i)*m,int(1.2*l2),l2+100) - call psb_realloc(isz,uval,info) - if (info == psb_success_) call psb_realloc(isz,uja,info) - if (info == psb_success_) call psb_realloc(isz,uplevs,info,pad=(m+1)) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - end if - uja(l2) = j - uval(l2) = row(j) - uplevs(l2) = rowlevs(j) - else if (ialg == mld_milu_n_) then - ! - ! MILU(k): add discarded entries to the diagonal one - ! - d(i) = d(i) + row(j) - end if - ! - ! Re-initialize row(j) and rowlevs(j) - ! - row(j) = czero - rowlevs(j) = -(m+1) - end if - end do - - ! - ! Store the pointers to the first non occupied entry of in - ! lval and uval - ! - lirp(i+1) = l1 + 1 - uirp(i+1) = l2 + 1 - - ! - ! Check the pivot size - ! - if (abs(d(i)) < s_epstol) then - ! - ! Too small pivot: unstable factorization - ! - info = psb_err_pivot_too_small_ - int_err(1) = i - write(ch_err,'(g20.10)') d(i) - call psb_errpush(info,name,i_err=int_err,a_err=ch_err) - goto 9999 - else - ! - ! Compute 1/pivot - ! - d(i) = cone/d(i) - end if - - ! - ! Scale the upper part - ! - do j=uirp(i), uirp(i+1)-1 - uval(j) = d(i)*uval(j) - end do - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine iluk_copyout - - -end subroutine mld_ciluk_fact diff --git a/mlprec/impl/solver/mld_cilut_fact.f90 b/mlprec/impl/solver/mld_cilut_fact.f90 deleted file mode 100644 index 510ac38a..00000000 --- a/mlprec/impl/solver/mld_cilut_fact.f90 +++ /dev/null @@ -1,1186 +0,0 @@ -! -! -! MLD2P4 version 2.2 -! MultiLevel Domain Decomposition Parallel Preconditioners Package -! based on PSBLAS (Parallel Sparse BLAS version 3.5) -! -! (C) Copyright 2008-2018 -! -! Salvatore Filippone -! Pasqua D'Ambra -! Daniela di Serafino -! -! 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_cilut_fact.f90 -! -! Subroutine: mld_cilut_fact -! Version: complex -! Contains: mld_cilut_factint, ilut_copyin, ilut_fact, ilut_copyout -! -! This routine computes the ILU(k,t) factorization of the diagonal blocks -! of a distributed matrix. This factorization is used to build the 'base -! preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz -! preconditioner) corresponding to a certain level of a multilevel preconditioner. -! -! Details on the above factorization can be found in -! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, -! SIAM, 2003, Chapter 10. -! -! The local matrix is stored into a and blck, as specified in the description -! of the arguments below. The storage format for both the L and U factors is -! CSR. The diagonal of the U factor is stored separately (actually, the -! inverse of the diagonal entries is stored; this is then managed in the -! solve stage associated to the ILU(k,t) factorization). -! -! -! Arguments: -! fill_in - integer, input. -! The fill-in parameter k in ILU(k,t). -! thres - real, input. -! The threshold t, i.e. the drop tolerance, in ILU(k,t). -! a - type(psb_cspmat_type), input. -! The sparse matrix structure containing the local matrix. -! Note that if the 'base' Additive Schwarz preconditioner -! has overlap greater than 0 and the matrix has not been reordered -! (see mld_fact_bld), then a contains only the 'original' local part -! of the distributed matrix, i.e. the rows of the matrix held -! by the calling process according to the initial data distribution. -! l - type(psb_cspmat_type), input/output. -! The L factor in the incomplete factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! u - type(psb_cspmat_type), input/output. -! The U factor (except its diagonal) in the incomplete factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! d - complex(psb_spk_), dimension(:), input/output. -! The inverse of the diagonal entries of the U factor in the incomplete -! factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! info - integer, output. -! Error code. -! blck - type(psb_cspmat_type), input, optional, target. -! The sparse matrix structure containing the remote rows of the -! distributed matrix, that have been retrieved by mld_as_bld -! to build an Additive Schwarz base preconditioner with overlap -! greater than 0. If the overlap is 0 or the matrix has been reordered -! (see mld_fact_bld), then blck does not contain any row. -! -subroutine mld_cilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) - - use psb_base_mod - use mld_c_ilu_fact_mod, mld_protect_name => mld_cilut_fact - - implicit none - - ! Arguments - integer(psb_ipk_), intent(in) :: fill_in - real(psb_spk_), intent(in) :: thres - integer(psb_ipk_), intent(out) :: info - type(psb_cspmat_type),intent(in) :: a - type(psb_cspmat_type),intent(inout) :: l,u - complex(psb_spk_), intent(inout) :: d(:) - type(psb_cspmat_type),intent(in), optional, target :: blck - integer(psb_ipk_), intent(in), optional :: iscale - ! Local Variables - integer(psb_ipk_) :: l1, l2, m, err_act, iscale_ - - type(psb_cspmat_type), pointer :: blck_ - type(psb_c_csr_sparse_mat) :: ll, uu - real(psb_spk_) :: scale - character(len=20) :: name, ch_err - - name='mld_cilut_fact' - info = psb_success_ - call psb_erractionsave(err_act) - - if (fill_in < 0) then - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name, & - & i_err=(/ione,fill_in,izero,izero,izero/)) - goto 9999 - end if - ! - ! Point to / allocate memory for the incomplete factorization - ! - if (present(blck)) then - blck_ => blck - else - allocate(blck_,stat=info) - if (info == psb_success_) call blck_%csall(izero,izero,info,ione) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='csall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - if (present(iscale)) then - iscale_ = iscale - else - iscale_ = mld_ilu_scale_none_ - end if - - select case(iscale_) - case(mld_ilu_scale_none_) - scale = sone - case(mld_ilu_scale_maxval_) - scale = max(a%maxval(),blck_%maxval()) - scale = sone/scale - case default - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,i_err=(/ione*9,iscale_,izero,izero,izero/)) - goto 9999 - end select - - m = a%get_nrows() + blck_%get_nrows() - if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& - & (m > size(d)) ) then - write(0,*) 'Wrong allocation status for L,D,U? ',& - & l%get_nrows(),size(d),u%get_nrows() - info = -1 - return - end if - - call l%mv_to(ll) - call u%mv_to(uu) - - ! - ! Compute the ILU(k,t) factorization - ! - call mld_cilut_factint(fill_in,thres,a,blck_,& - & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info,scale) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_cilut_factint' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - ! - ! Store information on the L and U sparse matrices - ! - call l%mv_from(ll) - call l%set_triangle() - call l%set_unit() - call l%set_lower() - call u%mv_from(uu) - call u%set_triangle() - call u%set_unit() - call u%set_upper() - - ! - ! Nullify pointer / deallocate memory - ! - if (present(blck)) then - blck_ => null() - else - call blck_%free() - deallocate(blck_,stat=info) - if(info.ne.0) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - -contains - - ! - ! Subroutine: mld_cilut_factint - ! Version: complex - ! Note: internal subroutine of mld_cilut_fact - ! - ! This routine computes the ILU(k,t) factorization of the diagonal blocks of a - ! distributed matrix. This factorization is used to build the 'base - ! preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz - ! preconditioner) corresponding to a certain level of a multilevel preconditioner. - ! - ! The local matrix to be factorized is stored into a and b, as specified in the - ! description of the arguments below. The storage format for both the L and U - ! factors is CSR. The diagonal of the U factor is stored separately (actually, - ! the inverse of the diagonal entries is stored; this is then managed in the - ! solve stage associated to the ILU(k,t) factorization). - ! - ! - ! Arguments: - ! fill_in - integer, input. - ! The fill-in parameter k in ILU(k,t). - ! thres - real, input. - ! The threshold t, i.e. the drop tolerance, in ILU(k,t). - ! m - integer, output. - ! The total number of rows of the local matrix to be factorized, - ! i.e. ma+mb. - ! a - type(psb_cspmat_type), input. - ! The sparse matrix structure containing the local matrix. - ! Note that, if the 'base' Additive Schwarz preconditioner - ! has overlap greater than 0 and the matrix has not been reordered - ! (see mld_fact_bld), then a contains only the 'original' local part - ! of the distributed matrix, i.e. the rows of the matrix held - ! by the calling process according to the initial data distribution. - ! b - type(psb_cspmat_type), input. - ! The sparse matrix structure containing the remote rows of the - ! distributed matrix, that have been retrieved by mld_as_bld - ! to build an Additive Schwarz base preconditioner with overlap - ! greater than 0. If the overlap is 0 or the matrix has been reordered - ! (see mld_fact_bld), then b does not contain any row. - ! d - complex(psb_spk_), dimension(:), output. - ! The inverse of the diagonal entries of the U factor in the incomplete - ! factorization. - ! lval - complex(psb_spk_), dimension(:), input/output. - ! The L factor in the incomplete factorization. - ! lia1 - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the L factor, - ! according to the CSR storage format. - ! lirp - integer, dimension(:), input/output. - ! The indices identifying the first nonzero entry of each row - ! of the L factor in lval, according to the CSR storage format. - ! uval - complex(psb_spk_), dimension(:), input/output. - ! The U factor in the incomplete factorization. - ! The entries of U are stored according to the CSR format. - ! uja - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the U factor, - ! according to the CSR storage format. - ! uirp - integer, dimension(:), input/output. - ! The indices identifying the first nonzero entry of each row - ! of the U factor in uval, according to the CSR storage format. - ! l1 - integer, output - ! The number of nonzero entries in lval. - ! l2 - integer, output - ! The number of nonzero entries in uval. - ! info - integer, output. - ! Error code. - ! - subroutine mld_cilut_factint(fill_in,thres,a,b,& - & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info,scale) - - use psb_base_mod - - implicit none - - ! Arguments - integer(psb_ipk_), intent(in) :: fill_in - real(psb_spk_), intent(in) :: thres - type(psb_cspmat_type),intent(in) :: a,b - integer(psb_ipk_),intent(inout) :: l1,l2,info - integer(psb_ipk_), allocatable, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) - complex(psb_spk_), allocatable, intent(inout) :: lval(:),uval(:) - complex(psb_spk_), intent(inout) :: d(:) - real(psb_spk_), intent(in), optional :: scale - - ! Local Variables - integer(psb_ipk_) :: i, ktrw,err_act,nidx,nlw,nup,jmaxup, ma, mb, m - real(psb_spk_) :: nrmi - real(psb_spk_) :: weight - integer(psb_ipk_), allocatable :: idxs(:) - complex(psb_spk_), allocatable :: row(:) - type(psb_i_heap) :: heap - type(psb_c_coo_sparse_mat) :: trw - character(len=20), parameter :: name='mld_cilut_factint' - character(len=20) :: ch_err - - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - - - ma = a%get_nrows() - mb = b%get_nrows() - m = ma+mb - - ! - ! Allocate a temporary buffer for the ilut_copyin function - ! - call trw%allocate(izero,izero,ione) - if (info == psb_success_) call psb_ensure_size(m+1,lirp,info) - if (info == psb_success_) call psb_ensure_size(m+1,uirp,info) - - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_sp_all') - goto 9999 - end if - - l1=0 - l2=0 - lirp(1) = 1 - uirp(1) = 1 - - ! - ! Allocate memory to hold the entries of a row - ! - allocate(row(m),stat=info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - - row(:) = czero - weight = sone - if (present(scale)) weight = abs(scale) - ! - ! Cycle over the matrix rows - ! - do i = 1, m - - ! - ! At each iteration of the loop we keep in a heap the column indices - ! affected by the factorization. The heap is initialized and filled - ! in the ilut_copyin function, and updated during the elimination, in - ! the ilut_fact routine. The heap is ideal because at each step we need - ! the lowest index, but we also need to insert new items, and the heap - ! allows to do both in log time. - ! - d(i) = czero - if (i<=ma) then - call ilut_copyin(i,ma,a,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& - & row,heap,ktrw,trw,info) - else - call ilut_copyin(i-ma,mb,b,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& - & row,heap,ktrw,trw,info) - endif - - ! - ! Do an elimination step on current row - ! - if (info == psb_success_) call ilut_fact(thres,i,nrmi,row,heap,& - & d,uja,uirp,uval,nidx,idxs,info) - ! - ! Copy the row into lval/d(i)/uval - ! - if (info == psb_success_) call ilut_copyout(fill_in,thres,i,m,& - & nlw,nup,jmaxup,nrmi,row,nidx,idxs,& - & l1,l2,lja,lirp,lval,d,uja,uirp,uval,info) - - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='Copy/factor loop') - goto 9999 - end if - - end do - ! - ! Adjust diagonal accounting for scale factor - ! - if (weight /= sone) then - d(1:m) = d(1:m)*weight - end if - - ! - ! And we're sone, so deallocate the memory - ! - deallocate(row,idxs,stat=info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Deallocate') - goto 9999 - end if - if (info == psb_success_) call trw%free() - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine mld_cilut_factint - - ! - ! Subroutine: ilut_copyin - ! Version: complex - ! Note: internal subroutine of mld_cilut_fact - ! - ! This routine performs the following tasks: - ! - copying a row of a sparse matrix A, stored in the sparse matrix structure a, - ! into the array row; - ! - storing into a heap the column indices of the nonzero entries of the copied - ! row; - ! - computing the column index of the first entry with maximum absolute value - ! in the part of the row belonging to the upper triangle; - ! - computing the 2-norm of the row. - ! The output array row is such that it contains a full row of A, i.e. it contains - ! also the zero entries of the row. This is useful for the elimination step - ! performed by ilut_fact after the call to ilut_copyin (see mld_ilut_factint). - ! - ! If the sparse matrix is in CSR format, a 'straight' copy is performed; - ! otherwise psb_sp_getblk is used to extract a block of rows, which is then - ! copied, row by row, into the array row, through successive calls to - ! ilut_copyin. - ! - ! This routine is used by mld_cilut_factint in the computation of the ILU(k,t) - ! factorization of a local sparse matrix. - ! - ! - ! Arguments: - ! i - integer, input. - ! The local index of the row to be extracted from the - ! sparse matrix structure a. - ! m - integer, input. - ! The number of rows of the local matrix stored into a. - ! a - type(psb_cspmat_type), input. - ! The sparse matrix structure containing the row to be - ! copied. - ! jd - integer, input. - ! The column index of the diagonal entry of the row to be - ! copied. - ! jmin - integer, input. - ! The minimum valid column index. - ! jmax - integer, input. - ! The maximum valid column index. - ! The output matrix will contain a clipped copy taken from - ! a(1:m,jmin:jmax). - ! nlw - integer, output. - ! The number of nonzero entries in the part of the row - ! belonging to the lower triangle of the matrix. - ! nup - integer, output. - ! The number of nonzero entries in the part of the row - ! belonging to the upper triangle of the matrix. - ! jmaxup - integer, output. - ! The column index of the first entry with maximum absolute - ! value in the part of the row belonging to the upper triangle - ! nrmi - real(psb_spk_), output. - ! The 2-norm of the current row. - ! row - complex(psb_spk_), dimension(:), input/output. - ! In input it is the null vector (see mld_ilut_factint and - ! ilut_copyout). In output it contains the row extracted - ! from the matrix A. It actually contains a full row, i.e. - ! it contains also the zero entries of the row. - ! rowlevs - integer, dimension(:), input/output. - ! In input rowlevs(k) = -(m+1) for k=1,...,m. In output - ! rowlevs(k) = 0 for 1 <= k <= jmax and A(i,k) /= 0, for - ! future use in ilut_fact. - ! heap - type(psb_int_heap), input/output. - ! The heap containing the column indices of the nonzero - ! entries in the array row. - ! Note: this argument is intent(inout) and not only intent(out) - ! to retain its allocation, sone by psb_init_heap inside this - ! routine. - ! ktrw - integer, input/output. - ! The index identifying the last entry taken from the - ! staging buffer trw. See below. - ! trw - type(psb_cspmat_type), input/output. - ! A staging buffer. If the matrix A is not in CSR format, we use - ! the psb_sp_getblk routine and store its output in trw; when we - ! need to call psb_sp_getblk we do it for a block of rows, and then - ! we consume them from trw in successive calls to this routine, - ! until we empty the buffer. Thus we will make a call to psb_sp_getblk - ! every nrb calls to copyin. If A is in CSR format it is unused. - ! - subroutine ilut_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,& - & nrmi,weight,row,heap,ktrw,trw,info) - use psb_base_mod - implicit none - type(psb_cspmat_type), intent(in) :: a - type(psb_c_coo_sparse_mat), intent(inout) :: trw - integer(psb_ipk_), intent(in) :: i, m,jmin,jmax,jd - integer(psb_ipk_), intent(inout) :: ktrw,nlw,nup,jmaxup,info - real(psb_spk_), intent(inout) :: nrmi - complex(psb_spk_), intent(inout) :: row(:) - real(psb_spk_), intent(in) :: weight - type(psb_i_heap), intent(inout) :: heap - - integer(psb_ipk_) :: k,j,irb,kin,nz - integer(psb_ipk_), parameter :: nrb=40 - real(psb_spk_) :: dmaxup - real(psb_spk_), external :: dnrm2 - character(len=20), parameter :: name='mld_cilut_factint' - - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - - call heap%init(info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_init_heap') - goto 9999 - end if - - ! - ! nrmi is the norm of the current sparse row (for the time being, - ! we use the 2-norm). - ! NOTE: the 2-norm below includes also elements that are outside - ! [jmin:jmax] strictly. Is this really important? TO BE CHECKED. - ! - - nlw = 0 - nup = 0 - jmaxup = 0 - dmaxup = szero - nrmi = szero - - select type (aa=> a%a) - type is (psb_c_csr_sparse_mat) - ! - ! Take a fast shortcut if the matrix is stored in CSR format - ! - - do j = aa%irp(i), aa%irp(i+1) - 1 - k = aa%ja(j) - if ((jmin<=k).and.(k<=jmax)) then - row(k) = aa%val(j)*weight - call heap%insert(k,info) - if (info /= psb_success_) exit - if (kjd) then - nup = nup + 1 - if (abs(row(k))>dmaxup) then - jmaxup = k - dmaxup = abs(row(k)) - end if - end if - end if - end do - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_insert_heap') - goto 9999 - end if - - nz = aa%irp(i+1) - aa%irp(i) - nrmi = weight*dnrm2(nz,aa%val(aa%irp(i)),ione) - - - class default - - ! - ! Otherwise use psb_sp_getblk, slower but able (in principle) of - ! handling any format. In this case, a block of rows is extracted - ! instead of a single row, for performance reasons, and these - ! rows are copied one by one into the array row, through successive - ! calls to ilut_copyin. - ! - - if ((mod(i,nrb) == 1).or.(nrb == 1)) then - irb = min(m-i+1,nrb) - call aa%csget(i,i+irb-1,trw,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_sp_getblk') - goto 9999 - end if - ktrw=1 - end if - - kin = ktrw - nz = trw%get_nzeros() - do - if (ktrw > nz) exit - if (trw%ia(ktrw) > i) exit - k = trw%ja(ktrw) - if ((jmin<=k).and.(k<=jmax)) then - row(k) = trw%val(ktrw)*weight - call heap%insert(k,info) - if (info /= psb_success_) exit - if (kjd) then - nup = nup + 1 - if (abs(row(k))>dmaxup) then - jmaxup = k - dmaxup = abs(row(k)) - end if - end if - end if - ktrw = ktrw + 1 - enddo - nz = ktrw - kin - nrmi = weight*dnrm2(nz,trw%val(kin),ione) - end select - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine ilut_copyin - - ! - ! Subroutine: ilut_fact - ! Version: complex - ! Note: internal subroutine of mld_cilut_fact - ! - ! This routine does an elimination step of the ILU(k,t) factorization on a single - ! matrix row (see the calling routine mld_ilut_factint). Actually, only the dropping - ! rule based on the threshold is applied here. The dropping rule based on the - ! fill-in is applied by ilut_copyout. - ! - ! The routine is used by mld_cilut_factint in the computation of the ILU(k,t) - ! factorization of a local sparse matrix. - ! - ! - ! Arguments - ! thres - real, input. - ! The threshold t, i.e. the drop tolerance, in ILU(k,t). - ! i - integer, input. - ! The local index of the row to which the factorization is applied. - ! nrmi - real(psb_spk_), input. - ! The 2-norm of the row to which the elimination step has to be - ! applied. - ! row - complex(psb_spk_), dimension(:), input/output. - ! In input it contains the row to which the elimination step - ! has to be applied. In output it contains the row after the - ! elimination step. It actually contains a full row, i.e. - ! it contains also the zero entries of the row. - ! heap - type(psb_i_heap), input/output. - ! The heap containing the column indices of the nonzero entries - ! in the processed row. In input it contains the indices concerning - ! the row before the elimination step, while in output it contains - ! the previous indices plus the ones corresponding to transformed - ! entries in the 'upper part' that have not been dropped. - ! d - complex(psb_spk_), input. - ! The inverse of the diagonal entries of the part of the U factor - ! above the current row (see ilut_copyout). - ! uja - integer, dimension(:), input. - ! The column indices of the nonzero entries of the part of the U - ! factor above the current row, stored in uval row by row (see - ! ilut_copyout, called by mld_cilut_factint), according to the CSR - ! storage format. - ! uirp - integer, dimension(:), input. - ! The indices identifying the first nonzero entry of each row of - ! the U factor above the current row, stored in uval row by row - ! (see ilut_copyout, called by mld_cilut_factint), according to - ! the CSR storage format. - ! uval - complex(psb_spk_), dimension(:), input. - ! The entries of the U factor above the current row (except the - ! diagonal ones), stored according to the CSR format. - ! nidx - integer, output. - ! The number of entries of the array row that have been - ! examined during the elimination step. This will be used - ! by the routine ilut_copyout. - ! idxs - integer, dimension(:), allocatable, input/output. - ! The indices of the entries of the array row that have been - ! examined during the elimination step.This will be used by - ! by the routine ilut_copyout. - ! Note: this argument is intent(inout) and not only intent(out) - ! to retain its allocation, sone by this routine. - ! - subroutine ilut_fact(thres,i,nrmi,row,heap,d,uja,uirp,uval,nidx,idxs,info) - - use psb_base_mod - - implicit none - - ! Arguments - type(psb_i_heap), intent(inout) :: heap - integer(psb_ipk_), intent(in) :: i - integer(psb_ipk_), intent(inout) :: nidx,info - real(psb_spk_), intent(in) :: thres,nrmi - integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) - integer(psb_ipk_), intent(inout) :: uja(:),uirp(:) - complex(psb_spk_), intent(inout) :: row(:), uval(:),d(:) - - ! Local Variables - integer(psb_ipk_) :: k,j,jj,lastk,iret - complex(psb_spk_) :: rwk - - info = psb_success_ - call psb_ensure_size(200*ione,idxs,info) - if (info /= psb_success_) return - nidx = 0 - lastk = -1 - ! - ! Do while there are indices to be processed - ! - do - - call heap%get_first(k,iret) - if (iret < 0) exit - - ! - ! An index may have been put on the heap more than once. - ! - if (k == lastk) cycle - - lastk = k - lowert: if (k nidx) exit - if (idxs(idxp) >= i) exit - widx = idxs(idxp) - witem = row(widx) - ! - ! Dropping rule based on the 2-norm - ! - if (abs(witem) < thres*nrmi) cycle - - nz = nz + 1 - xw(nz) = witem - xwid(nz) = widx - call heap%insert(witem,widx,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_insert_heap') - goto 9999 - end if - end do - - ! - ! Now we have to take out the first nlw+fill_in entries - ! - if (nz <= nlw+fill_in) then - ! - ! Just copy everything from xw, and it is already ordered - ! - else - nz = nlw+fill_in - do k=1,nz - call heap%get_first(witem,widx,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_heap_get_first') - goto 9999 - end if - - xw(k) = witem - xwid(k) = widx - end do - end if - - ! - ! Now put things back into ascending column order - ! - call psb_msort(xwid(1:nz),indx(1:nz),dir=psb_sort_up_) - - ! - ! Copy out the lower part of the row - ! - do k=1,nz - l1 = l1 + 1 - if (size(lval) < l1) then - ! - ! Figure out a good reallocation size! - ! - isz = (max((l1/i)*m,int(1.2*l1),l1+100)) - call psb_realloc(isz,lval,info) - if (info == psb_success_) call psb_realloc(isz,lja,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - end if - lja(l1) = xwid(k) - lval(l1) = xw(indx(k)) - end do - - ! - ! Make sure idxp points to the diagonal entry - ! - if (idxp <= size(idxs)) then - if (idxs(idxp) < i) then - do - idxp = idxp + 1 - if (idxp > nidx) exit - if (idxs(idxp) >= i) exit - end do - end if - end if - if (idxp > size(idxs)) then -!!$ write(0,*) 'Warning: missing diagonal element in the row ' - else - if (idxs(idxp) > i) then -!!$ write(0,*) 'Warning: missing diagonal element in the row ' - else if (idxs(idxp) /= i) then -!!$ write(0,*) 'Warning: impossible error: diagonal has vanished' - else - ! - ! Copy the diagonal entry - ! - widx = idxs(idxp) - witem = row(widx) - d(i) = witem - if (abs(d(i)) < s_epstol) then - ! - ! Too small pivot: unstable factorization - ! - info = psb_err_pivot_too_small_ - int_err(1) = i - write(ch_err,'(g20.10)') d(i) - call psb_errpush(info,name,i_err=int_err,a_err=ch_err) - goto 9999 - else - ! - ! Compute 1/pivot - ! - d(i) = cone/d(i) - end if - end if - end if - - ! - ! Now the upper part - ! - - call heap%init(info,dir=psb_asort_down_) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_init_heap') - goto 9999 - end if - - nz = 0 - do - - idxp = idxp + 1 - if (idxp > nidx) exit - widx = idxs(idxp) - if (widx <= i) then -!!$ write(0,*) 'Warning: lower triangle in upper copy',widx,i,idxp,idxs(idxp) - cycle - end if - if (widx > m) then -!!$ write(0,*) 'Warning: impossible value',widx,i,idxp,idxs(idxp) - cycle - end if - witem = row(widx) - ! - ! Dropping rule based on the 2-norm. But keep the jmaxup-th entry anyway. - ! - if ((widx /= jmaxup) .and. (abs(witem) < thres*nrmi)) then - cycle - end if - - nz = nz + 1 - xw(nz) = witem - xwid(nz) = widx - call heap%insert(witem,widx,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_insert_heap') - goto 9999 - end if - - end do - - ! - ! Now we have to take out the first nup-fill_in entries. But make sure - ! we include entry jmaxup. - ! - if (nz <= nup+fill_in) then - ! - ! Just copy everything from xw - ! - fndmaxup=.true. - else - fndmaxup = .false. - nz = nup+fill_in - do k=1,nz - call heap%get_first(witem,widx,info) - xw(k) = witem - xwid(k) = widx - if (widx == jmaxup) fndmaxup=.true. - end do - end if - if ((i= 0 - call mld_ilut_fact(sv%fill_in,sv%thresh,& + call psb_ilut_fact(sv%fill_in,sv%thresh,& & a, sv%l,sv%u,sv%d,info,blck=b) end select if(info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='mld_ilut_fact' + ch_err='psb_ilut_fact' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - case(mld_ilu_n_,mld_milu_n_) + case(psb_ilu_n_,psb_milu_n_) ! ! ILU(k) and MILU(k) ! @@ -137,24 +137,24 @@ subroutine mld_d_ilu_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) ! Fill-in 0 ! Separate implementation of ILU(0) for better performance. ! There seems to be a problem with the separate implementation of MILU(0), - ! contained into mld_ilu0_fact. This must be investigated. For the time being, + ! contained into psb_ilu0_fact. This must be investigated. For the time being, ! resort to the implementation of MILU(k) with k=0. - if (sv%fact_type == mld_ilu_n_) then - call mld_ilu0_fact(sv%fact_type,a,sv%l,sv%u,& + if (sv%fact_type == psb_ilu_n_) then + call psb_ilu0_fact(sv%fact_type,a,sv%l,sv%u,& & sv%d,info,blck=b) else - call mld_iluk_fact(sv%fill_in,sv%fact_type,& + call psb_iluk_fact(sv%fill_in,sv%fact_type,& & a,sv%l,sv%u,sv%d,info,blck=b) endif case(1:) ! Fill-in >= 1 ! The same routine implements both ILU(k) and MILU(k) - call mld_iluk_fact(sv%fill_in,sv%fact_type,& + call psb_iluk_fact(sv%fill_in,sv%fact_type,& & a,sv%l,sv%u,sv%d,info,blck=b) end select if (info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='mld_iluk_fact' + ch_err='psb_iluk_fact' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if diff --git a/mlprec/impl/solver/mld_dilu0_fact.f90 b/mlprec/impl/solver/mld_dilu0_fact.f90 deleted file mode 100644 index d18c6bf9..00000000 --- a/mlprec/impl/solver/mld_dilu0_fact.f90 +++ /dev/null @@ -1,666 +0,0 @@ -! -! -! MLD2P4 version 2.2 -! MultiLevel Domain Decomposition Parallel Preconditioners Package -! based on PSBLAS (Parallel Sparse BLAS version 3.5) -! -! (C) Copyright 2008-2018 -! -! Salvatore Filippone -! Pasqua D'Ambra -! Daniela di Serafino -! -! 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_dilu0_fact.f90 -! -! Subroutine: mld_dilu0_fact -! Version: real -! Contains: mld_dilu0_factint, ilu_copyin -! -! This routine computes either the ILU(0) or the MILU(0) factorization of -! the diagonal blocks of a distributed matrix. These factorizations are used -! to build the 'base preconditioner' (block-Jacobi preconditioner/solver, -! Additive Schwarz preconditioner) corresponding to a given level of a -! multilevel preconditioner. -! -! Details on the above factorizations can be found in -! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, -! SIAM, 2003, Chapter 10. -! -! The local matrix is stored into a and blck, as specified in the description -! of the arguments below. The storage format for both the L and U factors is CSR. -! The diagonal of the U factor is stored separately (actually, the inverse of the -! diagonal entries is stored; this is then managed in the solve stage associated -! to the ILU(0)/MILU(0) factorization). -! -! The routine copies and factors "on the fly" from a and blck into l (L factor), -! u (U factor, except its diagonal) and d (diagonal of U). -! -! This implementation of ILU(0)/MILU(0) is faster than the implementation in -! mld_ziluk_fct (the latter routine performs the more general ILU(k)/MILU(k)). -! -! -! Arguments: -! ialg - integer, input. -! The type of incomplete factorization to be performed. -! The MILU(0) factorization is computed if ialg = 2 (= mld_milu_n_); -! the ILU(0) factorization otherwise. -! a - type(psb_dspmat_type), input. -! The sparse matrix structure containing the local matrix. -! Note that if the 'base' Additive Schwarz preconditioner -! has overlap greater than 0 and the matrix has not been reordered -! (see mld_as_bld), then a contains only the 'original' local part -! of the distributed matrix, i.e. the rows of the matrix held -! by the calling process according to the initial data distribution. -! l - type(psb_dspmat_type), input/output. -! The L factor in the incomplete factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! u - type(psb_dspmat_type), input/output. -! The U factor (except its diagonal) in the incomplete factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! d - real(psb_dpk_), dimension(:), input/output. -! The inverse of the diagonal entries of the U factor in the incomplete -! factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! info - integer, output. -! Error code. -! blck - type(psb_dspmat_type), input, optional, target. -! The sparse matrix structure containing the remote rows of the -! distributed matrix, that have been retrieved by mld_as_bld -! to build an Additive Schwarz base preconditioner with overlap -! greater than 0. If the overlap is 0 or the matrix has been reordered -! (see mld_fact_bld), then blck is empty. -! -subroutine mld_dilu0_fact(ialg,a,l,u,d,info,blck, upd) - - use psb_base_mod - use mld_d_ilu_fact_mod, mld_protect_name => mld_dilu0_fact - - implicit none - - ! Arguments - integer(psb_ipk_), intent(in) :: ialg - type(psb_dspmat_type),intent(in) :: a - type(psb_dspmat_type),intent(inout) :: l,u - real(psb_dpk_), intent(inout) :: d(:) - integer(psb_ipk_), intent(out) :: info - type(psb_dspmat_type),intent(in), optional, target :: blck - character, intent(in), optional :: upd - - ! Local variables - integer(psb_ipk_) :: l1, l2, m, err_act - type(psb_dspmat_type), pointer :: blck_ - type(psb_d_csr_sparse_mat) :: ll, uu - character :: upd_ - character(len=20) :: name, ch_err - - name='mld_dilu0_fact' - info = psb_success_ - call psb_erractionsave(err_act) - - ! - ! Point to / allocate memory for the incomplete factorization - ! - if (present(blck)) then - blck_ => blck - else - allocate(blck_,stat=info) - if (info == psb_success_) call blck_%csall(izero,izero,info,ione) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='csall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - if (present(upd)) then - upd_ = psb_toupper(upd) - else - upd_ = 'F' - end if - - m = a%get_nrows() + blck_%get_nrows() - if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& - & (m > size(d)) ) then - write(0,*) 'Wrong allocation status for L,D,U? ',& - & l%get_nrows(),size(d),u%get_nrows() - info = -1 - return - end if - - call l%mv_to(ll) - call u%mv_to(uu) - ! - ! Compute the ILU(0) or the MILU(0) factorization, depending on ialg - ! - call mld_dilu0_factint(ialg,a,blck_,& - & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,upd_,info) - if(info.ne.0) then - info=psb_err_from_subroutine_ - ch_err='mld_dilu0_factint' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - ! - ! Store information on the L and U sparse matrices - ! - call l%mv_from(ll) - call l%set_triangle() - call l%set_unit() - call l%set_lower() - call u%mv_from(uu) - call u%set_triangle() - call u%set_unit() - call u%set_upper() - - ! - ! Nullify pointer / deallocate memory - ! - if (present(blck)) then - blck_ => null() - else - call blck_%free() - if(info.ne.0) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - deallocate(blck_) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -contains - - ! - ! Subroutine: mld_dilu0_factint - ! Version: real - ! Note: internal subroutine of mld_dilu0_fact. - ! - ! This routine computes either the ILU(0) or the MILU(0) factorization of the - ! diagonal blocks of a distributed matrix. - ! These factorizations are used to build the 'base preconditioner' - ! (block-Jacobi preconditioner/solver, Additive Schwarz - ! preconditioner) corresponding to a given level of a multilevel preconditioner. - ! - ! The local matrix is stored into a and b, as specified in the - ! description of the arguments below. The storage format for both the L and U - ! factors is CSR. The diagonal of the U factor is stored separately (actually, - ! the inverse of the diagonal entries is stored; this is then managed in the - ! solve stage associated to the ILU(0)/MILU(0) factorization). - ! - ! The routine copies and factors "on the fly" from the sparse matrix structures a - ! and b into the arrays lval, uval, d (L, U without its diagonal, diagonal of U). - ! - ! - ! Arguments: - ! ialg - integer, input. - ! The type of incomplete factorization to be performed. - ! The ILU(0) factorization is computed if ialg = 1 (= mld_ilu_n_), - ! the MILU(0) one if ialg = 2 (= mld_milu_n_); other values - ! are not allowed. - ! m - integer, output. - ! The total number of rows of the local matrix to be factorized, - ! i.e. ma+mb. - ! ma - integer, input - ! The number of rows of the local submatrix stored into a. - ! a - type(psb_dspmat_type), input. - ! The sparse matrix structure containing the local matrix. - ! Note that, if the 'base' Additive Schwarz preconditioner - ! has overlap greater than 0 and the matrix has not been reordered - ! (see mld_fact_bld), then a contains only the 'original' local part - ! of the distributed matrix, i.e. the rows of the matrix held - ! by the calling process according to the initial data distribution. - ! mb - integer, input. - ! The number of rows of the local submatrix stored into b. - ! b - type(psb_dspmat_type), input. - ! The sparse matrix structure containing the remote rows of the - ! distributed matrix, that have been retrieved by mld_as_bld - ! to build an Additive Schwarz base preconditioner with overlap - ! greater than 0. If the overlap is 0 or the matrix has been - ! reordered (see mld_fact_bld), then b does not contain any row. - ! d - real(psb_dpk_), dimension(:), output. - ! The inverse of the diagonal entries of the U factor in the - ! incomplete factorization. - ! lval - real(psb_dpk_), dimension(:), input/output. - ! The entries of U are stored according to the CSR format. - ! The L factor in the incomplete factorization. - ! lja - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the L factor, - ! according to the CSR storage format. - ! lirp - integer, dimension(:), input/output. - ! The indices identifying the first nonzero entry of each row - ! of the L factor in lval, according to the CSR storage format. - ! uval - real(psb_dpk_), dimension(:), input/output. - ! The U factor in the incomplete factorization. - ! The entries of U are stored according to the CSR format. - ! uja - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the U factor, - ! according to the CSR storage format. - ! uirp - integer, dimension(:), input/output. - ! The indices identifying the first nonzero entry of each row - ! of the U factor in uval, according to the CSR storage format. - ! l1 - integer, output. - ! The number of nonzero entries in lval. - ! l2 - integer, output. - ! The number of nonzero entries in uval. - ! info - integer, output. - ! Error code. - ! - subroutine mld_dilu0_factint(ialg,a,b,& - & d,lval,lja,lirp,uval,uja,uirp,l1,l2,upd,info) - - implicit none - - ! Arguments - integer(psb_ipk_), intent(in) :: ialg - type(psb_dspmat_type),intent(in) :: a,b - integer(psb_ipk_),intent(inout) :: l1,l2,info - integer(psb_ipk_), intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) - real(psb_dpk_), intent(inout) :: lval(:),uval(:),d(:) - character, intent(in) :: upd - - ! Local variables - integer(psb_ipk_) :: i,j,k,l,low1,low2,kk,jj,ll, ktrw,err_act, m - integer(psb_ipk_) :: ma,mb - real(psb_dpk_) :: dia,temp - integer(psb_ipk_), parameter :: nrb=16 - type(psb_d_coo_sparse_mat) :: trw - integer(psb_ipk_) :: int_err(5) - character(len=20) :: name, ch_err - - name='mld_dilu0_factint' - info=psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - ma = a%get_nrows() - mb = b%get_nrows() - - select case(ialg) - case(mld_ilu_n_,mld_milu_n_) - ! Ok - case default - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,& - & i_err=(/ione,ialg,izero,izero,izero/)) - goto 9999 - end select - - call trw%allocate(izero,izero,ione) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_all' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - m = ma+mb - - if (psb_toupper(upd) == 'F' ) then - lirp(1) = 1 - uirp(1) = 1 - l1 = 0 - l2 = 0 - - ! - ! Cycle over the matrix rows - ! - do i = 1, m - - d(i) = dzero - - if (i <= ma) then - ! - ! Copy the i-th local row of the matrix, stored in a, - ! into lval/d(i)/uval - ! - call ilu_copyin(i,ma,a,i,ione,m,l1,lja,lval,& - & d(i),l2,uja,uval,ktrw,trw,upd) - else - ! - ! Copy the i-th local row of the matrix, stored in b - ! (as (i-ma)-th row), into lval/d(i)/uval - ! - call ilu_copyin(i-ma,mb,b,i,ione,m,l1,lja,lval,& - & d(i),l2,uja,uval,ktrw,trw,upd) - endif - - lirp(i+1) = l1 + 1 - uirp(i+1) = l2 + 1 - - dia = d(i) - do kk = lirp(i), lirp(i+1) - 1 - ! - ! Compute entry l(i,k) (lower factor L) of the incomplete - ! factorization - ! - temp = lval(kk) - k = lja(kk) - lval(kk) = temp*d(k) - ! - ! Update the rest of row i (lower and upper factors L and U) - ! using l(i,k) - ! - low1 = kk + 1 - low2 = uirp(i) - ! - updateloop: do jj = uirp(k), uirp(k+1) - 1 - ! - j = uja(jj) - ! - if (j < i) then - ! - ! search l(i,*) (i-th row of L) for a matching index j - ! - do ll = low1, lirp(i+1) - 1 - l = lja(ll) - if (l > j) then - low1 = ll - exit - else if (l == j) then - lval(ll) = lval(ll) - temp*uval(jj) - low1 = ll + 1 - cycle updateloop - end if - enddo - - else if (j == i) then - ! - ! j=i: update the diagonal - ! - dia = dia - temp*uval(jj) - cycle updateloop - ! - else if (j > i) then - ! - ! search u(i,*) (i-th row of U) for a matching index j - ! - do ll = low2, uirp(i+1) - 1 - l = uja(ll) - if (l > j) then - low2 = ll - exit - else if (l == j) then - uval(ll) = uval(ll) - temp*uval(jj) - low2 = ll + 1 - cycle updateloop - end if - enddo - end if - ! - ! If we get here we missed the cycle updateloop, which means - ! that this entry does not match; thus we accumulate on the - ! diagonal for MILU(0). - ! - if (ialg == mld_milu_n_) then - dia = dia - temp*uval(jj) - end if - enddo updateloop - enddo - ! - ! Check the pivot size - ! - if (abs(dia) < d_epstol) then - ! - ! Too small pivot: unstable factorization - ! - info = psb_err_pivot_too_small_ - int_err(1) = i - write(ch_err,'(g20.10)') abs(dia) - call psb_errpush(info,name,i_err=int_err,a_err=ch_err) - goto 9999 - else - ! - ! Compute 1/pivot - ! - dia = done/dia - end if - d(i) = dia - ! - ! Scale row i of upper triangle - ! - do kk = uirp(i), uirp(i+1) - 1 - uval(kk) = uval(kk)*dia - enddo - enddo - else - write(0,*) 'Update not implemented ' - info = 31 - call psb_errpush(info,name,& - & i_err=(/ione*13,izero,izero,izero,izero/),a_err=upd) - goto 9999 - - end if - - call trw%free() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine mld_dilu0_factint - - ! - ! Subroutine: ilu_copyin - ! Version: real - ! Note: internal subroutine of mld_dilu0_fact - ! - ! This routine copies a row of a sparse matrix A, stored in the psb_dspmat_type - ! data structure a, into the arrays lval and uval and into the scalar variable - ! dia, corresponding to the lower and upper triangles of A and to the diagonal - ! entry of the row, respectively. The entries in lval and uval are stored - ! according to the CSR format; the corresponding column indices are stored in - ! the arrays lja and uja. - ! - ! If the sparse matrix is in CSR format, a 'straight' copy is performed; - ! otherwise psb_sp_getblk is used to extract a block of rows, which is then - ! copied into lval, dia, uval row by row, through successive calls to - ! ilu_copyin. - ! - ! The routine is used by mld_dilu0_factint in the computation of the ILU(0)/MILU(0) - ! factorization of a local sparse matrix. - ! - ! TODO: modify the routine to allow copying into output L and U that are - ! already filled with indices; this would allow computing an ILU(k) pattern, - ! then use the ILU(0) internal for subsequent calls with the same pattern. - ! - ! Arguments: - ! i - integer, input. - ! The local index of the row to be extracted from the - ! sparse matrix structure a. - ! m - integer, input. - ! The number of rows of the local matrix stored into a. - ! a - type(psb_dspmat_type), input. - ! The sparse matrix structure containing the row to be copied. - ! jd - integer, input. - ! The column index of the diagonal entry of the row to be - ! copied. - ! jmin - integer, input. - ! Minimum valid column index. - ! jmax - integer, input. - ! Maximum valid column index. - ! The output matrix will contain a clipped copy taken from - ! a(1:m,jmin:jmax). - ! l1 - integer, input/output. - ! Pointer to the last occupied entry of lval. - ! lja - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the lower triangle - ! copied in lval row by row (see mld_dilu0_factint), according - ! to the CSR storage format. - ! lval - real(psb_dpk_), dimension(:), input/output. - ! The array where the entries of the row corresponding to the - ! lower triangle are copied. - ! dia - real(psb_dpk_), output. - ! The diagonal entry of the copied row. - ! l2 - integer, input/output. - ! Pointer to the last occupied entry of uval. - ! uja - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the upper triangle - ! copied in uval row by row (see mld_dilu0_factint), according - ! to the CSR storage format. - ! uval - real(psb_dpk_), dimension(:), input/output. - ! The array where the entries of the row corresponding to the - ! upper triangle are copied. - ! ktrw - integer, input/output. - ! The index identifying the last entry taken from the - ! staging buffer trw. See below. - ! trw - type(psb_dspmat_type), input/output. - ! A staging buffer. If the matrix A is not in CSR format, we use - ! the psb_sp_getblk routine and store its output in trw; when we - ! need to call psb_sp_getblk we do it for a block of rows, and then - ! we consume them from trw in successive calls to this routine, - ! until we empty the buffer. Thus we will make a call to psb_sp_getblk - ! every nrb calls to copyin. If A is in CSR format it is unused. - ! - subroutine ilu_copyin(i,m,a,jd,jmin,jmax,l1,lja,lval,& - & dia,l2,uja,uval,ktrw,trw,upd) - - use psb_base_mod - - implicit none - - ! Arguments - type(psb_dspmat_type), intent(in) :: a - type(psb_d_coo_sparse_mat), intent(inout) :: trw - integer(psb_ipk_), intent(in) :: i,m,jd,jmin,jmax - integer(psb_ipk_), intent(inout) :: ktrw,l1,l2 - integer(psb_ipk_), intent(inout) :: lja(:), uja(:) - real(psb_dpk_), intent(inout) :: lval(:), uval(:), dia - character, intent(in) :: upd - ! Local variables - integer(psb_ipk_) :: k,j,info,irb, nz - integer(psb_ipk_), parameter :: nrb=40 - character(len=20), parameter :: name='ilu_copyin' - character(len=20) :: ch_err - - info=psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - if (psb_toupper(upd) == 'F') then - - select type(aa => a%a) - type is (psb_d_csr_sparse_mat) - - ! - ! Take a fast shortcut if the matrix is stored in CSR format - ! - - do j = aa%irp(i), aa%irp(i+1) - 1 - k = aa%ja(j) - ! write(0,*)'KKKKK',k - if ((k < jd).and.(k >= jmin)) then - l1 = l1 + 1 - lval(l1) = aa%val(j) - lja(l1) = k - else if (k == jd) then - dia = aa%val(j) - else if ((k > jd).and.(k <= jmax)) then - l2 = l2 + 1 - uval(l2) = aa%val(j) - uja(l2) = k - end if - enddo - - class default - - ! - ! Otherwise use psb_sp_getblk, slower but able (in principle) of - ! handling any format. In this case, a block of rows is extracted - ! instead of a single row, for performance reasons, and these - ! rows are copied one by one into lval, dia, uval, through - ! successive calls to ilu_copyin. - ! - - if ((mod(i,nrb) == 1).or.(nrb == 1)) then - irb = min(m-i+1,nrb) - call aa%csget(i,i+irb-1,trw,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='csget' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - ktrw=1 - end if - - nz = trw%get_nzeros() - do - if (ktrw > nz) exit - if (trw%ia(ktrw) > i) exit - k = trw%ja(ktrw) - if ((k < jd).and.(k >= jmin)) then - l1 = l1 + 1 - lval(l1) = trw%val(ktrw) - lja(l1) = k - else if (k == jd) then - dia = trw%val(ktrw) - else if ((k > jd).and.(k <= jmax)) then - l2 = l2 + 1 - uval(l2) = trw%val(ktrw) - uja(l2) = k - end if - ktrw = ktrw + 1 - enddo - - end select - - else - - write(0,*) 'Update not implemented ' - info = 31 - call psb_errpush(info,name,& - & i_err=(/ione*13,izero,izero,izero,izero/),a_err=upd) - goto 9999 - - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine ilu_copyin - -end subroutine mld_dilu0_fact diff --git a/mlprec/impl/solver/mld_diluk_fact.f90 b/mlprec/impl/solver/mld_diluk_fact.f90 deleted file mode 100644 index 85fed716..00000000 --- a/mlprec/impl/solver/mld_diluk_fact.f90 +++ /dev/null @@ -1,969 +0,0 @@ -! -! -! MLD2P4 version 2.2 -! MultiLevel Domain Decomposition Parallel Preconditioners Package -! based on PSBLAS (Parallel Sparse BLAS version 3.5) -! -! (C) Copyright 2008-2018 -! -! Salvatore Filippone -! Pasqua D'Ambra -! Daniela di Serafino -! -! 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_diluk_fact.f90 -! -! Subroutine: mld_diluk_fact -! Version: real -! Contains: mld_diluk_factint, iluk_copyin, iluk_fact, iluk_copyout. -! -! This routine computes either the ILU(k) or the MILU(k) factorization of the -! diagonal blocks of a distributed matrix. These factorizations are used to -! build the 'base preconditioner' (block-Jacobi preconditioner/solver, -! Additive Schwarz preconditioner) corresponding to a certain level of a -! multilevel preconditioner. -! -! Details on the above factorizations can be found in -! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, -! SIAM, 2003, Chapter 10. -! -! The local matrix is stored into a and blck, as specified in -! the description of the arguments below. The storage format for both the L and -! U factors is CSR. The diagonal of the U factor is stored separately (actually, -! the inverse of the diagonal entries is stored; this is then managed in the solve -! stage associated to the ILU(k)/MILU(k) factorization). -! -! -! Arguments: -! fill_in - integer, input. -! The fill-in level k in ILU(k)/MILU(k). -! ialg - integer, input. -! The type of incomplete factorization to be performed. -! The ILU(k) factorization is computed if ialg = 1 (= mld_ilu_n_); -! the MILU(k) one if ialg = 2 (= mld_milu_n_); other values are -! not allowed. -! a - type(psb_dspmat_type), input. -! The sparse matrix structure containing the local matrix. -! Note that if the 'base' Additive Schwarz preconditioner -! has overlap greater than 0 and the matrix has not been reordered -! (see mld_fact_bld), then a contains only the 'original' local part -! of the distributed matrix, i.e. the rows of the matrix held -! by the calling process according to the initial data distribution. -! l - type(psb_dspmat_type), input/output. -! The L factor in the incomplete factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! u - type(psb_dspmat_type), input/output. -! The U factor (except its diagonal) in the incomplete factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! d - real(psb_dpk_), dimension(:), input/output. -! The inverse of the diagonal entries of the U factor in the incomplete -! factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! info - integer, output. -! Error code. -! blck - type(psb_dspmat_type), input, optional, target. -! The sparse matrix structure containing the remote rows of the -! distributed matrix, that have been retrieved by mld_as_bld -! to build an Additive Schwarz base preconditioner with overlap -! greater than 0. If the overlap is 0 or the matrix has been reordered -! (see mld_fact_bld), then blck does not contain any row. -! -subroutine mld_diluk_fact(fill_in,ialg,a,l,u,d,info,blck) - - use psb_base_mod - use mld_d_ilu_fact_mod, mld_protect_name => mld_diluk_fact - - implicit none - - ! Arguments - integer(psb_ipk_), intent(in) :: fill_in, ialg - integer(psb_ipk_), intent(out) :: info - type(psb_dspmat_type),intent(in) :: a - type(psb_dspmat_type),intent(inout) :: l,u - type(psb_dspmat_type),intent(in), optional, target :: blck - real(psb_dpk_), intent(inout) :: d(:) - ! Local Variables - integer(psb_ipk_) :: l1, l2, m, err_act - - type(psb_dspmat_type), pointer :: blck_ - type(psb_d_csr_sparse_mat) :: ll, uu - character(len=20) :: name, ch_err - - name='mld_diluk_fact' - info = psb_success_ - call psb_erractionsave(err_act) - - ! - ! Point to / allocate memory for the incomplete factorization - ! - if (present(blck)) then - blck_ => blck - else - allocate(blck_,stat=info) - if (info == psb_success_) call blck_%csall(izero,izero,info,ione) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='csall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - - m = a%get_nrows() + blck_%get_nrows() - if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& - & (m > size(d)) ) then - write(0,*) 'Wrong allocation status for L,D,U? ',& - & l%get_nrows(),size(d),u%get_nrows() - info = -1 - return - end if - - call l%mv_to(ll) - call u%mv_to(uu) - - ! - ! Compute the ILU(k) or the MILU(k) factorization, depending on ialg - ! - call mld_diluk_factint(fill_in,ialg,a,blck_,& - & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_diluk_factint' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - ! - ! Store information on the L and U sparse matrices - ! - call l%mv_from(ll) - call l%set_triangle() - call l%set_unit() - call l%set_lower() - call u%mv_from(uu) - call u%set_triangle() - call u%set_unit() - call u%set_upper() - - ! - ! Nullify pointer / deallocate memory - ! - if (present(blck)) then - blck_ => null() - else - call blck_%free() - deallocate(blck_,stat=info) - if(info.ne.0) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -contains - - ! - ! Subroutine: mld_diluk_factint - ! Version: real - ! Note: internal subroutine of mld_diluk_fact - ! - ! This routine computes either the ILU(k) or the MILU(k) factorization of the - ! diagonal blocks of a distributed matrix. These factorizations are used to build - ! the 'base preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz - ! preconditioner) corresponding to a certain level of a multilevel preconditioner. - ! - ! The local matrix is stored into a and b, as specified in the - ! description of the arguments below. The storage format for both the L and U - ! factors is CSR. The diagonal of the U factor is stored separately (actually, - ! the inverse of the diagonal entries is stored; this is then managed in the - ! solve stage associated to the ILU(k)/MILU(k) factorization). - ! - ! - ! Arguments: - ! fill_in - integer, input. - ! The fill-in level k in ILU(k)/MILU(k). - ! ialg - integer, input. - ! The type of incomplete factorization to be performed. - ! The MILU(k) factorization is computed if ialg = 2 (= mld_milu_n_); - ! the ILU(k) factorization otherwise. - ! m - integer, output. - ! The total number of rows of the local matrix to be factorized, - ! i.e. ma+mb. - ! a - type(psb_dspmat_type), input. - ! The sparse matrix structure containing the local matrix. - ! Note that, if the 'base' Additive Schwarz preconditioner - ! has overlap greater than 0 and the matrix has not been reordered - ! (see mld_fact_bld), then a contains only the 'original' local part - ! of the distributed matrix, i.e. the rows of the matrix held - ! by the calling process according to the initial data distribution. - ! b - type(psb_dspmat_type), input. - ! The sparse matrix structure containing the remote rows of the - ! distributed matrix, that have been retrieved by mld_as_bld - ! to build an Additive Schwarz base preconditioner with overlap - ! greater than 0. If the overlap is 0 or the matrix has been reordered - ! (see mld_fact_bld), then b does not contain any row. - ! d - real(psb_dpk_), dimension(:), output. - ! The inverse of the diagonal entries of the U factor in the incomplete - ! factorization. - ! laspk - real(psb_dpk_), dimension(:), input/output. - ! The L factor in the incomplete factorization. - ! lia1 - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the L factor, - ! according to the CSR storage format. - ! lia2 - integer, dimension(:), input/output. - ! The indices identifying the first nonzero entry of each row - ! of the L factor in laspk, according to the CSR storage format. - ! uval - real(psb_dpk_), dimension(:), input/output. - ! The U factor in the incomplete factorization. - ! The entries of U are stored according to the CSR format. - ! uja - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the U factor, - ! according to the CSR storage format. - ! uirp - integer, dimension(:), input/output. - ! The indices identifying the first nonzero entry of each row - ! of the U factor in uval, according to the CSR storage format. - ! l1 - integer, output - ! The number of nonzero entries in laspk. - ! l2 - integer, output - ! The number of nonzero entries in uval. - ! info - integer, output. - ! Error code. - ! - subroutine mld_diluk_factint(fill_in,ialg,a,b,& - & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info) - - use psb_base_mod - - implicit none - - ! Arguments - integer(psb_ipk_), intent(in) :: fill_in, ialg - type(psb_dspmat_type),intent(in) :: a,b - integer(psb_ipk_),intent(inout) :: l1,l2,info - integer(psb_ipk_), allocatable, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) - real(psb_dpk_), allocatable, intent(inout) :: lval(:),uval(:) - real(psb_dpk_), intent(inout) :: d(:) - - ! Local variables - integer(psb_ipk_) :: ma,mb,i, ktrw,err_act,nidx, m - integer(psb_ipk_), allocatable :: uplevs(:), rowlevs(:),idxs(:) - real(psb_dpk_), allocatable :: row(:) - type(psb_i_heap) :: heap - type(psb_d_coo_sparse_mat) :: trw - character(len=20), parameter :: name='mld_diluk_factint' - character(len=20) :: ch_err - - info=psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - - - select case(ialg) - case(mld_ilu_n_,mld_milu_n_) - ! Ok - case default - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,& - & i_err=(/itwo,ialg,izero,izero,izero/)) - goto 9999 - end select - if (fill_in < 0) then - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name, & - & i_err=(/ione,fill_in,izero,izero,izero/)) - goto 9999 - end if - - ma = a%get_nrows() - mb = b%get_nrows() - m = ma+mb - - ! - ! Allocate a temporary buffer for the iluk_copyin function - ! - - call trw%allocate(izero,izero,ione) - if (info == psb_success_) call psb_ensure_size(m+1,lirp,info) - if (info == psb_success_) call psb_ensure_size(m+1,uirp,info) - - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_sp_all') - goto 9999 - end if - - l1=0 - l2=0 - lirp(1) = 1 - uirp(1) = 1 - - ! - ! Allocate memory to hold the entries of a row and the corresponding - ! fill levels - ! - allocate(uplevs(size(uval)),rowlevs(m),row(m),stat=info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - - uplevs(:) = m+1 - row(:) = dzero - rowlevs(:) = -(m+1) - - ! - ! Cycle over the matrix rows - ! - do i = 1, m - - ! - ! At each iteration of the loop we keep in a heap the column indices - ! affected by the factorization. The heap is initialized and filled - ! in the iluk_copyin routine, and updated during the elimination, in - ! the iluk_fact routine. The heap is ideal because at each step we need - ! the lowest index, but we also need to insert new items, and the heap - ! allows to do both in log time. - ! - d(i) = dzero - if (i<=ma) then - ! - ! Copy into trw the i-th local row of the matrix, stored in a - ! - call iluk_copyin(i,ma,a,ione,m,row,rowlevs,heap,ktrw,trw,info) - else - ! - ! Copy into trw the i-th local row of the matrix, stored in b - ! (as (i-ma)-th row) - ! - call iluk_copyin(i-ma,mb,b,ione,m,row,rowlevs,heap,ktrw,trw,info) - endif - - ! Do an elimination step on the current row. It turns out we only - ! need to keep track of fill levels for the upper triangle, hence we - ! do not have a lowlevs variable. - ! - if (info == psb_success_) call iluk_fact(fill_in,i,row,rowlevs,heap,& - & d,uja,uirp,uval,uplevs,nidx,idxs,info) - ! - ! Copy the row into lval/d(i)/uval - ! - if (info == psb_success_) call iluk_copyout(fill_in,ialg,i,m,row,rowlevs,nidx,idxs,& - & l1,l2,lja,lirp,lval,d,uja,uirp,uval,uplevs,info) - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='Copy/factor loop') - goto 9999 - end if - end do - - ! - ! And we're done, so deallocate the memory - ! - deallocate(uplevs,rowlevs,row,stat=info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Deallocate') - goto 9999 - end if - if (info == psb_success_) call trw%free() - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine mld_diluk_factint - - ! - ! Subroutine: iluk_copyin - ! Version: real - ! Note: internal subroutine of mld_diluk_fact - ! - ! This routine copies a row of a sparse matrix A, stored in the sparse matrix - ! structure a, into the array row and stores into a heap the column indices of - ! the nonzero entries of the copied row. The output array row is such that it - ! contains a full row of A, i.e. it contains also the zero entries of the row. - ! This is useful for the elimination step performed by iluk_fact after the call - ! to iluk_copyin (see mld_iluk_factint). - ! The routine also sets to zero the entries of the array rowlevs corresponding - ! to the nonzero entries of the copied row (see the description of the arguments - ! below). - ! - ! If the sparse matrix is in CSR format, a 'straight' copy is performed; - ! otherwise psb_sp_getblk is used to extract a block of rows, which is then - ! copied, row by row, into the array row, through successive calls to - ! ilu_copyin. - ! - ! This routine is used by mld_diluk_factint in the computation of the - ! ILU(k)/MILU(k) factorization of a local sparse matrix. - ! - ! - ! Arguments: - ! i - integer, input. - ! The local index of the row to be extracted from the - ! sparse matrix structure a. - ! m - integer, input. - ! The number of rows of the local matrix stored into a. - ! a - type(psb_dspmat_type), input. - ! The sparse matrix structure containing the row to be copied. - ! jmin - integer, input. - ! The minimum valid column index. - ! jmax - integer, input. - ! The maximum valid column index. - ! The output matrix will contain a clipped copy taken from - ! a(1:m,jmin:jmax). - ! row - real(psb_dpk_), dimension(:), input/output. - ! In input it is the null vector (see mld_iluk_factint and - ! iluk_copyout). In output it contains the row extracted - ! from the matrix A. It actually contains a full row, i.e. - ! it contains also the zero entries of the row. - ! rowlevs - integer, dimension(:), input/output. - ! In input rowlevs(k) = -(m+1) for k=1,...,m. In output - ! rowlevs(k) = 0 for 1 <= k <= jmax and A(i,k) /= 0, for - ! future use in iluk_fact. - ! heap - type(psb_i_heap), input/output. - ! The heap containing the column indices of the nonzero - ! entries in the array row. - ! Note: this argument is intent(inout) and not only intent(out) - ! to retain its allocation, done by psb_init_heap inside this - ! routine. - ! ktrw - integer, input/output. - ! The index identifying the last entry taken from the - ! staging buffer trw. See below. - ! trw - type(psb_dspmat_type), input/output. - ! A staging buffer. If the matrix A is not in CSR format, we use - ! the psb_sp_getblk routine and store its output in trw; when we - ! need to call psb_sp_getblk we do it for a block of rows, and then - ! we consume them from trw in successive calls to this routine, - ! until we empty the buffer. Thus we will make a call to psb_sp_getblk - ! every nrb calls to copyin. If A is in CSR format it is unused. - ! - subroutine iluk_copyin(i,m,a,jmin,jmax,row,rowlevs,heap,ktrw,trw,info) - - use psb_base_mod - - implicit none - - ! Arguments - type(psb_dspmat_type), intent(in) :: a - type(psb_d_coo_sparse_mat), intent(inout) :: trw - integer(psb_ipk_), intent(in) :: i,m,jmin,jmax - integer(psb_ipk_), intent(inout) :: ktrw,info - integer(psb_ipk_), intent(inout) :: rowlevs(:) - real(psb_dpk_), intent(inout) :: row(:) - type(psb_i_heap), intent(inout) :: heap - - ! Local variables - integer(psb_ipk_) :: k,j,irb,err_act,nz - integer(psb_ipk_), parameter :: nrb=40 - character(len=20), parameter :: name='iluk_copyin' - character(len=20) :: ch_err - - info=psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - call heap%init(info) - - select type (aa=> a%a) - type is (psb_d_csr_sparse_mat) - ! - ! Take a fast shortcut if the matrix is stored in CSR format - ! - - do j = aa%irp(i), aa%irp(i+1) - 1 - k = aa%ja(j) - if ((jmin<=k).and.(k<=jmax)) then - row(k) = aa%val(j) - rowlevs(k) = 0 - call heap%insert(k,info) - end if - end do - - class default - - ! - ! Otherwise use psb_sp_getblk, slower but able (in principle) of - ! handling any format. In this case, a block of rows is extracted - ! instead of a single row, for performance reasons, and these - ! rows are copied one by one into the array row, through successive - ! calls to iluk_copyin. - ! - - if ((mod(i,nrb) == 1).or.(nrb == 1)) then - irb = min(m-i+1,nrb) - call aa%csget(i,i+irb-1,trw,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_getblk' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - ktrw=1 - end if - nz = trw%get_nzeros() - do - if (ktrw > nz) exit - if (trw%ia(ktrw) > i) exit - k = trw%ja(ktrw) - if ((jmin<=k).and.(k<=jmax)) then - row(k) = trw%val(ktrw) - rowlevs(k) = 0 - call heap%insert(k,info) - end if - ktrw = ktrw + 1 - enddo - end select - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine iluk_copyin - - ! - ! Subroutine: iluk_fact - ! Version: real - ! Note: internal subroutine of mld_diluk_fact - ! - ! This routine does an elimination step of the ILU(k) factorization on a - ! single matrix row (see the calling routine mld_iluk_factint). - ! - ! This step is also the base for a MILU(k) elimination step on the row (see - ! iluk_copyout). This routine is used by mld_diluk_factint in the computation - ! of the ILU(k)/MILU(k) factorization of a local sparse matrix. - ! - ! NOTE: it turns out we only need to keep track of the fill levels for - ! the upper triangle. - ! - ! - ! Arguments - ! fill_in - integer, input. - ! The fill-in level k in ILU(k). - ! i - integer, input. - ! The local index of the row to which the factorization is - ! applied. - ! row - real(psb_dpk_), dimension(:), input/output. - ! In input it contains the row to which the elimination step - ! has to be applied. In output it contains the row after the - ! elimination step. It actually contains a full row, i.e. - ! it contains also the zero entries of the row. - ! rowlevs - integer, dimension(:), input/output. - ! In input rowlevs(k) = 0 if the k-th entry of the row is - ! nonzero, and rowlevs(k) = -(m+1) otherwise. In output - ! rowlevs(k) contains the fill kevel of the k-th entry of - ! the row after the current elimination step; rowlevs(k) = -(m+1) - ! means that the k-th row entry is zero throughout the elimination - ! step. - ! heap - type(psb_i_heap), input/output. - ! The heap containing the column indices of the nonzero entries - ! in the processed row. In input it contains the indices concerning - ! the row before the elimination step, while in output it contains - ! the indices concerning the transformed row. - ! d - real(psb_dpk_), input. - ! The inverse of the diagonal entries of the part of the U factor - ! above the current row (see iluk_copyout). - ! uja - integer, dimension(:), input. - ! The column indices of the nonzero entries of the part of the U - ! factor above the current row, stored in uval row by row (see - ! iluk_copyout, called by mld_diluk_factint), according to the CSR - ! storage format. - ! uirp - integer, dimension(:), input. - ! The indices identifying the first nonzero entry of each row of - ! the U factor above the current row, stored in uval row by row - ! (see iluk_copyout, called by mld_diluk_factint), according to - ! the CSR storage format. - ! uval - real(psb_dpk_), dimension(:), input. - ! The entries of the U factor above the current row (except the - ! diagonal ones), stored according to the CSR format. - ! uplevs - integer, dimension(:), input. - ! The fill levels of the nonzero entries in the part of the - ! U factor above the current row. - ! nidx - integer, output. - ! The number of entries of the array row that have been - ! examined during the elimination step. This will be used - ! by the routine iluk_copyout. - ! idxs - integer, dimension(:), allocatable, input/output. - ! The indices of the entries of the array row that have been - ! examined during the elimination step.This will be used by - ! by the routine iluk_copyout. - ! Note: this argument is intent(inout) and not only intent(out) - ! to retain its allocation, done by this routine. - ! - subroutine iluk_fact(fill_in,i,row,rowlevs,heap,d,uja,uirp,uval,uplevs,nidx,idxs,info) - - use psb_base_mod - - implicit none - - ! Arguments - type(psb_i_heap), intent(inout) :: heap - integer(psb_ipk_), intent(in) :: i, fill_in - integer(psb_ipk_), intent(inout) :: nidx,info - integer(psb_ipk_), intent(inout) :: rowlevs(:) - integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) - integer(psb_ipk_), intent(inout) :: uja(:),uirp(:),uplevs(:) - real(psb_dpk_), intent(inout) :: row(:), uval(:),d(:) - - ! Local variables - integer(psb_ipk_) :: k,j,lrwk,jj,lastk, iret - real(psb_dpk_) :: rwk - - info = psb_success_ - if (.not.allocated(idxs)) then - allocate(idxs(200),stat=info) - if (info /= psb_success_) return - endif - nidx = 0 - lastk = -1 - - ! - ! Do while there are indices to be processed - ! - do - ! Beware: (iret < 0) means that the heap is empty, not an error. - call heap%get_first(k,iret) - if (iret < 0) return - - ! - ! Just in case an index has been put on the heap more than once. - ! - if (k == lastk) cycle - - lastk = k - nidx = nidx + 1 - if (nidx>size(idxs)) then - call psb_realloc(nidx+psb_heap_resize,idxs,info) - if (info /= psb_success_) return - end if - idxs(nidx) = k - - if ((row(k) /= dzero).and.(rowlevs(k) <= fill_in).and.(ki) then - ! - ! Copy the upper part of the row - ! - if (rowlevs(j) <= fill_in) then - l2 = l2 + 1 - if (size(uval) < l2) then - ! - ! Figure out a good reallocation size! - ! - isz = max((l2/i)*m,int(1.2*l2),l2+100) - call psb_realloc(isz,uval,info) - if (info == psb_success_) call psb_realloc(isz,uja,info) - if (info == psb_success_) call psb_realloc(isz,uplevs,info,pad=(m+1)) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - end if - uja(l2) = j - uval(l2) = row(j) - uplevs(l2) = rowlevs(j) - else if (ialg == mld_milu_n_) then - ! - ! MILU(k): add discarded entries to the diagonal one - ! - d(i) = d(i) + row(j) - end if - ! - ! Re-initialize row(j) and rowlevs(j) - ! - row(j) = dzero - rowlevs(j) = -(m+1) - end if - end do - - ! - ! Store the pointers to the first non occupied entry of in - ! lval and uval - ! - lirp(i+1) = l1 + 1 - uirp(i+1) = l2 + 1 - - ! - ! Check the pivot size - ! - if (abs(d(i)) < d_epstol) then - ! - ! Too small pivot: unstable factorization - ! - info = psb_err_pivot_too_small_ - int_err(1) = i - write(ch_err,'(g20.10)') d(i) - call psb_errpush(info,name,i_err=int_err,a_err=ch_err) - goto 9999 - else - ! - ! Compute 1/pivot - ! - d(i) = done/d(i) - end if - - ! - ! Scale the upper part - ! - do j=uirp(i), uirp(i+1)-1 - uval(j) = d(i)*uval(j) - end do - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine iluk_copyout - - -end subroutine mld_diluk_fact diff --git a/mlprec/impl/solver/mld_dilut_fact.f90 b/mlprec/impl/solver/mld_dilut_fact.f90 deleted file mode 100644 index f056812f..00000000 --- a/mlprec/impl/solver/mld_dilut_fact.f90 +++ /dev/null @@ -1,1186 +0,0 @@ -! -! -! MLD2P4 version 2.2 -! MultiLevel Domain Decomposition Parallel Preconditioners Package -! based on PSBLAS (Parallel Sparse BLAS version 3.5) -! -! (C) Copyright 2008-2018 -! -! Salvatore Filippone -! Pasqua D'Ambra -! Daniela di Serafino -! -! 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_dilut_fact.f90 -! -! Subroutine: mld_dilut_fact -! Version: real -! Contains: mld_dilut_factint, ilut_copyin, ilut_fact, ilut_copyout -! -! This routine computes the ILU(k,t) factorization of the diagonal blocks -! of a distributed matrix. This factorization is used to build the 'base -! preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz -! preconditioner) corresponding to a certain level of a multilevel preconditioner. -! -! Details on the above factorization can be found in -! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, -! SIAM, 2003, Chapter 10. -! -! The local matrix is stored into a and blck, as specified in the description -! of the arguments below. The storage format for both the L and U factors is -! CSR. The diagonal of the U factor is stored separately (actually, the -! inverse of the diagonal entries is stored; this is then managed in the -! solve stage associated to the ILU(k,t) factorization). -! -! -! Arguments: -! fill_in - integer, input. -! The fill-in parameter k in ILU(k,t). -! thres - real, input. -! The threshold t, i.e. the drop tolerance, in ILU(k,t). -! a - type(psb_dspmat_type), input. -! The sparse matrix structure containing the local matrix. -! Note that if the 'base' Additive Schwarz preconditioner -! has overlap greater than 0 and the matrix has not been reordered -! (see mld_fact_bld), then a contains only the 'original' local part -! of the distributed matrix, i.e. the rows of the matrix held -! by the calling process according to the initial data distribution. -! l - type(psb_dspmat_type), input/output. -! The L factor in the incomplete factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! u - type(psb_dspmat_type), input/output. -! The U factor (except its diagonal) in the incomplete factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! d - real(psb_dpk_), dimension(:), input/output. -! The inverse of the diagonal entries of the U factor in the incomplete -! factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! info - integer, output. -! Error code. -! blck - type(psb_dspmat_type), input, optional, target. -! The sparse matrix structure containing the remote rows of the -! distributed matrix, that have been retrieved by mld_as_bld -! to build an Additive Schwarz base preconditioner with overlap -! greater than 0. If the overlap is 0 or the matrix has been reordered -! (see mld_fact_bld), then blck does not contain any row. -! -subroutine mld_dilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) - - use psb_base_mod - use mld_d_ilu_fact_mod, mld_protect_name => mld_dilut_fact - - implicit none - - ! Arguments - integer(psb_ipk_), intent(in) :: fill_in - real(psb_dpk_), intent(in) :: thres - integer(psb_ipk_), intent(out) :: info - type(psb_dspmat_type),intent(in) :: a - type(psb_dspmat_type),intent(inout) :: l,u - real(psb_dpk_), intent(inout) :: d(:) - type(psb_dspmat_type),intent(in), optional, target :: blck - integer(psb_ipk_), intent(in), optional :: iscale - ! Local Variables - integer(psb_ipk_) :: l1, l2, m, err_act, iscale_ - - type(psb_dspmat_type), pointer :: blck_ - type(psb_d_csr_sparse_mat) :: ll, uu - real(psb_dpk_) :: scale - character(len=20) :: name, ch_err - - name='mld_dilut_fact' - info = psb_success_ - call psb_erractionsave(err_act) - - if (fill_in < 0) then - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name, & - & i_err=(/ione,fill_in,izero,izero,izero/)) - goto 9999 - end if - ! - ! Point to / allocate memory for the incomplete factorization - ! - if (present(blck)) then - blck_ => blck - else - allocate(blck_,stat=info) - if (info == psb_success_) call blck_%csall(izero,izero,info,ione) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='csall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - if (present(iscale)) then - iscale_ = iscale - else - iscale_ = mld_ilu_scale_none_ - end if - - select case(iscale_) - case(mld_ilu_scale_none_) - scale = sone - case(mld_ilu_scale_maxval_) - scale = max(a%maxval(),blck_%maxval()) - scale = sone/scale - case default - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,i_err=(/ione*9,iscale_,izero,izero,izero/)) - goto 9999 - end select - - m = a%get_nrows() + blck_%get_nrows() - if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& - & (m > size(d)) ) then - write(0,*) 'Wrong allocation status for L,D,U? ',& - & l%get_nrows(),size(d),u%get_nrows() - info = -1 - return - end if - - call l%mv_to(ll) - call u%mv_to(uu) - - ! - ! Compute the ILU(k,t) factorization - ! - call mld_dilut_factint(fill_in,thres,a,blck_,& - & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info,scale) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_dilut_factint' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - ! - ! Store information on the L and U sparse matrices - ! - call l%mv_from(ll) - call l%set_triangle() - call l%set_unit() - call l%set_lower() - call u%mv_from(uu) - call u%set_triangle() - call u%set_unit() - call u%set_upper() - - ! - ! Nullify pointer / deallocate memory - ! - if (present(blck)) then - blck_ => null() - else - call blck_%free() - deallocate(blck_,stat=info) - if(info.ne.0) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - -contains - - ! - ! Subroutine: mld_dilut_factint - ! Version: real - ! Note: internal subroutine of mld_dilut_fact - ! - ! This routine computes the ILU(k,t) factorization of the diagonal blocks of a - ! distributed matrix. This factorization is used to build the 'base - ! preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz - ! preconditioner) corresponding to a certain level of a multilevel preconditioner. - ! - ! The local matrix to be factorized is stored into a and b, as specified in the - ! description of the arguments below. The storage format for both the L and U - ! factors is CSR. The diagonal of the U factor is stored separately (actually, - ! the inverse of the diagonal entries is stored; this is then managed in the - ! solve stage associated to the ILU(k,t) factorization). - ! - ! - ! Arguments: - ! fill_in - integer, input. - ! The fill-in parameter k in ILU(k,t). - ! thres - real, input. - ! The threshold t, i.e. the drop tolerance, in ILU(k,t). - ! m - integer, output. - ! The total number of rows of the local matrix to be factorized, - ! i.e. ma+mb. - ! a - type(psb_dspmat_type), input. - ! The sparse matrix structure containing the local matrix. - ! Note that, if the 'base' Additive Schwarz preconditioner - ! has overlap greater than 0 and the matrix has not been reordered - ! (see mld_fact_bld), then a contains only the 'original' local part - ! of the distributed matrix, i.e. the rows of the matrix held - ! by the calling process according to the initial data distribution. - ! b - type(psb_dspmat_type), input. - ! The sparse matrix structure containing the remote rows of the - ! distributed matrix, that have been retrieved by mld_as_bld - ! to build an Additive Schwarz base preconditioner with overlap - ! greater than 0. If the overlap is 0 or the matrix has been reordered - ! (see mld_fact_bld), then b does not contain any row. - ! d - real(psb_dpk_), dimension(:), output. - ! The inverse of the diagonal entries of the U factor in the incomplete - ! factorization. - ! lval - real(psb_dpk_), dimension(:), input/output. - ! The L factor in the incomplete factorization. - ! lia1 - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the L factor, - ! according to the CSR storage format. - ! lirp - integer, dimension(:), input/output. - ! The indices identifying the first nonzero entry of each row - ! of the L factor in lval, according to the CSR storage format. - ! uval - real(psb_dpk_), dimension(:), input/output. - ! The U factor in the incomplete factorization. - ! The entries of U are stored according to the CSR format. - ! uja - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the U factor, - ! according to the CSR storage format. - ! uirp - integer, dimension(:), input/output. - ! The indices identifying the first nonzero entry of each row - ! of the U factor in uval, according to the CSR storage format. - ! l1 - integer, output - ! The number of nonzero entries in lval. - ! l2 - integer, output - ! The number of nonzero entries in uval. - ! info - integer, output. - ! Error code. - ! - subroutine mld_dilut_factint(fill_in,thres,a,b,& - & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info,scale) - - use psb_base_mod - - implicit none - - ! Arguments - integer(psb_ipk_), intent(in) :: fill_in - real(psb_dpk_), intent(in) :: thres - type(psb_dspmat_type),intent(in) :: a,b - integer(psb_ipk_),intent(inout) :: l1,l2,info - integer(psb_ipk_), allocatable, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) - real(psb_dpk_), allocatable, intent(inout) :: lval(:),uval(:) - real(psb_dpk_), intent(inout) :: d(:) - real(psb_dpk_), intent(in), optional :: scale - - ! Local Variables - integer(psb_ipk_) :: i, ktrw,err_act,nidx,nlw,nup,jmaxup, ma, mb, m - real(psb_dpk_) :: nrmi - real(psb_dpk_) :: weight - integer(psb_ipk_), allocatable :: idxs(:) - real(psb_dpk_), allocatable :: row(:) - type(psb_i_heap) :: heap - type(psb_d_coo_sparse_mat) :: trw - character(len=20), parameter :: name='mld_dilut_factint' - character(len=20) :: ch_err - - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - - - ma = a%get_nrows() - mb = b%get_nrows() - m = ma+mb - - ! - ! Allocate a temporary buffer for the ilut_copyin function - ! - call trw%allocate(izero,izero,ione) - if (info == psb_success_) call psb_ensure_size(m+1,lirp,info) - if (info == psb_success_) call psb_ensure_size(m+1,uirp,info) - - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_sp_all') - goto 9999 - end if - - l1=0 - l2=0 - lirp(1) = 1 - uirp(1) = 1 - - ! - ! Allocate memory to hold the entries of a row - ! - allocate(row(m),stat=info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - - row(:) = czero - weight = sone - if (present(scale)) weight = abs(scale) - ! - ! Cycle over the matrix rows - ! - do i = 1, m - - ! - ! At each iteration of the loop we keep in a heap the column indices - ! affected by the factorization. The heap is initialized and filled - ! in the ilut_copyin function, and updated during the elimination, in - ! the ilut_fact routine. The heap is ideal because at each step we need - ! the lowest index, but we also need to insert new items, and the heap - ! allows to do both in log time. - ! - d(i) = czero - if (i<=ma) then - call ilut_copyin(i,ma,a,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& - & row,heap,ktrw,trw,info) - else - call ilut_copyin(i-ma,mb,b,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& - & row,heap,ktrw,trw,info) - endif - - ! - ! Do an elimination step on current row - ! - if (info == psb_success_) call ilut_fact(thres,i,nrmi,row,heap,& - & d,uja,uirp,uval,nidx,idxs,info) - ! - ! Copy the row into lval/d(i)/uval - ! - if (info == psb_success_) call ilut_copyout(fill_in,thres,i,m,& - & nlw,nup,jmaxup,nrmi,row,nidx,idxs,& - & l1,l2,lja,lirp,lval,d,uja,uirp,uval,info) - - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='Copy/factor loop') - goto 9999 - end if - - end do - ! - ! Adjust diagonal accounting for scale factor - ! - if (weight /= sone) then - d(1:m) = d(1:m)*weight - end if - - ! - ! And we're sone, so deallocate the memory - ! - deallocate(row,idxs,stat=info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Deallocate') - goto 9999 - end if - if (info == psb_success_) call trw%free() - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine mld_dilut_factint - - ! - ! Subroutine: ilut_copyin - ! Version: real - ! Note: internal subroutine of mld_dilut_fact - ! - ! This routine performs the following tasks: - ! - copying a row of a sparse matrix A, stored in the sparse matrix structure a, - ! into the array row; - ! - storing into a heap the column indices of the nonzero entries of the copied - ! row; - ! - computing the column index of the first entry with maximum absolute value - ! in the part of the row belonging to the upper triangle; - ! - computing the 2-norm of the row. - ! The output array row is such that it contains a full row of A, i.e. it contains - ! also the zero entries of the row. This is useful for the elimination step - ! performed by ilut_fact after the call to ilut_copyin (see mld_ilut_factint). - ! - ! If the sparse matrix is in CSR format, a 'straight' copy is performed; - ! otherwise psb_sp_getblk is used to extract a block of rows, which is then - ! copied, row by row, into the array row, through successive calls to - ! ilut_copyin. - ! - ! This routine is used by mld_dilut_factint in the computation of the ILU(k,t) - ! factorization of a local sparse matrix. - ! - ! - ! Arguments: - ! i - integer, input. - ! The local index of the row to be extracted from the - ! sparse matrix structure a. - ! m - integer, input. - ! The number of rows of the local matrix stored into a. - ! a - type(psb_dspmat_type), input. - ! The sparse matrix structure containing the row to be - ! copied. - ! jd - integer, input. - ! The column index of the diagonal entry of the row to be - ! copied. - ! jmin - integer, input. - ! The minimum valid column index. - ! jmax - integer, input. - ! The maximum valid column index. - ! The output matrix will contain a clipped copy taken from - ! a(1:m,jmin:jmax). - ! nlw - integer, output. - ! The number of nonzero entries in the part of the row - ! belonging to the lower triangle of the matrix. - ! nup - integer, output. - ! The number of nonzero entries in the part of the row - ! belonging to the upper triangle of the matrix. - ! jmaxup - integer, output. - ! The column index of the first entry with maximum absolute - ! value in the part of the row belonging to the upper triangle - ! nrmi - real(psb_dpk_), output. - ! The 2-norm of the current row. - ! row - real(psb_dpk_), dimension(:), input/output. - ! In input it is the null vector (see mld_ilut_factint and - ! ilut_copyout). In output it contains the row extracted - ! from the matrix A. It actually contains a full row, i.e. - ! it contains also the zero entries of the row. - ! rowlevs - integer, dimension(:), input/output. - ! In input rowlevs(k) = -(m+1) for k=1,...,m. In output - ! rowlevs(k) = 0 for 1 <= k <= jmax and A(i,k) /= 0, for - ! future use in ilut_fact. - ! heap - type(psb_int_heap), input/output. - ! The heap containing the column indices of the nonzero - ! entries in the array row. - ! Note: this argument is intent(inout) and not only intent(out) - ! to retain its allocation, sone by psb_init_heap inside this - ! routine. - ! ktrw - integer, input/output. - ! The index identifying the last entry taken from the - ! staging buffer trw. See below. - ! trw - type(psb_dspmat_type), input/output. - ! A staging buffer. If the matrix A is not in CSR format, we use - ! the psb_sp_getblk routine and store its output in trw; when we - ! need to call psb_sp_getblk we do it for a block of rows, and then - ! we consume them from trw in successive calls to this routine, - ! until we empty the buffer. Thus we will make a call to psb_sp_getblk - ! every nrb calls to copyin. If A is in CSR format it is unused. - ! - subroutine ilut_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,& - & nrmi,weight,row,heap,ktrw,trw,info) - use psb_base_mod - implicit none - type(psb_dspmat_type), intent(in) :: a - type(psb_d_coo_sparse_mat), intent(inout) :: trw - integer(psb_ipk_), intent(in) :: i, m,jmin,jmax,jd - integer(psb_ipk_), intent(inout) :: ktrw,nlw,nup,jmaxup,info - real(psb_dpk_), intent(inout) :: nrmi - real(psb_dpk_), intent(inout) :: row(:) - real(psb_dpk_), intent(in) :: weight - type(psb_i_heap), intent(inout) :: heap - - integer(psb_ipk_) :: k,j,irb,kin,nz - integer(psb_ipk_), parameter :: nrb=40 - real(psb_dpk_) :: dmaxup - real(psb_dpk_), external :: dnrm2 - character(len=20), parameter :: name='mld_dilut_factint' - - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - - call heap%init(info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_init_heap') - goto 9999 - end if - - ! - ! nrmi is the norm of the current sparse row (for the time being, - ! we use the 2-norm). - ! NOTE: the 2-norm below includes also elements that are outside - ! [jmin:jmax] strictly. Is this really important? TO BE CHECKED. - ! - - nlw = 0 - nup = 0 - jmaxup = 0 - dmaxup = szero - nrmi = szero - - select type (aa=> a%a) - type is (psb_d_csr_sparse_mat) - ! - ! Take a fast shortcut if the matrix is stored in CSR format - ! - - do j = aa%irp(i), aa%irp(i+1) - 1 - k = aa%ja(j) - if ((jmin<=k).and.(k<=jmax)) then - row(k) = aa%val(j)*weight - call heap%insert(k,info) - if (info /= psb_success_) exit - if (kjd) then - nup = nup + 1 - if (abs(row(k))>dmaxup) then - jmaxup = k - dmaxup = abs(row(k)) - end if - end if - end if - end do - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_insert_heap') - goto 9999 - end if - - nz = aa%irp(i+1) - aa%irp(i) - nrmi = weight*dnrm2(nz,aa%val(aa%irp(i)),ione) - - - class default - - ! - ! Otherwise use psb_sp_getblk, slower but able (in principle) of - ! handling any format. In this case, a block of rows is extracted - ! instead of a single row, for performance reasons, and these - ! rows are copied one by one into the array row, through successive - ! calls to ilut_copyin. - ! - - if ((mod(i,nrb) == 1).or.(nrb == 1)) then - irb = min(m-i+1,nrb) - call aa%csget(i,i+irb-1,trw,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_sp_getblk') - goto 9999 - end if - ktrw=1 - end if - - kin = ktrw - nz = trw%get_nzeros() - do - if (ktrw > nz) exit - if (trw%ia(ktrw) > i) exit - k = trw%ja(ktrw) - if ((jmin<=k).and.(k<=jmax)) then - row(k) = trw%val(ktrw)*weight - call heap%insert(k,info) - if (info /= psb_success_) exit - if (kjd) then - nup = nup + 1 - if (abs(row(k))>dmaxup) then - jmaxup = k - dmaxup = abs(row(k)) - end if - end if - end if - ktrw = ktrw + 1 - enddo - nz = ktrw - kin - nrmi = weight*dnrm2(nz,trw%val(kin),ione) - end select - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine ilut_copyin - - ! - ! Subroutine: ilut_fact - ! Version: real - ! Note: internal subroutine of mld_dilut_fact - ! - ! This routine does an elimination step of the ILU(k,t) factorization on a single - ! matrix row (see the calling routine mld_ilut_factint). Actually, only the dropping - ! rule based on the threshold is applied here. The dropping rule based on the - ! fill-in is applied by ilut_copyout. - ! - ! The routine is used by mld_dilut_factint in the computation of the ILU(k,t) - ! factorization of a local sparse matrix. - ! - ! - ! Arguments - ! thres - real, input. - ! The threshold t, i.e. the drop tolerance, in ILU(k,t). - ! i - integer, input. - ! The local index of the row to which the factorization is applied. - ! nrmi - real(psb_dpk_), input. - ! The 2-norm of the row to which the elimination step has to be - ! applied. - ! row - real(psb_dpk_), dimension(:), input/output. - ! In input it contains the row to which the elimination step - ! has to be applied. In output it contains the row after the - ! elimination step. It actually contains a full row, i.e. - ! it contains also the zero entries of the row. - ! heap - type(psb_i_heap), input/output. - ! The heap containing the column indices of the nonzero entries - ! in the processed row. In input it contains the indices concerning - ! the row before the elimination step, while in output it contains - ! the previous indices plus the ones corresponding to transformed - ! entries in the 'upper part' that have not been dropped. - ! d - real(psb_dpk_), input. - ! The inverse of the diagonal entries of the part of the U factor - ! above the current row (see ilut_copyout). - ! uja - integer, dimension(:), input. - ! The column indices of the nonzero entries of the part of the U - ! factor above the current row, stored in uval row by row (see - ! ilut_copyout, called by mld_dilut_factint), according to the CSR - ! storage format. - ! uirp - integer, dimension(:), input. - ! The indices identifying the first nonzero entry of each row of - ! the U factor above the current row, stored in uval row by row - ! (see ilut_copyout, called by mld_dilut_factint), according to - ! the CSR storage format. - ! uval - real(psb_dpk_), dimension(:), input. - ! The entries of the U factor above the current row (except the - ! diagonal ones), stored according to the CSR format. - ! nidx - integer, output. - ! The number of entries of the array row that have been - ! examined during the elimination step. This will be used - ! by the routine ilut_copyout. - ! idxs - integer, dimension(:), allocatable, input/output. - ! The indices of the entries of the array row that have been - ! examined during the elimination step.This will be used by - ! by the routine ilut_copyout. - ! Note: this argument is intent(inout) and not only intent(out) - ! to retain its allocation, sone by this routine. - ! - subroutine ilut_fact(thres,i,nrmi,row,heap,d,uja,uirp,uval,nidx,idxs,info) - - use psb_base_mod - - implicit none - - ! Arguments - type(psb_i_heap), intent(inout) :: heap - integer(psb_ipk_), intent(in) :: i - integer(psb_ipk_), intent(inout) :: nidx,info - real(psb_dpk_), intent(in) :: thres,nrmi - integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) - integer(psb_ipk_), intent(inout) :: uja(:),uirp(:) - real(psb_dpk_), intent(inout) :: row(:), uval(:),d(:) - - ! Local Variables - integer(psb_ipk_) :: k,j,jj,lastk,iret - real(psb_dpk_) :: rwk - - info = psb_success_ - call psb_ensure_size(200*ione,idxs,info) - if (info /= psb_success_) return - nidx = 0 - lastk = -1 - ! - ! Do while there are indices to be processed - ! - do - - call heap%get_first(k,iret) - if (iret < 0) exit - - ! - ! An index may have been put on the heap more than once. - ! - if (k == lastk) cycle - - lastk = k - lowert: if (k nidx) exit - if (idxs(idxp) >= i) exit - widx = idxs(idxp) - witem = row(widx) - ! - ! Dropping rule based on the 2-norm - ! - if (abs(witem) < thres*nrmi) cycle - - nz = nz + 1 - xw(nz) = witem - xwid(nz) = widx - call heap%insert(witem,widx,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_insert_heap') - goto 9999 - end if - end do - - ! - ! Now we have to take out the first nlw+fill_in entries - ! - if (nz <= nlw+fill_in) then - ! - ! Just copy everything from xw, and it is already ordered - ! - else - nz = nlw+fill_in - do k=1,nz - call heap%get_first(witem,widx,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_heap_get_first') - goto 9999 - end if - - xw(k) = witem - xwid(k) = widx - end do - end if - - ! - ! Now put things back into ascending column order - ! - call psb_msort(xwid(1:nz),indx(1:nz),dir=psb_sort_up_) - - ! - ! Copy out the lower part of the row - ! - do k=1,nz - l1 = l1 + 1 - if (size(lval) < l1) then - ! - ! Figure out a good reallocation size! - ! - isz = (max((l1/i)*m,int(1.2*l1),l1+100)) - call psb_realloc(isz,lval,info) - if (info == psb_success_) call psb_realloc(isz,lja,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - end if - lja(l1) = xwid(k) - lval(l1) = xw(indx(k)) - end do - - ! - ! Make sure idxp points to the diagonal entry - ! - if (idxp <= size(idxs)) then - if (idxs(idxp) < i) then - do - idxp = idxp + 1 - if (idxp > nidx) exit - if (idxs(idxp) >= i) exit - end do - end if - end if - if (idxp > size(idxs)) then -!!$ write(0,*) 'Warning: missing diagonal element in the row ' - else - if (idxs(idxp) > i) then -!!$ write(0,*) 'Warning: missing diagonal element in the row ' - else if (idxs(idxp) /= i) then -!!$ write(0,*) 'Warning: impossible error: diagonal has vanished' - else - ! - ! Copy the diagonal entry - ! - widx = idxs(idxp) - witem = row(widx) - d(i) = witem - if (abs(d(i)) < d_epstol) then - ! - ! Too small pivot: unstable factorization - ! - info = psb_err_pivot_too_small_ - int_err(1) = i - write(ch_err,'(g20.10)') d(i) - call psb_errpush(info,name,i_err=int_err,a_err=ch_err) - goto 9999 - else - ! - ! Compute 1/pivot - ! - d(i) = cone/d(i) - end if - end if - end if - - ! - ! Now the upper part - ! - - call heap%init(info,dir=psb_asort_down_) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_init_heap') - goto 9999 - end if - - nz = 0 - do - - idxp = idxp + 1 - if (idxp > nidx) exit - widx = idxs(idxp) - if (widx <= i) then -!!$ write(0,*) 'Warning: lower triangle in upper copy',widx,i,idxp,idxs(idxp) - cycle - end if - if (widx > m) then -!!$ write(0,*) 'Warning: impossible value',widx,i,idxp,idxs(idxp) - cycle - end if - witem = row(widx) - ! - ! Dropping rule based on the 2-norm. But keep the jmaxup-th entry anyway. - ! - if ((widx /= jmaxup) .and. (abs(witem) < thres*nrmi)) then - cycle - end if - - nz = nz + 1 - xw(nz) = witem - xwid(nz) = widx - call heap%insert(witem,widx,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_insert_heap') - goto 9999 - end if - - end do - - ! - ! Now we have to take out the first nup-fill_in entries. But make sure - ! we include entry jmaxup. - ! - if (nz <= nup+fill_in) then - ! - ! Just copy everything from xw - ! - fndmaxup=.true. - else - fndmaxup = .false. - nz = nup+fill_in - do k=1,nz - call heap%get_first(witem,widx,info) - xw(k) = witem - xwid(k) = widx - if (widx == jmaxup) fndmaxup=.true. - end do - end if - if ((i= 0 - call mld_ilut_fact(sv%fill_in,sv%thresh,& + call psb_ilut_fact(sv%fill_in,sv%thresh,& & a, sv%l,sv%u,sv%d,info,blck=b) end select if(info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='mld_ilut_fact' + ch_err='psb_ilut_fact' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - case(mld_ilu_n_,mld_milu_n_) + case(psb_ilu_n_,psb_milu_n_) ! ! ILU(k) and MILU(k) ! @@ -137,24 +137,24 @@ subroutine mld_s_ilu_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) ! Fill-in 0 ! Separate implementation of ILU(0) for better performance. ! There seems to be a problem with the separate implementation of MILU(0), - ! contained into mld_ilu0_fact. This must be investigated. For the time being, + ! contained into psb_ilu0_fact. This must be investigated. For the time being, ! resort to the implementation of MILU(k) with k=0. - if (sv%fact_type == mld_ilu_n_) then - call mld_ilu0_fact(sv%fact_type,a,sv%l,sv%u,& + if (sv%fact_type == psb_ilu_n_) then + call psb_ilu0_fact(sv%fact_type,a,sv%l,sv%u,& & sv%d,info,blck=b) else - call mld_iluk_fact(sv%fill_in,sv%fact_type,& + call psb_iluk_fact(sv%fill_in,sv%fact_type,& & a,sv%l,sv%u,sv%d,info,blck=b) endif case(1:) ! Fill-in >= 1 ! The same routine implements both ILU(k) and MILU(k) - call mld_iluk_fact(sv%fill_in,sv%fact_type,& + call psb_iluk_fact(sv%fill_in,sv%fact_type,& & a,sv%l,sv%u,sv%d,info,blck=b) end select if (info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='mld_iluk_fact' + ch_err='psb_iluk_fact' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if diff --git a/mlprec/impl/solver/mld_silu0_fact.f90 b/mlprec/impl/solver/mld_silu0_fact.f90 deleted file mode 100644 index f539a4db..00000000 --- a/mlprec/impl/solver/mld_silu0_fact.f90 +++ /dev/null @@ -1,666 +0,0 @@ -! -! -! MLD2P4 version 2.2 -! MultiLevel Domain Decomposition Parallel Preconditioners Package -! based on PSBLAS (Parallel Sparse BLAS version 3.5) -! -! (C) Copyright 2008-2018 -! -! Salvatore Filippone -! Pasqua D'Ambra -! Daniela di Serafino -! -! 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_silu0_fact.f90 -! -! Subroutine: mld_silu0_fact -! Version: real -! Contains: mld_silu0_factint, ilu_copyin -! -! This routine computes either the ILU(0) or the MILU(0) factorization of -! the diagonal blocks of a distributed matrix. These factorizations are used -! to build the 'base preconditioner' (block-Jacobi preconditioner/solver, -! Additive Schwarz preconditioner) corresponding to a given level of a -! multilevel preconditioner. -! -! Details on the above factorizations can be found in -! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, -! SIAM, 2003, Chapter 10. -! -! The local matrix is stored into a and blck, as specified in the description -! of the arguments below. The storage format for both the L and U factors is CSR. -! The diagonal of the U factor is stored separately (actually, the inverse of the -! diagonal entries is stored; this is then managed in the solve stage associated -! to the ILU(0)/MILU(0) factorization). -! -! The routine copies and factors "on the fly" from a and blck into l (L factor), -! u (U factor, except its diagonal) and d (diagonal of U). -! -! This implementation of ILU(0)/MILU(0) is faster than the implementation in -! mld_ziluk_fct (the latter routine performs the more general ILU(k)/MILU(k)). -! -! -! Arguments: -! ialg - integer, input. -! The type of incomplete factorization to be performed. -! The MILU(0) factorization is computed if ialg = 2 (= mld_milu_n_); -! the ILU(0) factorization otherwise. -! a - type(psb_sspmat_type), input. -! The sparse matrix structure containing the local matrix. -! Note that if the 'base' Additive Schwarz preconditioner -! has overlap greater than 0 and the matrix has not been reordered -! (see mld_as_bld), then a contains only the 'original' local part -! of the distributed matrix, i.e. the rows of the matrix held -! by the calling process according to the initial data distribution. -! l - type(psb_sspmat_type), input/output. -! The L factor in the incomplete factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! u - type(psb_sspmat_type), input/output. -! The U factor (except its diagonal) in the incomplete factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! d - real(psb_spk_), dimension(:), input/output. -! The inverse of the diagonal entries of the U factor in the incomplete -! factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! info - integer, output. -! Error code. -! blck - type(psb_sspmat_type), input, optional, target. -! The sparse matrix structure containing the remote rows of the -! distributed matrix, that have been retrieved by mld_as_bld -! to build an Additive Schwarz base preconditioner with overlap -! greater than 0. If the overlap is 0 or the matrix has been reordered -! (see mld_fact_bld), then blck is empty. -! -subroutine mld_silu0_fact(ialg,a,l,u,d,info,blck, upd) - - use psb_base_mod - use mld_s_ilu_fact_mod, mld_protect_name => mld_silu0_fact - - implicit none - - ! Arguments - integer(psb_ipk_), intent(in) :: ialg - type(psb_sspmat_type),intent(in) :: a - type(psb_sspmat_type),intent(inout) :: l,u - real(psb_spk_), intent(inout) :: d(:) - integer(psb_ipk_), intent(out) :: info - type(psb_sspmat_type),intent(in), optional, target :: blck - character, intent(in), optional :: upd - - ! Local variables - integer(psb_ipk_) :: l1, l2, m, err_act - type(psb_sspmat_type), pointer :: blck_ - type(psb_s_csr_sparse_mat) :: ll, uu - character :: upd_ - character(len=20) :: name, ch_err - - name='mld_silu0_fact' - info = psb_success_ - call psb_erractionsave(err_act) - - ! - ! Point to / allocate memory for the incomplete factorization - ! - if (present(blck)) then - blck_ => blck - else - allocate(blck_,stat=info) - if (info == psb_success_) call blck_%csall(izero,izero,info,ione) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='csall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - if (present(upd)) then - upd_ = psb_toupper(upd) - else - upd_ = 'F' - end if - - m = a%get_nrows() + blck_%get_nrows() - if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& - & (m > size(d)) ) then - write(0,*) 'Wrong allocation status for L,D,U? ',& - & l%get_nrows(),size(d),u%get_nrows() - info = -1 - return - end if - - call l%mv_to(ll) - call u%mv_to(uu) - ! - ! Compute the ILU(0) or the MILU(0) factorization, depending on ialg - ! - call mld_silu0_factint(ialg,a,blck_,& - & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,upd_,info) - if(info.ne.0) then - info=psb_err_from_subroutine_ - ch_err='mld_silu0_factint' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - ! - ! Store information on the L and U sparse matrices - ! - call l%mv_from(ll) - call l%set_triangle() - call l%set_unit() - call l%set_lower() - call u%mv_from(uu) - call u%set_triangle() - call u%set_unit() - call u%set_upper() - - ! - ! Nullify pointer / deallocate memory - ! - if (present(blck)) then - blck_ => null() - else - call blck_%free() - if(info.ne.0) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - deallocate(blck_) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -contains - - ! - ! Subroutine: mld_silu0_factint - ! Version: real - ! Note: internal subroutine of mld_silu0_fact. - ! - ! This routine computes either the ILU(0) or the MILU(0) factorization of the - ! diagonal blocks of a distributed matrix. - ! These factorizations are used to build the 'base preconditioner' - ! (block-Jacobi preconditioner/solver, Additive Schwarz - ! preconditioner) corresponding to a given level of a multilevel preconditioner. - ! - ! The local matrix is stored into a and b, as specified in the - ! description of the arguments below. The storage format for both the L and U - ! factors is CSR. The diagonal of the U factor is stored separately (actually, - ! the inverse of the diagonal entries is stored; this is then managed in the - ! solve stage associated to the ILU(0)/MILU(0) factorization). - ! - ! The routine copies and factors "on the fly" from the sparse matrix structures a - ! and b into the arrays lval, uval, d (L, U without its diagonal, diagonal of U). - ! - ! - ! Arguments: - ! ialg - integer, input. - ! The type of incomplete factorization to be performed. - ! The ILU(0) factorization is computed if ialg = 1 (= mld_ilu_n_), - ! the MILU(0) one if ialg = 2 (= mld_milu_n_); other values - ! are not allowed. - ! m - integer, output. - ! The total number of rows of the local matrix to be factorized, - ! i.e. ma+mb. - ! ma - integer, input - ! The number of rows of the local submatrix stored into a. - ! a - type(psb_sspmat_type), input. - ! The sparse matrix structure containing the local matrix. - ! Note that, if the 'base' Additive Schwarz preconditioner - ! has overlap greater than 0 and the matrix has not been reordered - ! (see mld_fact_bld), then a contains only the 'original' local part - ! of the distributed matrix, i.e. the rows of the matrix held - ! by the calling process according to the initial data distribution. - ! mb - integer, input. - ! The number of rows of the local submatrix stored into b. - ! b - type(psb_sspmat_type), input. - ! The sparse matrix structure containing the remote rows of the - ! distributed matrix, that have been retrieved by mld_as_bld - ! to build an Additive Schwarz base preconditioner with overlap - ! greater than 0. If the overlap is 0 or the matrix has been - ! reordered (see mld_fact_bld), then b does not contain any row. - ! d - real(psb_spk_), dimension(:), output. - ! The inverse of the diagonal entries of the U factor in the - ! incomplete factorization. - ! lval - real(psb_spk_), dimension(:), input/output. - ! The entries of U are stored according to the CSR format. - ! The L factor in the incomplete factorization. - ! lja - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the L factor, - ! according to the CSR storage format. - ! lirp - integer, dimension(:), input/output. - ! The indices identifying the first nonzero entry of each row - ! of the L factor in lval, according to the CSR storage format. - ! uval - real(psb_spk_), dimension(:), input/output. - ! The U factor in the incomplete factorization. - ! The entries of U are stored according to the CSR format. - ! uja - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the U factor, - ! according to the CSR storage format. - ! uirp - integer, dimension(:), input/output. - ! The indices identifying the first nonzero entry of each row - ! of the U factor in uval, according to the CSR storage format. - ! l1 - integer, output. - ! The number of nonzero entries in lval. - ! l2 - integer, output. - ! The number of nonzero entries in uval. - ! info - integer, output. - ! Error code. - ! - subroutine mld_silu0_factint(ialg,a,b,& - & d,lval,lja,lirp,uval,uja,uirp,l1,l2,upd,info) - - implicit none - - ! Arguments - integer(psb_ipk_), intent(in) :: ialg - type(psb_sspmat_type),intent(in) :: a,b - integer(psb_ipk_),intent(inout) :: l1,l2,info - integer(psb_ipk_), intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) - real(psb_spk_), intent(inout) :: lval(:),uval(:),d(:) - character, intent(in) :: upd - - ! Local variables - integer(psb_ipk_) :: i,j,k,l,low1,low2,kk,jj,ll, ktrw,err_act, m - integer(psb_ipk_) :: ma,mb - real(psb_spk_) :: dia,temp - integer(psb_ipk_), parameter :: nrb=16 - type(psb_s_coo_sparse_mat) :: trw - integer(psb_ipk_) :: int_err(5) - character(len=20) :: name, ch_err - - name='mld_silu0_factint' - info=psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - ma = a%get_nrows() - mb = b%get_nrows() - - select case(ialg) - case(mld_ilu_n_,mld_milu_n_) - ! Ok - case default - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,& - & i_err=(/ione,ialg,izero,izero,izero/)) - goto 9999 - end select - - call trw%allocate(izero,izero,ione) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_all' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - m = ma+mb - - if (psb_toupper(upd) == 'F' ) then - lirp(1) = 1 - uirp(1) = 1 - l1 = 0 - l2 = 0 - - ! - ! Cycle over the matrix rows - ! - do i = 1, m - - d(i) = szero - - if (i <= ma) then - ! - ! Copy the i-th local row of the matrix, stored in a, - ! into lval/d(i)/uval - ! - call ilu_copyin(i,ma,a,i,ione,m,l1,lja,lval,& - & d(i),l2,uja,uval,ktrw,trw,upd) - else - ! - ! Copy the i-th local row of the matrix, stored in b - ! (as (i-ma)-th row), into lval/d(i)/uval - ! - call ilu_copyin(i-ma,mb,b,i,ione,m,l1,lja,lval,& - & d(i),l2,uja,uval,ktrw,trw,upd) - endif - - lirp(i+1) = l1 + 1 - uirp(i+1) = l2 + 1 - - dia = d(i) - do kk = lirp(i), lirp(i+1) - 1 - ! - ! Compute entry l(i,k) (lower factor L) of the incomplete - ! factorization - ! - temp = lval(kk) - k = lja(kk) - lval(kk) = temp*d(k) - ! - ! Update the rest of row i (lower and upper factors L and U) - ! using l(i,k) - ! - low1 = kk + 1 - low2 = uirp(i) - ! - updateloop: do jj = uirp(k), uirp(k+1) - 1 - ! - j = uja(jj) - ! - if (j < i) then - ! - ! search l(i,*) (i-th row of L) for a matching index j - ! - do ll = low1, lirp(i+1) - 1 - l = lja(ll) - if (l > j) then - low1 = ll - exit - else if (l == j) then - lval(ll) = lval(ll) - temp*uval(jj) - low1 = ll + 1 - cycle updateloop - end if - enddo - - else if (j == i) then - ! - ! j=i: update the diagonal - ! - dia = dia - temp*uval(jj) - cycle updateloop - ! - else if (j > i) then - ! - ! search u(i,*) (i-th row of U) for a matching index j - ! - do ll = low2, uirp(i+1) - 1 - l = uja(ll) - if (l > j) then - low2 = ll - exit - else if (l == j) then - uval(ll) = uval(ll) - temp*uval(jj) - low2 = ll + 1 - cycle updateloop - end if - enddo - end if - ! - ! If we get here we missed the cycle updateloop, which means - ! that this entry does not match; thus we accumulate on the - ! diagonal for MILU(0). - ! - if (ialg == mld_milu_n_) then - dia = dia - temp*uval(jj) - end if - enddo updateloop - enddo - ! - ! Check the pivot size - ! - if (abs(dia) < s_epstol) then - ! - ! Too small pivot: unstable factorization - ! - info = psb_err_pivot_too_small_ - int_err(1) = i - write(ch_err,'(g20.10)') abs(dia) - call psb_errpush(info,name,i_err=int_err,a_err=ch_err) - goto 9999 - else - ! - ! Compute 1/pivot - ! - dia = sone/dia - end if - d(i) = dia - ! - ! Scale row i of upper triangle - ! - do kk = uirp(i), uirp(i+1) - 1 - uval(kk) = uval(kk)*dia - enddo - enddo - else - write(0,*) 'Update not implemented ' - info = 31 - call psb_errpush(info,name,& - & i_err=(/ione*13,izero,izero,izero,izero/),a_err=upd) - goto 9999 - - end if - - call trw%free() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine mld_silu0_factint - - ! - ! Subroutine: ilu_copyin - ! Version: real - ! Note: internal subroutine of mld_silu0_fact - ! - ! This routine copies a row of a sparse matrix A, stored in the psb_sspmat_type - ! data structure a, into the arrays lval and uval and into the scalar variable - ! dia, corresponding to the lower and upper triangles of A and to the diagonal - ! entry of the row, respectively. The entries in lval and uval are stored - ! according to the CSR format; the corresponding column indices are stored in - ! the arrays lja and uja. - ! - ! If the sparse matrix is in CSR format, a 'straight' copy is performed; - ! otherwise psb_sp_getblk is used to extract a block of rows, which is then - ! copied into lval, dia, uval row by row, through successive calls to - ! ilu_copyin. - ! - ! The routine is used by mld_silu0_factint in the computation of the ILU(0)/MILU(0) - ! factorization of a local sparse matrix. - ! - ! TODO: modify the routine to allow copying into output L and U that are - ! already filled with indices; this would allow computing an ILU(k) pattern, - ! then use the ILU(0) internal for subsequent calls with the same pattern. - ! - ! Arguments: - ! i - integer, input. - ! The local index of the row to be extracted from the - ! sparse matrix structure a. - ! m - integer, input. - ! The number of rows of the local matrix stored into a. - ! a - type(psb_sspmat_type), input. - ! The sparse matrix structure containing the row to be copied. - ! jd - integer, input. - ! The column index of the diagonal entry of the row to be - ! copied. - ! jmin - integer, input. - ! Minimum valid column index. - ! jmax - integer, input. - ! Maximum valid column index. - ! The output matrix will contain a clipped copy taken from - ! a(1:m,jmin:jmax). - ! l1 - integer, input/output. - ! Pointer to the last occupied entry of lval. - ! lja - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the lower triangle - ! copied in lval row by row (see mld_silu0_factint), according - ! to the CSR storage format. - ! lval - real(psb_spk_), dimension(:), input/output. - ! The array where the entries of the row corresponding to the - ! lower triangle are copied. - ! dia - real(psb_spk_), output. - ! The diagonal entry of the copied row. - ! l2 - integer, input/output. - ! Pointer to the last occupied entry of uval. - ! uja - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the upper triangle - ! copied in uval row by row (see mld_silu0_factint), according - ! to the CSR storage format. - ! uval - real(psb_spk_), dimension(:), input/output. - ! The array where the entries of the row corresponding to the - ! upper triangle are copied. - ! ktrw - integer, input/output. - ! The index identifying the last entry taken from the - ! staging buffer trw. See below. - ! trw - type(psb_sspmat_type), input/output. - ! A staging buffer. If the matrix A is not in CSR format, we use - ! the psb_sp_getblk routine and store its output in trw; when we - ! need to call psb_sp_getblk we do it for a block of rows, and then - ! we consume them from trw in successive calls to this routine, - ! until we empty the buffer. Thus we will make a call to psb_sp_getblk - ! every nrb calls to copyin. If A is in CSR format it is unused. - ! - subroutine ilu_copyin(i,m,a,jd,jmin,jmax,l1,lja,lval,& - & dia,l2,uja,uval,ktrw,trw,upd) - - use psb_base_mod - - implicit none - - ! Arguments - type(psb_sspmat_type), intent(in) :: a - type(psb_s_coo_sparse_mat), intent(inout) :: trw - integer(psb_ipk_), intent(in) :: i,m,jd,jmin,jmax - integer(psb_ipk_), intent(inout) :: ktrw,l1,l2 - integer(psb_ipk_), intent(inout) :: lja(:), uja(:) - real(psb_spk_), intent(inout) :: lval(:), uval(:), dia - character, intent(in) :: upd - ! Local variables - integer(psb_ipk_) :: k,j,info,irb, nz - integer(psb_ipk_), parameter :: nrb=40 - character(len=20), parameter :: name='ilu_copyin' - character(len=20) :: ch_err - - info=psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - if (psb_toupper(upd) == 'F') then - - select type(aa => a%a) - type is (psb_s_csr_sparse_mat) - - ! - ! Take a fast shortcut if the matrix is stored in CSR format - ! - - do j = aa%irp(i), aa%irp(i+1) - 1 - k = aa%ja(j) - ! write(0,*)'KKKKK',k - if ((k < jd).and.(k >= jmin)) then - l1 = l1 + 1 - lval(l1) = aa%val(j) - lja(l1) = k - else if (k == jd) then - dia = aa%val(j) - else if ((k > jd).and.(k <= jmax)) then - l2 = l2 + 1 - uval(l2) = aa%val(j) - uja(l2) = k - end if - enddo - - class default - - ! - ! Otherwise use psb_sp_getblk, slower but able (in principle) of - ! handling any format. In this case, a block of rows is extracted - ! instead of a single row, for performance reasons, and these - ! rows are copied one by one into lval, dia, uval, through - ! successive calls to ilu_copyin. - ! - - if ((mod(i,nrb) == 1).or.(nrb == 1)) then - irb = min(m-i+1,nrb) - call aa%csget(i,i+irb-1,trw,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='csget' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - ktrw=1 - end if - - nz = trw%get_nzeros() - do - if (ktrw > nz) exit - if (trw%ia(ktrw) > i) exit - k = trw%ja(ktrw) - if ((k < jd).and.(k >= jmin)) then - l1 = l1 + 1 - lval(l1) = trw%val(ktrw) - lja(l1) = k - else if (k == jd) then - dia = trw%val(ktrw) - else if ((k > jd).and.(k <= jmax)) then - l2 = l2 + 1 - uval(l2) = trw%val(ktrw) - uja(l2) = k - end if - ktrw = ktrw + 1 - enddo - - end select - - else - - write(0,*) 'Update not implemented ' - info = 31 - call psb_errpush(info,name,& - & i_err=(/ione*13,izero,izero,izero,izero/),a_err=upd) - goto 9999 - - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine ilu_copyin - -end subroutine mld_silu0_fact diff --git a/mlprec/impl/solver/mld_siluk_fact.f90 b/mlprec/impl/solver/mld_siluk_fact.f90 deleted file mode 100644 index fe7e18d6..00000000 --- a/mlprec/impl/solver/mld_siluk_fact.f90 +++ /dev/null @@ -1,969 +0,0 @@ -! -! -! MLD2P4 version 2.2 -! MultiLevel Domain Decomposition Parallel Preconditioners Package -! based on PSBLAS (Parallel Sparse BLAS version 3.5) -! -! (C) Copyright 2008-2018 -! -! Salvatore Filippone -! Pasqua D'Ambra -! Daniela di Serafino -! -! 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_siluk_fact.f90 -! -! Subroutine: mld_siluk_fact -! Version: real -! Contains: mld_siluk_factint, iluk_copyin, iluk_fact, iluk_copyout. -! -! This routine computes either the ILU(k) or the MILU(k) factorization of the -! diagonal blocks of a distributed matrix. These factorizations are used to -! build the 'base preconditioner' (block-Jacobi preconditioner/solver, -! Additive Schwarz preconditioner) corresponding to a certain level of a -! multilevel preconditioner. -! -! Details on the above factorizations can be found in -! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, -! SIAM, 2003, Chapter 10. -! -! The local matrix is stored into a and blck, as specified in -! the description of the arguments below. The storage format for both the L and -! U factors is CSR. The diagonal of the U factor is stored separately (actually, -! the inverse of the diagonal entries is stored; this is then managed in the solve -! stage associated to the ILU(k)/MILU(k) factorization). -! -! -! Arguments: -! fill_in - integer, input. -! The fill-in level k in ILU(k)/MILU(k). -! ialg - integer, input. -! The type of incomplete factorization to be performed. -! The ILU(k) factorization is computed if ialg = 1 (= mld_ilu_n_); -! the MILU(k) one if ialg = 2 (= mld_milu_n_); other values are -! not allowed. -! a - type(psb_sspmat_type), input. -! The sparse matrix structure containing the local matrix. -! Note that if the 'base' Additive Schwarz preconditioner -! has overlap greater than 0 and the matrix has not been reordered -! (see mld_fact_bld), then a contains only the 'original' local part -! of the distributed matrix, i.e. the rows of the matrix held -! by the calling process according to the initial data distribution. -! l - type(psb_sspmat_type), input/output. -! The L factor in the incomplete factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! u - type(psb_sspmat_type), input/output. -! The U factor (except its diagonal) in the incomplete factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! d - real(psb_spk_), dimension(:), input/output. -! The inverse of the diagonal entries of the U factor in the incomplete -! factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! info - integer, output. -! Error code. -! blck - type(psb_sspmat_type), input, optional, target. -! The sparse matrix structure containing the remote rows of the -! distributed matrix, that have been retrieved by mld_as_bld -! to build an Additive Schwarz base preconditioner with overlap -! greater than 0. If the overlap is 0 or the matrix has been reordered -! (see mld_fact_bld), then blck does not contain any row. -! -subroutine mld_siluk_fact(fill_in,ialg,a,l,u,d,info,blck) - - use psb_base_mod - use mld_s_ilu_fact_mod, mld_protect_name => mld_siluk_fact - - implicit none - - ! Arguments - integer(psb_ipk_), intent(in) :: fill_in, ialg - integer(psb_ipk_), intent(out) :: info - type(psb_sspmat_type),intent(in) :: a - type(psb_sspmat_type),intent(inout) :: l,u - type(psb_sspmat_type),intent(in), optional, target :: blck - real(psb_spk_), intent(inout) :: d(:) - ! Local Variables - integer(psb_ipk_) :: l1, l2, m, err_act - - type(psb_sspmat_type), pointer :: blck_ - type(psb_s_csr_sparse_mat) :: ll, uu - character(len=20) :: name, ch_err - - name='mld_siluk_fact' - info = psb_success_ - call psb_erractionsave(err_act) - - ! - ! Point to / allocate memory for the incomplete factorization - ! - if (present(blck)) then - blck_ => blck - else - allocate(blck_,stat=info) - if (info == psb_success_) call blck_%csall(izero,izero,info,ione) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='csall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - - m = a%get_nrows() + blck_%get_nrows() - if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& - & (m > size(d)) ) then - write(0,*) 'Wrong allocation status for L,D,U? ',& - & l%get_nrows(),size(d),u%get_nrows() - info = -1 - return - end if - - call l%mv_to(ll) - call u%mv_to(uu) - - ! - ! Compute the ILU(k) or the MILU(k) factorization, depending on ialg - ! - call mld_siluk_factint(fill_in,ialg,a,blck_,& - & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_siluk_factint' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - ! - ! Store information on the L and U sparse matrices - ! - call l%mv_from(ll) - call l%set_triangle() - call l%set_unit() - call l%set_lower() - call u%mv_from(uu) - call u%set_triangle() - call u%set_unit() - call u%set_upper() - - ! - ! Nullify pointer / deallocate memory - ! - if (present(blck)) then - blck_ => null() - else - call blck_%free() - deallocate(blck_,stat=info) - if(info.ne.0) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -contains - - ! - ! Subroutine: mld_siluk_factint - ! Version: real - ! Note: internal subroutine of mld_siluk_fact - ! - ! This routine computes either the ILU(k) or the MILU(k) factorization of the - ! diagonal blocks of a distributed matrix. These factorizations are used to build - ! the 'base preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz - ! preconditioner) corresponding to a certain level of a multilevel preconditioner. - ! - ! The local matrix is stored into a and b, as specified in the - ! description of the arguments below. The storage format for both the L and U - ! factors is CSR. The diagonal of the U factor is stored separately (actually, - ! the inverse of the diagonal entries is stored; this is then managed in the - ! solve stage associated to the ILU(k)/MILU(k) factorization). - ! - ! - ! Arguments: - ! fill_in - integer, input. - ! The fill-in level k in ILU(k)/MILU(k). - ! ialg - integer, input. - ! The type of incomplete factorization to be performed. - ! The MILU(k) factorization is computed if ialg = 2 (= mld_milu_n_); - ! the ILU(k) factorization otherwise. - ! m - integer, output. - ! The total number of rows of the local matrix to be factorized, - ! i.e. ma+mb. - ! a - type(psb_sspmat_type), input. - ! The sparse matrix structure containing the local matrix. - ! Note that, if the 'base' Additive Schwarz preconditioner - ! has overlap greater than 0 and the matrix has not been reordered - ! (see mld_fact_bld), then a contains only the 'original' local part - ! of the distributed matrix, i.e. the rows of the matrix held - ! by the calling process according to the initial data distribution. - ! b - type(psb_sspmat_type), input. - ! The sparse matrix structure containing the remote rows of the - ! distributed matrix, that have been retrieved by mld_as_bld - ! to build an Additive Schwarz base preconditioner with overlap - ! greater than 0. If the overlap is 0 or the matrix has been reordered - ! (see mld_fact_bld), then b does not contain any row. - ! d - real(psb_spk_), dimension(:), output. - ! The inverse of the diagonal entries of the U factor in the incomplete - ! factorization. - ! laspk - real(psb_spk_), dimension(:), input/output. - ! The L factor in the incomplete factorization. - ! lia1 - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the L factor, - ! according to the CSR storage format. - ! lia2 - integer, dimension(:), input/output. - ! The indices identifying the first nonzero entry of each row - ! of the L factor in laspk, according to the CSR storage format. - ! uval - real(psb_spk_), dimension(:), input/output. - ! The U factor in the incomplete factorization. - ! The entries of U are stored according to the CSR format. - ! uja - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the U factor, - ! according to the CSR storage format. - ! uirp - integer, dimension(:), input/output. - ! The indices identifying the first nonzero entry of each row - ! of the U factor in uval, according to the CSR storage format. - ! l1 - integer, output - ! The number of nonzero entries in laspk. - ! l2 - integer, output - ! The number of nonzero entries in uval. - ! info - integer, output. - ! Error code. - ! - subroutine mld_siluk_factint(fill_in,ialg,a,b,& - & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info) - - use psb_base_mod - - implicit none - - ! Arguments - integer(psb_ipk_), intent(in) :: fill_in, ialg - type(psb_sspmat_type),intent(in) :: a,b - integer(psb_ipk_),intent(inout) :: l1,l2,info - integer(psb_ipk_), allocatable, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) - real(psb_spk_), allocatable, intent(inout) :: lval(:),uval(:) - real(psb_spk_), intent(inout) :: d(:) - - ! Local variables - integer(psb_ipk_) :: ma,mb,i, ktrw,err_act,nidx, m - integer(psb_ipk_), allocatable :: uplevs(:), rowlevs(:),idxs(:) - real(psb_spk_), allocatable :: row(:) - type(psb_i_heap) :: heap - type(psb_s_coo_sparse_mat) :: trw - character(len=20), parameter :: name='mld_siluk_factint' - character(len=20) :: ch_err - - info=psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - - - select case(ialg) - case(mld_ilu_n_,mld_milu_n_) - ! Ok - case default - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,& - & i_err=(/itwo,ialg,izero,izero,izero/)) - goto 9999 - end select - if (fill_in < 0) then - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name, & - & i_err=(/ione,fill_in,izero,izero,izero/)) - goto 9999 - end if - - ma = a%get_nrows() - mb = b%get_nrows() - m = ma+mb - - ! - ! Allocate a temporary buffer for the iluk_copyin function - ! - - call trw%allocate(izero,izero,ione) - if (info == psb_success_) call psb_ensure_size(m+1,lirp,info) - if (info == psb_success_) call psb_ensure_size(m+1,uirp,info) - - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_sp_all') - goto 9999 - end if - - l1=0 - l2=0 - lirp(1) = 1 - uirp(1) = 1 - - ! - ! Allocate memory to hold the entries of a row and the corresponding - ! fill levels - ! - allocate(uplevs(size(uval)),rowlevs(m),row(m),stat=info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - - uplevs(:) = m+1 - row(:) = szero - rowlevs(:) = -(m+1) - - ! - ! Cycle over the matrix rows - ! - do i = 1, m - - ! - ! At each iteration of the loop we keep in a heap the column indices - ! affected by the factorization. The heap is initialized and filled - ! in the iluk_copyin routine, and updated during the elimination, in - ! the iluk_fact routine. The heap is ideal because at each step we need - ! the lowest index, but we also need to insert new items, and the heap - ! allows to do both in log time. - ! - d(i) = szero - if (i<=ma) then - ! - ! Copy into trw the i-th local row of the matrix, stored in a - ! - call iluk_copyin(i,ma,a,ione,m,row,rowlevs,heap,ktrw,trw,info) - else - ! - ! Copy into trw the i-th local row of the matrix, stored in b - ! (as (i-ma)-th row) - ! - call iluk_copyin(i-ma,mb,b,ione,m,row,rowlevs,heap,ktrw,trw,info) - endif - - ! Do an elimination step on the current row. It turns out we only - ! need to keep track of fill levels for the upper triangle, hence we - ! do not have a lowlevs variable. - ! - if (info == psb_success_) call iluk_fact(fill_in,i,row,rowlevs,heap,& - & d,uja,uirp,uval,uplevs,nidx,idxs,info) - ! - ! Copy the row into lval/d(i)/uval - ! - if (info == psb_success_) call iluk_copyout(fill_in,ialg,i,m,row,rowlevs,nidx,idxs,& - & l1,l2,lja,lirp,lval,d,uja,uirp,uval,uplevs,info) - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='Copy/factor loop') - goto 9999 - end if - end do - - ! - ! And we're done, so deallocate the memory - ! - deallocate(uplevs,rowlevs,row,stat=info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Deallocate') - goto 9999 - end if - if (info == psb_success_) call trw%free() - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine mld_siluk_factint - - ! - ! Subroutine: iluk_copyin - ! Version: real - ! Note: internal subroutine of mld_siluk_fact - ! - ! This routine copies a row of a sparse matrix A, stored in the sparse matrix - ! structure a, into the array row and stores into a heap the column indices of - ! the nonzero entries of the copied row. The output array row is such that it - ! contains a full row of A, i.e. it contains also the zero entries of the row. - ! This is useful for the elimination step performed by iluk_fact after the call - ! to iluk_copyin (see mld_iluk_factint). - ! The routine also sets to zero the entries of the array rowlevs corresponding - ! to the nonzero entries of the copied row (see the description of the arguments - ! below). - ! - ! If the sparse matrix is in CSR format, a 'straight' copy is performed; - ! otherwise psb_sp_getblk is used to extract a block of rows, which is then - ! copied, row by row, into the array row, through successive calls to - ! ilu_copyin. - ! - ! This routine is used by mld_siluk_factint in the computation of the - ! ILU(k)/MILU(k) factorization of a local sparse matrix. - ! - ! - ! Arguments: - ! i - integer, input. - ! The local index of the row to be extracted from the - ! sparse matrix structure a. - ! m - integer, input. - ! The number of rows of the local matrix stored into a. - ! a - type(psb_sspmat_type), input. - ! The sparse matrix structure containing the row to be copied. - ! jmin - integer, input. - ! The minimum valid column index. - ! jmax - integer, input. - ! The maximum valid column index. - ! The output matrix will contain a clipped copy taken from - ! a(1:m,jmin:jmax). - ! row - real(psb_spk_), dimension(:), input/output. - ! In input it is the null vector (see mld_iluk_factint and - ! iluk_copyout). In output it contains the row extracted - ! from the matrix A. It actually contains a full row, i.e. - ! it contains also the zero entries of the row. - ! rowlevs - integer, dimension(:), input/output. - ! In input rowlevs(k) = -(m+1) for k=1,...,m. In output - ! rowlevs(k) = 0 for 1 <= k <= jmax and A(i,k) /= 0, for - ! future use in iluk_fact. - ! heap - type(psb_i_heap), input/output. - ! The heap containing the column indices of the nonzero - ! entries in the array row. - ! Note: this argument is intent(inout) and not only intent(out) - ! to retain its allocation, done by psb_init_heap inside this - ! routine. - ! ktrw - integer, input/output. - ! The index identifying the last entry taken from the - ! staging buffer trw. See below. - ! trw - type(psb_sspmat_type), input/output. - ! A staging buffer. If the matrix A is not in CSR format, we use - ! the psb_sp_getblk routine and store its output in trw; when we - ! need to call psb_sp_getblk we do it for a block of rows, and then - ! we consume them from trw in successive calls to this routine, - ! until we empty the buffer. Thus we will make a call to psb_sp_getblk - ! every nrb calls to copyin. If A is in CSR format it is unused. - ! - subroutine iluk_copyin(i,m,a,jmin,jmax,row,rowlevs,heap,ktrw,trw,info) - - use psb_base_mod - - implicit none - - ! Arguments - type(psb_sspmat_type), intent(in) :: a - type(psb_s_coo_sparse_mat), intent(inout) :: trw - integer(psb_ipk_), intent(in) :: i,m,jmin,jmax - integer(psb_ipk_), intent(inout) :: ktrw,info - integer(psb_ipk_), intent(inout) :: rowlevs(:) - real(psb_spk_), intent(inout) :: row(:) - type(psb_i_heap), intent(inout) :: heap - - ! Local variables - integer(psb_ipk_) :: k,j,irb,err_act,nz - integer(psb_ipk_), parameter :: nrb=40 - character(len=20), parameter :: name='iluk_copyin' - character(len=20) :: ch_err - - info=psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - call heap%init(info) - - select type (aa=> a%a) - type is (psb_s_csr_sparse_mat) - ! - ! Take a fast shortcut if the matrix is stored in CSR format - ! - - do j = aa%irp(i), aa%irp(i+1) - 1 - k = aa%ja(j) - if ((jmin<=k).and.(k<=jmax)) then - row(k) = aa%val(j) - rowlevs(k) = 0 - call heap%insert(k,info) - end if - end do - - class default - - ! - ! Otherwise use psb_sp_getblk, slower but able (in principle) of - ! handling any format. In this case, a block of rows is extracted - ! instead of a single row, for performance reasons, and these - ! rows are copied one by one into the array row, through successive - ! calls to iluk_copyin. - ! - - if ((mod(i,nrb) == 1).or.(nrb == 1)) then - irb = min(m-i+1,nrb) - call aa%csget(i,i+irb-1,trw,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_getblk' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - ktrw=1 - end if - nz = trw%get_nzeros() - do - if (ktrw > nz) exit - if (trw%ia(ktrw) > i) exit - k = trw%ja(ktrw) - if ((jmin<=k).and.(k<=jmax)) then - row(k) = trw%val(ktrw) - rowlevs(k) = 0 - call heap%insert(k,info) - end if - ktrw = ktrw + 1 - enddo - end select - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine iluk_copyin - - ! - ! Subroutine: iluk_fact - ! Version: real - ! Note: internal subroutine of mld_siluk_fact - ! - ! This routine does an elimination step of the ILU(k) factorization on a - ! single matrix row (see the calling routine mld_iluk_factint). - ! - ! This step is also the base for a MILU(k) elimination step on the row (see - ! iluk_copyout). This routine is used by mld_siluk_factint in the computation - ! of the ILU(k)/MILU(k) factorization of a local sparse matrix. - ! - ! NOTE: it turns out we only need to keep track of the fill levels for - ! the upper triangle. - ! - ! - ! Arguments - ! fill_in - integer, input. - ! The fill-in level k in ILU(k). - ! i - integer, input. - ! The local index of the row to which the factorization is - ! applied. - ! row - real(psb_spk_), dimension(:), input/output. - ! In input it contains the row to which the elimination step - ! has to be applied. In output it contains the row after the - ! elimination step. It actually contains a full row, i.e. - ! it contains also the zero entries of the row. - ! rowlevs - integer, dimension(:), input/output. - ! In input rowlevs(k) = 0 if the k-th entry of the row is - ! nonzero, and rowlevs(k) = -(m+1) otherwise. In output - ! rowlevs(k) contains the fill kevel of the k-th entry of - ! the row after the current elimination step; rowlevs(k) = -(m+1) - ! means that the k-th row entry is zero throughout the elimination - ! step. - ! heap - type(psb_i_heap), input/output. - ! The heap containing the column indices of the nonzero entries - ! in the processed row. In input it contains the indices concerning - ! the row before the elimination step, while in output it contains - ! the indices concerning the transformed row. - ! d - real(psb_spk_), input. - ! The inverse of the diagonal entries of the part of the U factor - ! above the current row (see iluk_copyout). - ! uja - integer, dimension(:), input. - ! The column indices of the nonzero entries of the part of the U - ! factor above the current row, stored in uval row by row (see - ! iluk_copyout, called by mld_siluk_factint), according to the CSR - ! storage format. - ! uirp - integer, dimension(:), input. - ! The indices identifying the first nonzero entry of each row of - ! the U factor above the current row, stored in uval row by row - ! (see iluk_copyout, called by mld_siluk_factint), according to - ! the CSR storage format. - ! uval - real(psb_spk_), dimension(:), input. - ! The entries of the U factor above the current row (except the - ! diagonal ones), stored according to the CSR format. - ! uplevs - integer, dimension(:), input. - ! The fill levels of the nonzero entries in the part of the - ! U factor above the current row. - ! nidx - integer, output. - ! The number of entries of the array row that have been - ! examined during the elimination step. This will be used - ! by the routine iluk_copyout. - ! idxs - integer, dimension(:), allocatable, input/output. - ! The indices of the entries of the array row that have been - ! examined during the elimination step.This will be used by - ! by the routine iluk_copyout. - ! Note: this argument is intent(inout) and not only intent(out) - ! to retain its allocation, done by this routine. - ! - subroutine iluk_fact(fill_in,i,row,rowlevs,heap,d,uja,uirp,uval,uplevs,nidx,idxs,info) - - use psb_base_mod - - implicit none - - ! Arguments - type(psb_i_heap), intent(inout) :: heap - integer(psb_ipk_), intent(in) :: i, fill_in - integer(psb_ipk_), intent(inout) :: nidx,info - integer(psb_ipk_), intent(inout) :: rowlevs(:) - integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) - integer(psb_ipk_), intent(inout) :: uja(:),uirp(:),uplevs(:) - real(psb_spk_), intent(inout) :: row(:), uval(:),d(:) - - ! Local variables - integer(psb_ipk_) :: k,j,lrwk,jj,lastk, iret - real(psb_spk_) :: rwk - - info = psb_success_ - if (.not.allocated(idxs)) then - allocate(idxs(200),stat=info) - if (info /= psb_success_) return - endif - nidx = 0 - lastk = -1 - - ! - ! Do while there are indices to be processed - ! - do - ! Beware: (iret < 0) means that the heap is empty, not an error. - call heap%get_first(k,iret) - if (iret < 0) return - - ! - ! Just in case an index has been put on the heap more than once. - ! - if (k == lastk) cycle - - lastk = k - nidx = nidx + 1 - if (nidx>size(idxs)) then - call psb_realloc(nidx+psb_heap_resize,idxs,info) - if (info /= psb_success_) return - end if - idxs(nidx) = k - - if ((row(k) /= szero).and.(rowlevs(k) <= fill_in).and.(ki) then - ! - ! Copy the upper part of the row - ! - if (rowlevs(j) <= fill_in) then - l2 = l2 + 1 - if (size(uval) < l2) then - ! - ! Figure out a good reallocation size! - ! - isz = max((l2/i)*m,int(1.2*l2),l2+100) - call psb_realloc(isz,uval,info) - if (info == psb_success_) call psb_realloc(isz,uja,info) - if (info == psb_success_) call psb_realloc(isz,uplevs,info,pad=(m+1)) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - end if - uja(l2) = j - uval(l2) = row(j) - uplevs(l2) = rowlevs(j) - else if (ialg == mld_milu_n_) then - ! - ! MILU(k): add discarded entries to the diagonal one - ! - d(i) = d(i) + row(j) - end if - ! - ! Re-initialize row(j) and rowlevs(j) - ! - row(j) = szero - rowlevs(j) = -(m+1) - end if - end do - - ! - ! Store the pointers to the first non occupied entry of in - ! lval and uval - ! - lirp(i+1) = l1 + 1 - uirp(i+1) = l2 + 1 - - ! - ! Check the pivot size - ! - if (abs(d(i)) < s_epstol) then - ! - ! Too small pivot: unstable factorization - ! - info = psb_err_pivot_too_small_ - int_err(1) = i - write(ch_err,'(g20.10)') d(i) - call psb_errpush(info,name,i_err=int_err,a_err=ch_err) - goto 9999 - else - ! - ! Compute 1/pivot - ! - d(i) = sone/d(i) - end if - - ! - ! Scale the upper part - ! - do j=uirp(i), uirp(i+1)-1 - uval(j) = d(i)*uval(j) - end do - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine iluk_copyout - - -end subroutine mld_siluk_fact diff --git a/mlprec/impl/solver/mld_silut_fact.f90 b/mlprec/impl/solver/mld_silut_fact.f90 deleted file mode 100644 index 202157df..00000000 --- a/mlprec/impl/solver/mld_silut_fact.f90 +++ /dev/null @@ -1,1186 +0,0 @@ -! -! -! MLD2P4 version 2.2 -! MultiLevel Domain Decomposition Parallel Preconditioners Package -! based on PSBLAS (Parallel Sparse BLAS version 3.5) -! -! (C) Copyright 2008-2018 -! -! Salvatore Filippone -! Pasqua D'Ambra -! Daniela di Serafino -! -! 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_silut_fact.f90 -! -! Subroutine: mld_silut_fact -! Version: real -! Contains: mld_silut_factint, ilut_copyin, ilut_fact, ilut_copyout -! -! This routine computes the ILU(k,t) factorization of the diagonal blocks -! of a distributed matrix. This factorization is used to build the 'base -! preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz -! preconditioner) corresponding to a certain level of a multilevel preconditioner. -! -! Details on the above factorization can be found in -! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, -! SIAM, 2003, Chapter 10. -! -! The local matrix is stored into a and blck, as specified in the description -! of the arguments below. The storage format for both the L and U factors is -! CSR. The diagonal of the U factor is stored separately (actually, the -! inverse of the diagonal entries is stored; this is then managed in the -! solve stage associated to the ILU(k,t) factorization). -! -! -! Arguments: -! fill_in - integer, input. -! The fill-in parameter k in ILU(k,t). -! thres - real, input. -! The threshold t, i.e. the drop tolerance, in ILU(k,t). -! a - type(psb_sspmat_type), input. -! The sparse matrix structure containing the local matrix. -! Note that if the 'base' Additive Schwarz preconditioner -! has overlap greater than 0 and the matrix has not been reordered -! (see mld_fact_bld), then a contains only the 'original' local part -! of the distributed matrix, i.e. the rows of the matrix held -! by the calling process according to the initial data distribution. -! l - type(psb_sspmat_type), input/output. -! The L factor in the incomplete factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! u - type(psb_sspmat_type), input/output. -! The U factor (except its diagonal) in the incomplete factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! d - real(psb_spk_), dimension(:), input/output. -! The inverse of the diagonal entries of the U factor in the incomplete -! factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! info - integer, output. -! Error code. -! blck - type(psb_sspmat_type), input, optional, target. -! The sparse matrix structure containing the remote rows of the -! distributed matrix, that have been retrieved by mld_as_bld -! to build an Additive Schwarz base preconditioner with overlap -! greater than 0. If the overlap is 0 or the matrix has been reordered -! (see mld_fact_bld), then blck does not contain any row. -! -subroutine mld_silut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) - - use psb_base_mod - use mld_s_ilu_fact_mod, mld_protect_name => mld_silut_fact - - implicit none - - ! Arguments - integer(psb_ipk_), intent(in) :: fill_in - real(psb_spk_), intent(in) :: thres - integer(psb_ipk_), intent(out) :: info - type(psb_sspmat_type),intent(in) :: a - type(psb_sspmat_type),intent(inout) :: l,u - real(psb_spk_), intent(inout) :: d(:) - type(psb_sspmat_type),intent(in), optional, target :: blck - integer(psb_ipk_), intent(in), optional :: iscale - ! Local Variables - integer(psb_ipk_) :: l1, l2, m, err_act, iscale_ - - type(psb_sspmat_type), pointer :: blck_ - type(psb_s_csr_sparse_mat) :: ll, uu - real(psb_spk_) :: scale - character(len=20) :: name, ch_err - - name='mld_silut_fact' - info = psb_success_ - call psb_erractionsave(err_act) - - if (fill_in < 0) then - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name, & - & i_err=(/ione,fill_in,izero,izero,izero/)) - goto 9999 - end if - ! - ! Point to / allocate memory for the incomplete factorization - ! - if (present(blck)) then - blck_ => blck - else - allocate(blck_,stat=info) - if (info == psb_success_) call blck_%csall(izero,izero,info,ione) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='csall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - if (present(iscale)) then - iscale_ = iscale - else - iscale_ = mld_ilu_scale_none_ - end if - - select case(iscale_) - case(mld_ilu_scale_none_) - scale = sone - case(mld_ilu_scale_maxval_) - scale = max(a%maxval(),blck_%maxval()) - scale = sone/scale - case default - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,i_err=(/ione*9,iscale_,izero,izero,izero/)) - goto 9999 - end select - - m = a%get_nrows() + blck_%get_nrows() - if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& - & (m > size(d)) ) then - write(0,*) 'Wrong allocation status for L,D,U? ',& - & l%get_nrows(),size(d),u%get_nrows() - info = -1 - return - end if - - call l%mv_to(ll) - call u%mv_to(uu) - - ! - ! Compute the ILU(k,t) factorization - ! - call mld_silut_factint(fill_in,thres,a,blck_,& - & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info,scale) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_silut_factint' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - ! - ! Store information on the L and U sparse matrices - ! - call l%mv_from(ll) - call l%set_triangle() - call l%set_unit() - call l%set_lower() - call u%mv_from(uu) - call u%set_triangle() - call u%set_unit() - call u%set_upper() - - ! - ! Nullify pointer / deallocate memory - ! - if (present(blck)) then - blck_ => null() - else - call blck_%free() - deallocate(blck_,stat=info) - if(info.ne.0) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - -contains - - ! - ! Subroutine: mld_silut_factint - ! Version: real - ! Note: internal subroutine of mld_silut_fact - ! - ! This routine computes the ILU(k,t) factorization of the diagonal blocks of a - ! distributed matrix. This factorization is used to build the 'base - ! preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz - ! preconditioner) corresponding to a certain level of a multilevel preconditioner. - ! - ! The local matrix to be factorized is stored into a and b, as specified in the - ! description of the arguments below. The storage format for both the L and U - ! factors is CSR. The diagonal of the U factor is stored separately (actually, - ! the inverse of the diagonal entries is stored; this is then managed in the - ! solve stage associated to the ILU(k,t) factorization). - ! - ! - ! Arguments: - ! fill_in - integer, input. - ! The fill-in parameter k in ILU(k,t). - ! thres - real, input. - ! The threshold t, i.e. the drop tolerance, in ILU(k,t). - ! m - integer, output. - ! The total number of rows of the local matrix to be factorized, - ! i.e. ma+mb. - ! a - type(psb_sspmat_type), input. - ! The sparse matrix structure containing the local matrix. - ! Note that, if the 'base' Additive Schwarz preconditioner - ! has overlap greater than 0 and the matrix has not been reordered - ! (see mld_fact_bld), then a contains only the 'original' local part - ! of the distributed matrix, i.e. the rows of the matrix held - ! by the calling process according to the initial data distribution. - ! b - type(psb_sspmat_type), input. - ! The sparse matrix structure containing the remote rows of the - ! distributed matrix, that have been retrieved by mld_as_bld - ! to build an Additive Schwarz base preconditioner with overlap - ! greater than 0. If the overlap is 0 or the matrix has been reordered - ! (see mld_fact_bld), then b does not contain any row. - ! d - real(psb_spk_), dimension(:), output. - ! The inverse of the diagonal entries of the U factor in the incomplete - ! factorization. - ! lval - real(psb_spk_), dimension(:), input/output. - ! The L factor in the incomplete factorization. - ! lia1 - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the L factor, - ! according to the CSR storage format. - ! lirp - integer, dimension(:), input/output. - ! The indices identifying the first nonzero entry of each row - ! of the L factor in lval, according to the CSR storage format. - ! uval - real(psb_spk_), dimension(:), input/output. - ! The U factor in the incomplete factorization. - ! The entries of U are stored according to the CSR format. - ! uja - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the U factor, - ! according to the CSR storage format. - ! uirp - integer, dimension(:), input/output. - ! The indices identifying the first nonzero entry of each row - ! of the U factor in uval, according to the CSR storage format. - ! l1 - integer, output - ! The number of nonzero entries in lval. - ! l2 - integer, output - ! The number of nonzero entries in uval. - ! info - integer, output. - ! Error code. - ! - subroutine mld_silut_factint(fill_in,thres,a,b,& - & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info,scale) - - use psb_base_mod - - implicit none - - ! Arguments - integer(psb_ipk_), intent(in) :: fill_in - real(psb_spk_), intent(in) :: thres - type(psb_sspmat_type),intent(in) :: a,b - integer(psb_ipk_),intent(inout) :: l1,l2,info - integer(psb_ipk_), allocatable, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) - real(psb_spk_), allocatable, intent(inout) :: lval(:),uval(:) - real(psb_spk_), intent(inout) :: d(:) - real(psb_spk_), intent(in), optional :: scale - - ! Local Variables - integer(psb_ipk_) :: i, ktrw,err_act,nidx,nlw,nup,jmaxup, ma, mb, m - real(psb_spk_) :: nrmi - real(psb_spk_) :: weight - integer(psb_ipk_), allocatable :: idxs(:) - real(psb_spk_), allocatable :: row(:) - type(psb_i_heap) :: heap - type(psb_s_coo_sparse_mat) :: trw - character(len=20), parameter :: name='mld_silut_factint' - character(len=20) :: ch_err - - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - - - ma = a%get_nrows() - mb = b%get_nrows() - m = ma+mb - - ! - ! Allocate a temporary buffer for the ilut_copyin function - ! - call trw%allocate(izero,izero,ione) - if (info == psb_success_) call psb_ensure_size(m+1,lirp,info) - if (info == psb_success_) call psb_ensure_size(m+1,uirp,info) - - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_sp_all') - goto 9999 - end if - - l1=0 - l2=0 - lirp(1) = 1 - uirp(1) = 1 - - ! - ! Allocate memory to hold the entries of a row - ! - allocate(row(m),stat=info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - - row(:) = czero - weight = sone - if (present(scale)) weight = abs(scale) - ! - ! Cycle over the matrix rows - ! - do i = 1, m - - ! - ! At each iteration of the loop we keep in a heap the column indices - ! affected by the factorization. The heap is initialized and filled - ! in the ilut_copyin function, and updated during the elimination, in - ! the ilut_fact routine. The heap is ideal because at each step we need - ! the lowest index, but we also need to insert new items, and the heap - ! allows to do both in log time. - ! - d(i) = czero - if (i<=ma) then - call ilut_copyin(i,ma,a,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& - & row,heap,ktrw,trw,info) - else - call ilut_copyin(i-ma,mb,b,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& - & row,heap,ktrw,trw,info) - endif - - ! - ! Do an elimination step on current row - ! - if (info == psb_success_) call ilut_fact(thres,i,nrmi,row,heap,& - & d,uja,uirp,uval,nidx,idxs,info) - ! - ! Copy the row into lval/d(i)/uval - ! - if (info == psb_success_) call ilut_copyout(fill_in,thres,i,m,& - & nlw,nup,jmaxup,nrmi,row,nidx,idxs,& - & l1,l2,lja,lirp,lval,d,uja,uirp,uval,info) - - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='Copy/factor loop') - goto 9999 - end if - - end do - ! - ! Adjust diagonal accounting for scale factor - ! - if (weight /= sone) then - d(1:m) = d(1:m)*weight - end if - - ! - ! And we're sone, so deallocate the memory - ! - deallocate(row,idxs,stat=info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Deallocate') - goto 9999 - end if - if (info == psb_success_) call trw%free() - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine mld_silut_factint - - ! - ! Subroutine: ilut_copyin - ! Version: real - ! Note: internal subroutine of mld_silut_fact - ! - ! This routine performs the following tasks: - ! - copying a row of a sparse matrix A, stored in the sparse matrix structure a, - ! into the array row; - ! - storing into a heap the column indices of the nonzero entries of the copied - ! row; - ! - computing the column index of the first entry with maximum absolute value - ! in the part of the row belonging to the upper triangle; - ! - computing the 2-norm of the row. - ! The output array row is such that it contains a full row of A, i.e. it contains - ! also the zero entries of the row. This is useful for the elimination step - ! performed by ilut_fact after the call to ilut_copyin (see mld_ilut_factint). - ! - ! If the sparse matrix is in CSR format, a 'straight' copy is performed; - ! otherwise psb_sp_getblk is used to extract a block of rows, which is then - ! copied, row by row, into the array row, through successive calls to - ! ilut_copyin. - ! - ! This routine is used by mld_silut_factint in the computation of the ILU(k,t) - ! factorization of a local sparse matrix. - ! - ! - ! Arguments: - ! i - integer, input. - ! The local index of the row to be extracted from the - ! sparse matrix structure a. - ! m - integer, input. - ! The number of rows of the local matrix stored into a. - ! a - type(psb_sspmat_type), input. - ! The sparse matrix structure containing the row to be - ! copied. - ! jd - integer, input. - ! The column index of the diagonal entry of the row to be - ! copied. - ! jmin - integer, input. - ! The minimum valid column index. - ! jmax - integer, input. - ! The maximum valid column index. - ! The output matrix will contain a clipped copy taken from - ! a(1:m,jmin:jmax). - ! nlw - integer, output. - ! The number of nonzero entries in the part of the row - ! belonging to the lower triangle of the matrix. - ! nup - integer, output. - ! The number of nonzero entries in the part of the row - ! belonging to the upper triangle of the matrix. - ! jmaxup - integer, output. - ! The column index of the first entry with maximum absolute - ! value in the part of the row belonging to the upper triangle - ! nrmi - real(psb_spk_), output. - ! The 2-norm of the current row. - ! row - real(psb_spk_), dimension(:), input/output. - ! In input it is the null vector (see mld_ilut_factint and - ! ilut_copyout). In output it contains the row extracted - ! from the matrix A. It actually contains a full row, i.e. - ! it contains also the zero entries of the row. - ! rowlevs - integer, dimension(:), input/output. - ! In input rowlevs(k) = -(m+1) for k=1,...,m. In output - ! rowlevs(k) = 0 for 1 <= k <= jmax and A(i,k) /= 0, for - ! future use in ilut_fact. - ! heap - type(psb_int_heap), input/output. - ! The heap containing the column indices of the nonzero - ! entries in the array row. - ! Note: this argument is intent(inout) and not only intent(out) - ! to retain its allocation, sone by psb_init_heap inside this - ! routine. - ! ktrw - integer, input/output. - ! The index identifying the last entry taken from the - ! staging buffer trw. See below. - ! trw - type(psb_sspmat_type), input/output. - ! A staging buffer. If the matrix A is not in CSR format, we use - ! the psb_sp_getblk routine and store its output in trw; when we - ! need to call psb_sp_getblk we do it for a block of rows, and then - ! we consume them from trw in successive calls to this routine, - ! until we empty the buffer. Thus we will make a call to psb_sp_getblk - ! every nrb calls to copyin. If A is in CSR format it is unused. - ! - subroutine ilut_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,& - & nrmi,weight,row,heap,ktrw,trw,info) - use psb_base_mod - implicit none - type(psb_sspmat_type), intent(in) :: a - type(psb_s_coo_sparse_mat), intent(inout) :: trw - integer(psb_ipk_), intent(in) :: i, m,jmin,jmax,jd - integer(psb_ipk_), intent(inout) :: ktrw,nlw,nup,jmaxup,info - real(psb_spk_), intent(inout) :: nrmi - real(psb_spk_), intent(inout) :: row(:) - real(psb_spk_), intent(in) :: weight - type(psb_i_heap), intent(inout) :: heap - - integer(psb_ipk_) :: k,j,irb,kin,nz - integer(psb_ipk_), parameter :: nrb=40 - real(psb_spk_) :: dmaxup - real(psb_spk_), external :: dnrm2 - character(len=20), parameter :: name='mld_silut_factint' - - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - - call heap%init(info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_init_heap') - goto 9999 - end if - - ! - ! nrmi is the norm of the current sparse row (for the time being, - ! we use the 2-norm). - ! NOTE: the 2-norm below includes also elements that are outside - ! [jmin:jmax] strictly. Is this really important? TO BE CHECKED. - ! - - nlw = 0 - nup = 0 - jmaxup = 0 - dmaxup = szero - nrmi = szero - - select type (aa=> a%a) - type is (psb_s_csr_sparse_mat) - ! - ! Take a fast shortcut if the matrix is stored in CSR format - ! - - do j = aa%irp(i), aa%irp(i+1) - 1 - k = aa%ja(j) - if ((jmin<=k).and.(k<=jmax)) then - row(k) = aa%val(j)*weight - call heap%insert(k,info) - if (info /= psb_success_) exit - if (kjd) then - nup = nup + 1 - if (abs(row(k))>dmaxup) then - jmaxup = k - dmaxup = abs(row(k)) - end if - end if - end if - end do - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_insert_heap') - goto 9999 - end if - - nz = aa%irp(i+1) - aa%irp(i) - nrmi = weight*dnrm2(nz,aa%val(aa%irp(i)),ione) - - - class default - - ! - ! Otherwise use psb_sp_getblk, slower but able (in principle) of - ! handling any format. In this case, a block of rows is extracted - ! instead of a single row, for performance reasons, and these - ! rows are copied one by one into the array row, through successive - ! calls to ilut_copyin. - ! - - if ((mod(i,nrb) == 1).or.(nrb == 1)) then - irb = min(m-i+1,nrb) - call aa%csget(i,i+irb-1,trw,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_sp_getblk') - goto 9999 - end if - ktrw=1 - end if - - kin = ktrw - nz = trw%get_nzeros() - do - if (ktrw > nz) exit - if (trw%ia(ktrw) > i) exit - k = trw%ja(ktrw) - if ((jmin<=k).and.(k<=jmax)) then - row(k) = trw%val(ktrw)*weight - call heap%insert(k,info) - if (info /= psb_success_) exit - if (kjd) then - nup = nup + 1 - if (abs(row(k))>dmaxup) then - jmaxup = k - dmaxup = abs(row(k)) - end if - end if - end if - ktrw = ktrw + 1 - enddo - nz = ktrw - kin - nrmi = weight*dnrm2(nz,trw%val(kin),ione) - end select - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine ilut_copyin - - ! - ! Subroutine: ilut_fact - ! Version: real - ! Note: internal subroutine of mld_silut_fact - ! - ! This routine does an elimination step of the ILU(k,t) factorization on a single - ! matrix row (see the calling routine mld_ilut_factint). Actually, only the dropping - ! rule based on the threshold is applied here. The dropping rule based on the - ! fill-in is applied by ilut_copyout. - ! - ! The routine is used by mld_silut_factint in the computation of the ILU(k,t) - ! factorization of a local sparse matrix. - ! - ! - ! Arguments - ! thres - real, input. - ! The threshold t, i.e. the drop tolerance, in ILU(k,t). - ! i - integer, input. - ! The local index of the row to which the factorization is applied. - ! nrmi - real(psb_spk_), input. - ! The 2-norm of the row to which the elimination step has to be - ! applied. - ! row - real(psb_spk_), dimension(:), input/output. - ! In input it contains the row to which the elimination step - ! has to be applied. In output it contains the row after the - ! elimination step. It actually contains a full row, i.e. - ! it contains also the zero entries of the row. - ! heap - type(psb_i_heap), input/output. - ! The heap containing the column indices of the nonzero entries - ! in the processed row. In input it contains the indices concerning - ! the row before the elimination step, while in output it contains - ! the previous indices plus the ones corresponding to transformed - ! entries in the 'upper part' that have not been dropped. - ! d - real(psb_spk_), input. - ! The inverse of the diagonal entries of the part of the U factor - ! above the current row (see ilut_copyout). - ! uja - integer, dimension(:), input. - ! The column indices of the nonzero entries of the part of the U - ! factor above the current row, stored in uval row by row (see - ! ilut_copyout, called by mld_silut_factint), according to the CSR - ! storage format. - ! uirp - integer, dimension(:), input. - ! The indices identifying the first nonzero entry of each row of - ! the U factor above the current row, stored in uval row by row - ! (see ilut_copyout, called by mld_silut_factint), according to - ! the CSR storage format. - ! uval - real(psb_spk_), dimension(:), input. - ! The entries of the U factor above the current row (except the - ! diagonal ones), stored according to the CSR format. - ! nidx - integer, output. - ! The number of entries of the array row that have been - ! examined during the elimination step. This will be used - ! by the routine ilut_copyout. - ! idxs - integer, dimension(:), allocatable, input/output. - ! The indices of the entries of the array row that have been - ! examined during the elimination step.This will be used by - ! by the routine ilut_copyout. - ! Note: this argument is intent(inout) and not only intent(out) - ! to retain its allocation, sone by this routine. - ! - subroutine ilut_fact(thres,i,nrmi,row,heap,d,uja,uirp,uval,nidx,idxs,info) - - use psb_base_mod - - implicit none - - ! Arguments - type(psb_i_heap), intent(inout) :: heap - integer(psb_ipk_), intent(in) :: i - integer(psb_ipk_), intent(inout) :: nidx,info - real(psb_spk_), intent(in) :: thres,nrmi - integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) - integer(psb_ipk_), intent(inout) :: uja(:),uirp(:) - real(psb_spk_), intent(inout) :: row(:), uval(:),d(:) - - ! Local Variables - integer(psb_ipk_) :: k,j,jj,lastk,iret - real(psb_spk_) :: rwk - - info = psb_success_ - call psb_ensure_size(200*ione,idxs,info) - if (info /= psb_success_) return - nidx = 0 - lastk = -1 - ! - ! Do while there are indices to be processed - ! - do - - call heap%get_first(k,iret) - if (iret < 0) exit - - ! - ! An index may have been put on the heap more than once. - ! - if (k == lastk) cycle - - lastk = k - lowert: if (k nidx) exit - if (idxs(idxp) >= i) exit - widx = idxs(idxp) - witem = row(widx) - ! - ! Dropping rule based on the 2-norm - ! - if (abs(witem) < thres*nrmi) cycle - - nz = nz + 1 - xw(nz) = witem - xwid(nz) = widx - call heap%insert(witem,widx,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_insert_heap') - goto 9999 - end if - end do - - ! - ! Now we have to take out the first nlw+fill_in entries - ! - if (nz <= nlw+fill_in) then - ! - ! Just copy everything from xw, and it is already ordered - ! - else - nz = nlw+fill_in - do k=1,nz - call heap%get_first(witem,widx,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_heap_get_first') - goto 9999 - end if - - xw(k) = witem - xwid(k) = widx - end do - end if - - ! - ! Now put things back into ascending column order - ! - call psb_msort(xwid(1:nz),indx(1:nz),dir=psb_sort_up_) - - ! - ! Copy out the lower part of the row - ! - do k=1,nz - l1 = l1 + 1 - if (size(lval) < l1) then - ! - ! Figure out a good reallocation size! - ! - isz = (max((l1/i)*m,int(1.2*l1),l1+100)) - call psb_realloc(isz,lval,info) - if (info == psb_success_) call psb_realloc(isz,lja,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - end if - lja(l1) = xwid(k) - lval(l1) = xw(indx(k)) - end do - - ! - ! Make sure idxp points to the diagonal entry - ! - if (idxp <= size(idxs)) then - if (idxs(idxp) < i) then - do - idxp = idxp + 1 - if (idxp > nidx) exit - if (idxs(idxp) >= i) exit - end do - end if - end if - if (idxp > size(idxs)) then -!!$ write(0,*) 'Warning: missing diagonal element in the row ' - else - if (idxs(idxp) > i) then -!!$ write(0,*) 'Warning: missing diagonal element in the row ' - else if (idxs(idxp) /= i) then -!!$ write(0,*) 'Warning: impossible error: diagonal has vanished' - else - ! - ! Copy the diagonal entry - ! - widx = idxs(idxp) - witem = row(widx) - d(i) = witem - if (abs(d(i)) < s_epstol) then - ! - ! Too small pivot: unstable factorization - ! - info = psb_err_pivot_too_small_ - int_err(1) = i - write(ch_err,'(g20.10)') d(i) - call psb_errpush(info,name,i_err=int_err,a_err=ch_err) - goto 9999 - else - ! - ! Compute 1/pivot - ! - d(i) = cone/d(i) - end if - end if - end if - - ! - ! Now the upper part - ! - - call heap%init(info,dir=psb_asort_down_) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_init_heap') - goto 9999 - end if - - nz = 0 - do - - idxp = idxp + 1 - if (idxp > nidx) exit - widx = idxs(idxp) - if (widx <= i) then -!!$ write(0,*) 'Warning: lower triangle in upper copy',widx,i,idxp,idxs(idxp) - cycle - end if - if (widx > m) then -!!$ write(0,*) 'Warning: impossible value',widx,i,idxp,idxs(idxp) - cycle - end if - witem = row(widx) - ! - ! Dropping rule based on the 2-norm. But keep the jmaxup-th entry anyway. - ! - if ((widx /= jmaxup) .and. (abs(witem) < thres*nrmi)) then - cycle - end if - - nz = nz + 1 - xw(nz) = witem - xwid(nz) = widx - call heap%insert(witem,widx,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_insert_heap') - goto 9999 - end if - - end do - - ! - ! Now we have to take out the first nup-fill_in entries. But make sure - ! we include entry jmaxup. - ! - if (nz <= nup+fill_in) then - ! - ! Just copy everything from xw - ! - fndmaxup=.true. - else - fndmaxup = .false. - nz = nup+fill_in - do k=1,nz - call heap%get_first(witem,widx,info) - xw(k) = witem - xwid(k) = widx - if (widx == jmaxup) fndmaxup=.true. - end do - end if - if ((i= 0 - call mld_ilut_fact(sv%fill_in,sv%thresh,& + call psb_ilut_fact(sv%fill_in,sv%thresh,& & a, sv%l,sv%u,sv%d,info,blck=b) end select if(info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='mld_ilut_fact' + ch_err='psb_ilut_fact' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - case(mld_ilu_n_,mld_milu_n_) + case(psb_ilu_n_,psb_milu_n_) ! ! ILU(k) and MILU(k) ! @@ -137,24 +137,24 @@ subroutine mld_z_ilu_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) ! Fill-in 0 ! Separate implementation of ILU(0) for better performance. ! There seems to be a problem with the separate implementation of MILU(0), - ! contained into mld_ilu0_fact. This must be investigated. For the time being, + ! contained into psb_ilu0_fact. This must be investigated. For the time being, ! resort to the implementation of MILU(k) with k=0. - if (sv%fact_type == mld_ilu_n_) then - call mld_ilu0_fact(sv%fact_type,a,sv%l,sv%u,& + if (sv%fact_type == psb_ilu_n_) then + call psb_ilu0_fact(sv%fact_type,a,sv%l,sv%u,& & sv%d,info,blck=b) else - call mld_iluk_fact(sv%fill_in,sv%fact_type,& + call psb_iluk_fact(sv%fill_in,sv%fact_type,& & a,sv%l,sv%u,sv%d,info,blck=b) endif case(1:) ! Fill-in >= 1 ! The same routine implements both ILU(k) and MILU(k) - call mld_iluk_fact(sv%fill_in,sv%fact_type,& + call psb_iluk_fact(sv%fill_in,sv%fact_type,& & a,sv%l,sv%u,sv%d,info,blck=b) end select if (info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='mld_iluk_fact' + ch_err='psb_iluk_fact' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if diff --git a/mlprec/impl/solver/mld_zilu0_fact.f90 b/mlprec/impl/solver/mld_zilu0_fact.f90 deleted file mode 100644 index 30dcbce6..00000000 --- a/mlprec/impl/solver/mld_zilu0_fact.f90 +++ /dev/null @@ -1,666 +0,0 @@ -! -! -! MLD2P4 version 2.2 -! MultiLevel Domain Decomposition Parallel Preconditioners Package -! based on PSBLAS (Parallel Sparse BLAS version 3.5) -! -! (C) Copyright 2008-2018 -! -! Salvatore Filippone -! Pasqua D'Ambra -! Daniela di Serafino -! -! 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_zilu0_fact.f90 -! -! Subroutine: mld_zilu0_fact -! Version: complex -! Contains: mld_zilu0_factint, ilu_copyin -! -! This routine computes either the ILU(0) or the MILU(0) factorization of -! the diagonal blocks of a distributed matrix. These factorizations are used -! to build the 'base preconditioner' (block-Jacobi preconditioner/solver, -! Additive Schwarz preconditioner) corresponding to a given level of a -! multilevel preconditioner. -! -! Details on the above factorizations can be found in -! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, -! SIAM, 2003, Chapter 10. -! -! The local matrix is stored into a and blck, as specified in the description -! of the arguments below. The storage format for both the L and U factors is CSR. -! The diagonal of the U factor is stored separately (actually, the inverse of the -! diagonal entries is stored; this is then managed in the solve stage associated -! to the ILU(0)/MILU(0) factorization). -! -! The routine copies and factors "on the fly" from a and blck into l (L factor), -! u (U factor, except its diagonal) and d (diagonal of U). -! -! This implementation of ILU(0)/MILU(0) is faster than the implementation in -! mld_ziluk_fct (the latter routine performs the more general ILU(k)/MILU(k)). -! -! -! Arguments: -! ialg - integer, input. -! The type of incomplete factorization to be performed. -! The MILU(0) factorization is computed if ialg = 2 (= mld_milu_n_); -! the ILU(0) factorization otherwise. -! a - type(psb_zspmat_type), input. -! The sparse matrix structure containing the local matrix. -! Note that if the 'base' Additive Schwarz preconditioner -! has overlap greater than 0 and the matrix has not been reordered -! (see mld_as_bld), then a contains only the 'original' local part -! of the distributed matrix, i.e. the rows of the matrix held -! by the calling process according to the initial data distribution. -! l - type(psb_zspmat_type), input/output. -! The L factor in the incomplete factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! u - type(psb_zspmat_type), input/output. -! The U factor (except its diagonal) in the incomplete factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! d - complex(psb_dpk_), dimension(:), input/output. -! The inverse of the diagonal entries of the U factor in the incomplete -! factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! info - integer, output. -! Error code. -! blck - type(psb_zspmat_type), input, optional, target. -! The sparse matrix structure containing the remote rows of the -! distributed matrix, that have been retrieved by mld_as_bld -! to build an Additive Schwarz base preconditioner with overlap -! greater than 0. If the overlap is 0 or the matrix has been reordered -! (see mld_fact_bld), then blck is empty. -! -subroutine mld_zilu0_fact(ialg,a,l,u,d,info,blck, upd) - - use psb_base_mod - use mld_z_ilu_fact_mod, mld_protect_name => mld_zilu0_fact - - implicit none - - ! Arguments - integer(psb_ipk_), intent(in) :: ialg - type(psb_zspmat_type),intent(in) :: a - type(psb_zspmat_type),intent(inout) :: l,u - complex(psb_dpk_), intent(inout) :: d(:) - integer(psb_ipk_), intent(out) :: info - type(psb_zspmat_type),intent(in), optional, target :: blck - character, intent(in), optional :: upd - - ! Local variables - integer(psb_ipk_) :: l1, l2, m, err_act - type(psb_zspmat_type), pointer :: blck_ - type(psb_z_csr_sparse_mat) :: ll, uu - character :: upd_ - character(len=20) :: name, ch_err - - name='mld_zilu0_fact' - info = psb_success_ - call psb_erractionsave(err_act) - - ! - ! Point to / allocate memory for the incomplete factorization - ! - if (present(blck)) then - blck_ => blck - else - allocate(blck_,stat=info) - if (info == psb_success_) call blck_%csall(izero,izero,info,ione) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='csall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - if (present(upd)) then - upd_ = psb_toupper(upd) - else - upd_ = 'F' - end if - - m = a%get_nrows() + blck_%get_nrows() - if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& - & (m > size(d)) ) then - write(0,*) 'Wrong allocation status for L,D,U? ',& - & l%get_nrows(),size(d),u%get_nrows() - info = -1 - return - end if - - call l%mv_to(ll) - call u%mv_to(uu) - ! - ! Compute the ILU(0) or the MILU(0) factorization, depending on ialg - ! - call mld_zilu0_factint(ialg,a,blck_,& - & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,upd_,info) - if(info.ne.0) then - info=psb_err_from_subroutine_ - ch_err='mld_zilu0_factint' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - ! - ! Store information on the L and U sparse matrices - ! - call l%mv_from(ll) - call l%set_triangle() - call l%set_unit() - call l%set_lower() - call u%mv_from(uu) - call u%set_triangle() - call u%set_unit() - call u%set_upper() - - ! - ! Nullify pointer / deallocate memory - ! - if (present(blck)) then - blck_ => null() - else - call blck_%free() - if(info.ne.0) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - deallocate(blck_) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -contains - - ! - ! Subroutine: mld_zilu0_factint - ! Version: complex - ! Note: internal subroutine of mld_zilu0_fact. - ! - ! This routine computes either the ILU(0) or the MILU(0) factorization of the - ! diagonal blocks of a distributed matrix. - ! These factorizations are used to build the 'base preconditioner' - ! (block-Jacobi preconditioner/solver, Additive Schwarz - ! preconditioner) corresponding to a given level of a multilevel preconditioner. - ! - ! The local matrix is stored into a and b, as specified in the - ! description of the arguments below. The storage format for both the L and U - ! factors is CSR. The diagonal of the U factor is stored separately (actually, - ! the inverse of the diagonal entries is stored; this is then managed in the - ! solve stage associated to the ILU(0)/MILU(0) factorization). - ! - ! The routine copies and factors "on the fly" from the sparse matrix structures a - ! and b into the arrays lval, uval, d (L, U without its diagonal, diagonal of U). - ! - ! - ! Arguments: - ! ialg - integer, input. - ! The type of incomplete factorization to be performed. - ! The ILU(0) factorization is computed if ialg = 1 (= mld_ilu_n_), - ! the MILU(0) one if ialg = 2 (= mld_milu_n_); other values - ! are not allowed. - ! m - integer, output. - ! The total number of rows of the local matrix to be factorized, - ! i.e. ma+mb. - ! ma - integer, input - ! The number of rows of the local submatrix stored into a. - ! a - type(psb_zspmat_type), input. - ! The sparse matrix structure containing the local matrix. - ! Note that, if the 'base' Additive Schwarz preconditioner - ! has overlap greater than 0 and the matrix has not been reordered - ! (see mld_fact_bld), then a contains only the 'original' local part - ! of the distributed matrix, i.e. the rows of the matrix held - ! by the calling process according to the initial data distribution. - ! mb - integer, input. - ! The number of rows of the local submatrix stored into b. - ! b - type(psb_zspmat_type), input. - ! The sparse matrix structure containing the remote rows of the - ! distributed matrix, that have been retrieved by mld_as_bld - ! to build an Additive Schwarz base preconditioner with overlap - ! greater than 0. If the overlap is 0 or the matrix has been - ! reordered (see mld_fact_bld), then b does not contain any row. - ! d - complex(psb_dpk_), dimension(:), output. - ! The inverse of the diagonal entries of the U factor in the - ! incomplete factorization. - ! lval - complex(psb_dpk_), dimension(:), input/output. - ! The entries of U are stored according to the CSR format. - ! The L factor in the incomplete factorization. - ! lja - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the L factor, - ! according to the CSR storage format. - ! lirp - integer, dimension(:), input/output. - ! The indices identifying the first nonzero entry of each row - ! of the L factor in lval, according to the CSR storage format. - ! uval - complex(psb_dpk_), dimension(:), input/output. - ! The U factor in the incomplete factorization. - ! The entries of U are stored according to the CSR format. - ! uja - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the U factor, - ! according to the CSR storage format. - ! uirp - integer, dimension(:), input/output. - ! The indices identifying the first nonzero entry of each row - ! of the U factor in uval, according to the CSR storage format. - ! l1 - integer, output. - ! The number of nonzero entries in lval. - ! l2 - integer, output. - ! The number of nonzero entries in uval. - ! info - integer, output. - ! Error code. - ! - subroutine mld_zilu0_factint(ialg,a,b,& - & d,lval,lja,lirp,uval,uja,uirp,l1,l2,upd,info) - - implicit none - - ! Arguments - integer(psb_ipk_), intent(in) :: ialg - type(psb_zspmat_type),intent(in) :: a,b - integer(psb_ipk_),intent(inout) :: l1,l2,info - integer(psb_ipk_), intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) - complex(psb_dpk_), intent(inout) :: lval(:),uval(:),d(:) - character, intent(in) :: upd - - ! Local variables - integer(psb_ipk_) :: i,j,k,l,low1,low2,kk,jj,ll, ktrw,err_act, m - integer(psb_ipk_) :: ma,mb - complex(psb_dpk_) :: dia,temp - integer(psb_ipk_), parameter :: nrb=16 - type(psb_z_coo_sparse_mat) :: trw - integer(psb_ipk_) :: int_err(5) - character(len=20) :: name, ch_err - - name='mld_zilu0_factint' - info=psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - ma = a%get_nrows() - mb = b%get_nrows() - - select case(ialg) - case(mld_ilu_n_,mld_milu_n_) - ! Ok - case default - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,& - & i_err=(/ione,ialg,izero,izero,izero/)) - goto 9999 - end select - - call trw%allocate(izero,izero,ione) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_all' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - m = ma+mb - - if (psb_toupper(upd) == 'F' ) then - lirp(1) = 1 - uirp(1) = 1 - l1 = 0 - l2 = 0 - - ! - ! Cycle over the matrix rows - ! - do i = 1, m - - d(i) = zzero - - if (i <= ma) then - ! - ! Copy the i-th local row of the matrix, stored in a, - ! into lval/d(i)/uval - ! - call ilu_copyin(i,ma,a,i,ione,m,l1,lja,lval,& - & d(i),l2,uja,uval,ktrw,trw,upd) - else - ! - ! Copy the i-th local row of the matrix, stored in b - ! (as (i-ma)-th row), into lval/d(i)/uval - ! - call ilu_copyin(i-ma,mb,b,i,ione,m,l1,lja,lval,& - & d(i),l2,uja,uval,ktrw,trw,upd) - endif - - lirp(i+1) = l1 + 1 - uirp(i+1) = l2 + 1 - - dia = d(i) - do kk = lirp(i), lirp(i+1) - 1 - ! - ! Compute entry l(i,k) (lower factor L) of the incomplete - ! factorization - ! - temp = lval(kk) - k = lja(kk) - lval(kk) = temp*d(k) - ! - ! Update the rest of row i (lower and upper factors L and U) - ! using l(i,k) - ! - low1 = kk + 1 - low2 = uirp(i) - ! - updateloop: do jj = uirp(k), uirp(k+1) - 1 - ! - j = uja(jj) - ! - if (j < i) then - ! - ! search l(i,*) (i-th row of L) for a matching index j - ! - do ll = low1, lirp(i+1) - 1 - l = lja(ll) - if (l > j) then - low1 = ll - exit - else if (l == j) then - lval(ll) = lval(ll) - temp*uval(jj) - low1 = ll + 1 - cycle updateloop - end if - enddo - - else if (j == i) then - ! - ! j=i: update the diagonal - ! - dia = dia - temp*uval(jj) - cycle updateloop - ! - else if (j > i) then - ! - ! search u(i,*) (i-th row of U) for a matching index j - ! - do ll = low2, uirp(i+1) - 1 - l = uja(ll) - if (l > j) then - low2 = ll - exit - else if (l == j) then - uval(ll) = uval(ll) - temp*uval(jj) - low2 = ll + 1 - cycle updateloop - end if - enddo - end if - ! - ! If we get here we missed the cycle updateloop, which means - ! that this entry does not match; thus we accumulate on the - ! diagonal for MILU(0). - ! - if (ialg == mld_milu_n_) then - dia = dia - temp*uval(jj) - end if - enddo updateloop - enddo - ! - ! Check the pivot size - ! - if (abs(dia) < d_epstol) then - ! - ! Too small pivot: unstable factorization - ! - info = psb_err_pivot_too_small_ - int_err(1) = i - write(ch_err,'(g20.10)') abs(dia) - call psb_errpush(info,name,i_err=int_err,a_err=ch_err) - goto 9999 - else - ! - ! Compute 1/pivot - ! - dia = zone/dia - end if - d(i) = dia - ! - ! Scale row i of upper triangle - ! - do kk = uirp(i), uirp(i+1) - 1 - uval(kk) = uval(kk)*dia - enddo - enddo - else - write(0,*) 'Update not implemented ' - info = 31 - call psb_errpush(info,name,& - & i_err=(/ione*13,izero,izero,izero,izero/),a_err=upd) - goto 9999 - - end if - - call trw%free() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine mld_zilu0_factint - - ! - ! Subroutine: ilu_copyin - ! Version: complex - ! Note: internal subroutine of mld_zilu0_fact - ! - ! This routine copies a row of a sparse matrix A, stored in the psb_zspmat_type - ! data structure a, into the arrays lval and uval and into the scalar variable - ! dia, corresponding to the lower and upper triangles of A and to the diagonal - ! entry of the row, respectively. The entries in lval and uval are stored - ! according to the CSR format; the corresponding column indices are stored in - ! the arrays lja and uja. - ! - ! If the sparse matrix is in CSR format, a 'straight' copy is performed; - ! otherwise psb_sp_getblk is used to extract a block of rows, which is then - ! copied into lval, dia, uval row by row, through successive calls to - ! ilu_copyin. - ! - ! The routine is used by mld_zilu0_factint in the computation of the ILU(0)/MILU(0) - ! factorization of a local sparse matrix. - ! - ! TODO: modify the routine to allow copying into output L and U that are - ! already filled with indices; this would allow computing an ILU(k) pattern, - ! then use the ILU(0) internal for subsequent calls with the same pattern. - ! - ! Arguments: - ! i - integer, input. - ! The local index of the row to be extracted from the - ! sparse matrix structure a. - ! m - integer, input. - ! The number of rows of the local matrix stored into a. - ! a - type(psb_zspmat_type), input. - ! The sparse matrix structure containing the row to be copied. - ! jd - integer, input. - ! The column index of the diagonal entry of the row to be - ! copied. - ! jmin - integer, input. - ! Minimum valid column index. - ! jmax - integer, input. - ! Maximum valid column index. - ! The output matrix will contain a clipped copy taken from - ! a(1:m,jmin:jmax). - ! l1 - integer, input/output. - ! Pointer to the last occupied entry of lval. - ! lja - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the lower triangle - ! copied in lval row by row (see mld_zilu0_factint), according - ! to the CSR storage format. - ! lval - complex(psb_dpk_), dimension(:), input/output. - ! The array where the entries of the row corresponding to the - ! lower triangle are copied. - ! dia - complex(psb_dpk_), output. - ! The diagonal entry of the copied row. - ! l2 - integer, input/output. - ! Pointer to the last occupied entry of uval. - ! uja - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the upper triangle - ! copied in uval row by row (see mld_zilu0_factint), according - ! to the CSR storage format. - ! uval - complex(psb_dpk_), dimension(:), input/output. - ! The array where the entries of the row corresponding to the - ! upper triangle are copied. - ! ktrw - integer, input/output. - ! The index identifying the last entry taken from the - ! staging buffer trw. See below. - ! trw - type(psb_zspmat_type), input/output. - ! A staging buffer. If the matrix A is not in CSR format, we use - ! the psb_sp_getblk routine and store its output in trw; when we - ! need to call psb_sp_getblk we do it for a block of rows, and then - ! we consume them from trw in successive calls to this routine, - ! until we empty the buffer. Thus we will make a call to psb_sp_getblk - ! every nrb calls to copyin. If A is in CSR format it is unused. - ! - subroutine ilu_copyin(i,m,a,jd,jmin,jmax,l1,lja,lval,& - & dia,l2,uja,uval,ktrw,trw,upd) - - use psb_base_mod - - implicit none - - ! Arguments - type(psb_zspmat_type), intent(in) :: a - type(psb_z_coo_sparse_mat), intent(inout) :: trw - integer(psb_ipk_), intent(in) :: i,m,jd,jmin,jmax - integer(psb_ipk_), intent(inout) :: ktrw,l1,l2 - integer(psb_ipk_), intent(inout) :: lja(:), uja(:) - complex(psb_dpk_), intent(inout) :: lval(:), uval(:), dia - character, intent(in) :: upd - ! Local variables - integer(psb_ipk_) :: k,j,info,irb, nz - integer(psb_ipk_), parameter :: nrb=40 - character(len=20), parameter :: name='ilu_copyin' - character(len=20) :: ch_err - - info=psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - if (psb_toupper(upd) == 'F') then - - select type(aa => a%a) - type is (psb_z_csr_sparse_mat) - - ! - ! Take a fast shortcut if the matrix is stored in CSR format - ! - - do j = aa%irp(i), aa%irp(i+1) - 1 - k = aa%ja(j) - ! write(0,*)'KKKKK',k - if ((k < jd).and.(k >= jmin)) then - l1 = l1 + 1 - lval(l1) = aa%val(j) - lja(l1) = k - else if (k == jd) then - dia = aa%val(j) - else if ((k > jd).and.(k <= jmax)) then - l2 = l2 + 1 - uval(l2) = aa%val(j) - uja(l2) = k - end if - enddo - - class default - - ! - ! Otherwise use psb_sp_getblk, slower but able (in principle) of - ! handling any format. In this case, a block of rows is extracted - ! instead of a single row, for performance reasons, and these - ! rows are copied one by one into lval, dia, uval, through - ! successive calls to ilu_copyin. - ! - - if ((mod(i,nrb) == 1).or.(nrb == 1)) then - irb = min(m-i+1,nrb) - call aa%csget(i,i+irb-1,trw,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='csget' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - ktrw=1 - end if - - nz = trw%get_nzeros() - do - if (ktrw > nz) exit - if (trw%ia(ktrw) > i) exit - k = trw%ja(ktrw) - if ((k < jd).and.(k >= jmin)) then - l1 = l1 + 1 - lval(l1) = trw%val(ktrw) - lja(l1) = k - else if (k == jd) then - dia = trw%val(ktrw) - else if ((k > jd).and.(k <= jmax)) then - l2 = l2 + 1 - uval(l2) = trw%val(ktrw) - uja(l2) = k - end if - ktrw = ktrw + 1 - enddo - - end select - - else - - write(0,*) 'Update not implemented ' - info = 31 - call psb_errpush(info,name,& - & i_err=(/ione*13,izero,izero,izero,izero/),a_err=upd) - goto 9999 - - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine ilu_copyin - -end subroutine mld_zilu0_fact diff --git a/mlprec/impl/solver/mld_ziluk_fact.f90 b/mlprec/impl/solver/mld_ziluk_fact.f90 deleted file mode 100644 index dced4381..00000000 --- a/mlprec/impl/solver/mld_ziluk_fact.f90 +++ /dev/null @@ -1,969 +0,0 @@ -! -! -! MLD2P4 version 2.2 -! MultiLevel Domain Decomposition Parallel Preconditioners Package -! based on PSBLAS (Parallel Sparse BLAS version 3.5) -! -! (C) Copyright 2008-2018 -! -! Salvatore Filippone -! Pasqua D'Ambra -! Daniela di Serafino -! -! 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_ziluk_fact.f90 -! -! Subroutine: mld_ziluk_fact -! Version: complex -! Contains: mld_ziluk_factint, iluk_copyin, iluk_fact, iluk_copyout. -! -! This routine computes either the ILU(k) or the MILU(k) factorization of the -! diagonal blocks of a distributed matrix. These factorizations are used to -! build the 'base preconditioner' (block-Jacobi preconditioner/solver, -! Additive Schwarz preconditioner) corresponding to a certain level of a -! multilevel preconditioner. -! -! Details on the above factorizations can be found in -! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, -! SIAM, 2003, Chapter 10. -! -! The local matrix is stored into a and blck, as specified in -! the description of the arguments below. The storage format for both the L and -! U factors is CSR. The diagonal of the U factor is stored separately (actually, -! the inverse of the diagonal entries is stored; this is then managed in the solve -! stage associated to the ILU(k)/MILU(k) factorization). -! -! -! Arguments: -! fill_in - integer, input. -! The fill-in level k in ILU(k)/MILU(k). -! ialg - integer, input. -! The type of incomplete factorization to be performed. -! The ILU(k) factorization is computed if ialg = 1 (= mld_ilu_n_); -! the MILU(k) one if ialg = 2 (= mld_milu_n_); other values are -! not allowed. -! a - type(psb_zspmat_type), input. -! The sparse matrix structure containing the local matrix. -! Note that if the 'base' Additive Schwarz preconditioner -! has overlap greater than 0 and the matrix has not been reordered -! (see mld_fact_bld), then a contains only the 'original' local part -! of the distributed matrix, i.e. the rows of the matrix held -! by the calling process according to the initial data distribution. -! l - type(psb_zspmat_type), input/output. -! The L factor in the incomplete factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! u - type(psb_zspmat_type), input/output. -! The U factor (except its diagonal) in the incomplete factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! d - complex(psb_dpk_), dimension(:), input/output. -! The inverse of the diagonal entries of the U factor in the incomplete -! factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! info - integer, output. -! Error code. -! blck - type(psb_zspmat_type), input, optional, target. -! The sparse matrix structure containing the remote rows of the -! distributed matrix, that have been retrieved by mld_as_bld -! to build an Additive Schwarz base preconditioner with overlap -! greater than 0. If the overlap is 0 or the matrix has been reordered -! (see mld_fact_bld), then blck does not contain any row. -! -subroutine mld_ziluk_fact(fill_in,ialg,a,l,u,d,info,blck) - - use psb_base_mod - use mld_z_ilu_fact_mod, mld_protect_name => mld_ziluk_fact - - implicit none - - ! Arguments - integer(psb_ipk_), intent(in) :: fill_in, ialg - integer(psb_ipk_), intent(out) :: info - type(psb_zspmat_type),intent(in) :: a - type(psb_zspmat_type),intent(inout) :: l,u - type(psb_zspmat_type),intent(in), optional, target :: blck - complex(psb_dpk_), intent(inout) :: d(:) - ! Local Variables - integer(psb_ipk_) :: l1, l2, m, err_act - - type(psb_zspmat_type), pointer :: blck_ - type(psb_z_csr_sparse_mat) :: ll, uu - character(len=20) :: name, ch_err - - name='mld_ziluk_fact' - info = psb_success_ - call psb_erractionsave(err_act) - - ! - ! Point to / allocate memory for the incomplete factorization - ! - if (present(blck)) then - blck_ => blck - else - allocate(blck_,stat=info) - if (info == psb_success_) call blck_%csall(izero,izero,info,ione) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='csall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - - m = a%get_nrows() + blck_%get_nrows() - if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& - & (m > size(d)) ) then - write(0,*) 'Wrong allocation status for L,D,U? ',& - & l%get_nrows(),size(d),u%get_nrows() - info = -1 - return - end if - - call l%mv_to(ll) - call u%mv_to(uu) - - ! - ! Compute the ILU(k) or the MILU(k) factorization, depending on ialg - ! - call mld_ziluk_factint(fill_in,ialg,a,blck_,& - & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_ziluk_factint' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - ! - ! Store information on the L and U sparse matrices - ! - call l%mv_from(ll) - call l%set_triangle() - call l%set_unit() - call l%set_lower() - call u%mv_from(uu) - call u%set_triangle() - call u%set_unit() - call u%set_upper() - - ! - ! Nullify pointer / deallocate memory - ! - if (present(blck)) then - blck_ => null() - else - call blck_%free() - deallocate(blck_,stat=info) - if(info.ne.0) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -contains - - ! - ! Subroutine: mld_ziluk_factint - ! Version: complex - ! Note: internal subroutine of mld_ziluk_fact - ! - ! This routine computes either the ILU(k) or the MILU(k) factorization of the - ! diagonal blocks of a distributed matrix. These factorizations are used to build - ! the 'base preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz - ! preconditioner) corresponding to a certain level of a multilevel preconditioner. - ! - ! The local matrix is stored into a and b, as specified in the - ! description of the arguments below. The storage format for both the L and U - ! factors is CSR. The diagonal of the U factor is stored separately (actually, - ! the inverse of the diagonal entries is stored; this is then managed in the - ! solve stage associated to the ILU(k)/MILU(k) factorization). - ! - ! - ! Arguments: - ! fill_in - integer, input. - ! The fill-in level k in ILU(k)/MILU(k). - ! ialg - integer, input. - ! The type of incomplete factorization to be performed. - ! The MILU(k) factorization is computed if ialg = 2 (= mld_milu_n_); - ! the ILU(k) factorization otherwise. - ! m - integer, output. - ! The total number of rows of the local matrix to be factorized, - ! i.e. ma+mb. - ! a - type(psb_zspmat_type), input. - ! The sparse matrix structure containing the local matrix. - ! Note that, if the 'base' Additive Schwarz preconditioner - ! has overlap greater than 0 and the matrix has not been reordered - ! (see mld_fact_bld), then a contains only the 'original' local part - ! of the distributed matrix, i.e. the rows of the matrix held - ! by the calling process according to the initial data distribution. - ! b - type(psb_zspmat_type), input. - ! The sparse matrix structure containing the remote rows of the - ! distributed matrix, that have been retrieved by mld_as_bld - ! to build an Additive Schwarz base preconditioner with overlap - ! greater than 0. If the overlap is 0 or the matrix has been reordered - ! (see mld_fact_bld), then b does not contain any row. - ! d - complex(psb_dpk_), dimension(:), output. - ! The inverse of the diagonal entries of the U factor in the incomplete - ! factorization. - ! laspk - complex(psb_dpk_), dimension(:), input/output. - ! The L factor in the incomplete factorization. - ! lia1 - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the L factor, - ! according to the CSR storage format. - ! lia2 - integer, dimension(:), input/output. - ! The indices identifying the first nonzero entry of each row - ! of the L factor in laspk, according to the CSR storage format. - ! uval - complex(psb_dpk_), dimension(:), input/output. - ! The U factor in the incomplete factorization. - ! The entries of U are stored according to the CSR format. - ! uja - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the U factor, - ! according to the CSR storage format. - ! uirp - integer, dimension(:), input/output. - ! The indices identifying the first nonzero entry of each row - ! of the U factor in uval, according to the CSR storage format. - ! l1 - integer, output - ! The number of nonzero entries in laspk. - ! l2 - integer, output - ! The number of nonzero entries in uval. - ! info - integer, output. - ! Error code. - ! - subroutine mld_ziluk_factint(fill_in,ialg,a,b,& - & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info) - - use psb_base_mod - - implicit none - - ! Arguments - integer(psb_ipk_), intent(in) :: fill_in, ialg - type(psb_zspmat_type),intent(in) :: a,b - integer(psb_ipk_),intent(inout) :: l1,l2,info - integer(psb_ipk_), allocatable, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) - complex(psb_dpk_), allocatable, intent(inout) :: lval(:),uval(:) - complex(psb_dpk_), intent(inout) :: d(:) - - ! Local variables - integer(psb_ipk_) :: ma,mb,i, ktrw,err_act,nidx, m - integer(psb_ipk_), allocatable :: uplevs(:), rowlevs(:),idxs(:) - complex(psb_dpk_), allocatable :: row(:) - type(psb_i_heap) :: heap - type(psb_z_coo_sparse_mat) :: trw - character(len=20), parameter :: name='mld_ziluk_factint' - character(len=20) :: ch_err - - info=psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - - - select case(ialg) - case(mld_ilu_n_,mld_milu_n_) - ! Ok - case default - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,& - & i_err=(/itwo,ialg,izero,izero,izero/)) - goto 9999 - end select - if (fill_in < 0) then - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name, & - & i_err=(/ione,fill_in,izero,izero,izero/)) - goto 9999 - end if - - ma = a%get_nrows() - mb = b%get_nrows() - m = ma+mb - - ! - ! Allocate a temporary buffer for the iluk_copyin function - ! - - call trw%allocate(izero,izero,ione) - if (info == psb_success_) call psb_ensure_size(m+1,lirp,info) - if (info == psb_success_) call psb_ensure_size(m+1,uirp,info) - - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_sp_all') - goto 9999 - end if - - l1=0 - l2=0 - lirp(1) = 1 - uirp(1) = 1 - - ! - ! Allocate memory to hold the entries of a row and the corresponding - ! fill levels - ! - allocate(uplevs(size(uval)),rowlevs(m),row(m),stat=info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - - uplevs(:) = m+1 - row(:) = zzero - rowlevs(:) = -(m+1) - - ! - ! Cycle over the matrix rows - ! - do i = 1, m - - ! - ! At each iteration of the loop we keep in a heap the column indices - ! affected by the factorization. The heap is initialized and filled - ! in the iluk_copyin routine, and updated during the elimination, in - ! the iluk_fact routine. The heap is ideal because at each step we need - ! the lowest index, but we also need to insert new items, and the heap - ! allows to do both in log time. - ! - d(i) = zzero - if (i<=ma) then - ! - ! Copy into trw the i-th local row of the matrix, stored in a - ! - call iluk_copyin(i,ma,a,ione,m,row,rowlevs,heap,ktrw,trw,info) - else - ! - ! Copy into trw the i-th local row of the matrix, stored in b - ! (as (i-ma)-th row) - ! - call iluk_copyin(i-ma,mb,b,ione,m,row,rowlevs,heap,ktrw,trw,info) - endif - - ! Do an elimination step on the current row. It turns out we only - ! need to keep track of fill levels for the upper triangle, hence we - ! do not have a lowlevs variable. - ! - if (info == psb_success_) call iluk_fact(fill_in,i,row,rowlevs,heap,& - & d,uja,uirp,uval,uplevs,nidx,idxs,info) - ! - ! Copy the row into lval/d(i)/uval - ! - if (info == psb_success_) call iluk_copyout(fill_in,ialg,i,m,row,rowlevs,nidx,idxs,& - & l1,l2,lja,lirp,lval,d,uja,uirp,uval,uplevs,info) - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='Copy/factor loop') - goto 9999 - end if - end do - - ! - ! And we're done, so deallocate the memory - ! - deallocate(uplevs,rowlevs,row,stat=info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Deallocate') - goto 9999 - end if - if (info == psb_success_) call trw%free() - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine mld_ziluk_factint - - ! - ! Subroutine: iluk_copyin - ! Version: complex - ! Note: internal subroutine of mld_ziluk_fact - ! - ! This routine copies a row of a sparse matrix A, stored in the sparse matrix - ! structure a, into the array row and stores into a heap the column indices of - ! the nonzero entries of the copied row. The output array row is such that it - ! contains a full row of A, i.e. it contains also the zero entries of the row. - ! This is useful for the elimination step performed by iluk_fact after the call - ! to iluk_copyin (see mld_iluk_factint). - ! The routine also sets to zero the entries of the array rowlevs corresponding - ! to the nonzero entries of the copied row (see the description of the arguments - ! below). - ! - ! If the sparse matrix is in CSR format, a 'straight' copy is performed; - ! otherwise psb_sp_getblk is used to extract a block of rows, which is then - ! copied, row by row, into the array row, through successive calls to - ! ilu_copyin. - ! - ! This routine is used by mld_ziluk_factint in the computation of the - ! ILU(k)/MILU(k) factorization of a local sparse matrix. - ! - ! - ! Arguments: - ! i - integer, input. - ! The local index of the row to be extracted from the - ! sparse matrix structure a. - ! m - integer, input. - ! The number of rows of the local matrix stored into a. - ! a - type(psb_zspmat_type), input. - ! The sparse matrix structure containing the row to be copied. - ! jmin - integer, input. - ! The minimum valid column index. - ! jmax - integer, input. - ! The maximum valid column index. - ! The output matrix will contain a clipped copy taken from - ! a(1:m,jmin:jmax). - ! row - complex(psb_dpk_), dimension(:), input/output. - ! In input it is the null vector (see mld_iluk_factint and - ! iluk_copyout). In output it contains the row extracted - ! from the matrix A. It actually contains a full row, i.e. - ! it contains also the zero entries of the row. - ! rowlevs - integer, dimension(:), input/output. - ! In input rowlevs(k) = -(m+1) for k=1,...,m. In output - ! rowlevs(k) = 0 for 1 <= k <= jmax and A(i,k) /= 0, for - ! future use in iluk_fact. - ! heap - type(psb_i_heap), input/output. - ! The heap containing the column indices of the nonzero - ! entries in the array row. - ! Note: this argument is intent(inout) and not only intent(out) - ! to retain its allocation, done by psb_init_heap inside this - ! routine. - ! ktrw - integer, input/output. - ! The index identifying the last entry taken from the - ! staging buffer trw. See below. - ! trw - type(psb_zspmat_type), input/output. - ! A staging buffer. If the matrix A is not in CSR format, we use - ! the psb_sp_getblk routine and store its output in trw; when we - ! need to call psb_sp_getblk we do it for a block of rows, and then - ! we consume them from trw in successive calls to this routine, - ! until we empty the buffer. Thus we will make a call to psb_sp_getblk - ! every nrb calls to copyin. If A is in CSR format it is unused. - ! - subroutine iluk_copyin(i,m,a,jmin,jmax,row,rowlevs,heap,ktrw,trw,info) - - use psb_base_mod - - implicit none - - ! Arguments - type(psb_zspmat_type), intent(in) :: a - type(psb_z_coo_sparse_mat), intent(inout) :: trw - integer(psb_ipk_), intent(in) :: i,m,jmin,jmax - integer(psb_ipk_), intent(inout) :: ktrw,info - integer(psb_ipk_), intent(inout) :: rowlevs(:) - complex(psb_dpk_), intent(inout) :: row(:) - type(psb_i_heap), intent(inout) :: heap - - ! Local variables - integer(psb_ipk_) :: k,j,irb,err_act,nz - integer(psb_ipk_), parameter :: nrb=40 - character(len=20), parameter :: name='iluk_copyin' - character(len=20) :: ch_err - - info=psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - call heap%init(info) - - select type (aa=> a%a) - type is (psb_z_csr_sparse_mat) - ! - ! Take a fast shortcut if the matrix is stored in CSR format - ! - - do j = aa%irp(i), aa%irp(i+1) - 1 - k = aa%ja(j) - if ((jmin<=k).and.(k<=jmax)) then - row(k) = aa%val(j) - rowlevs(k) = 0 - call heap%insert(k,info) - end if - end do - - class default - - ! - ! Otherwise use psb_sp_getblk, slower but able (in principle) of - ! handling any format. In this case, a block of rows is extracted - ! instead of a single row, for performance reasons, and these - ! rows are copied one by one into the array row, through successive - ! calls to iluk_copyin. - ! - - if ((mod(i,nrb) == 1).or.(nrb == 1)) then - irb = min(m-i+1,nrb) - call aa%csget(i,i+irb-1,trw,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_getblk' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - ktrw=1 - end if - nz = trw%get_nzeros() - do - if (ktrw > nz) exit - if (trw%ia(ktrw) > i) exit - k = trw%ja(ktrw) - if ((jmin<=k).and.(k<=jmax)) then - row(k) = trw%val(ktrw) - rowlevs(k) = 0 - call heap%insert(k,info) - end if - ktrw = ktrw + 1 - enddo - end select - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine iluk_copyin - - ! - ! Subroutine: iluk_fact - ! Version: complex - ! Note: internal subroutine of mld_ziluk_fact - ! - ! This routine does an elimination step of the ILU(k) factorization on a - ! single matrix row (see the calling routine mld_iluk_factint). - ! - ! This step is also the base for a MILU(k) elimination step on the row (see - ! iluk_copyout). This routine is used by mld_ziluk_factint in the computation - ! of the ILU(k)/MILU(k) factorization of a local sparse matrix. - ! - ! NOTE: it turns out we only need to keep track of the fill levels for - ! the upper triangle. - ! - ! - ! Arguments - ! fill_in - integer, input. - ! The fill-in level k in ILU(k). - ! i - integer, input. - ! The local index of the row to which the factorization is - ! applied. - ! row - complex(psb_dpk_), dimension(:), input/output. - ! In input it contains the row to which the elimination step - ! has to be applied. In output it contains the row after the - ! elimination step. It actually contains a full row, i.e. - ! it contains also the zero entries of the row. - ! rowlevs - integer, dimension(:), input/output. - ! In input rowlevs(k) = 0 if the k-th entry of the row is - ! nonzero, and rowlevs(k) = -(m+1) otherwise. In output - ! rowlevs(k) contains the fill kevel of the k-th entry of - ! the row after the current elimination step; rowlevs(k) = -(m+1) - ! means that the k-th row entry is zero throughout the elimination - ! step. - ! heap - type(psb_i_heap), input/output. - ! The heap containing the column indices of the nonzero entries - ! in the processed row. In input it contains the indices concerning - ! the row before the elimination step, while in output it contains - ! the indices concerning the transformed row. - ! d - complex(psb_dpk_), input. - ! The inverse of the diagonal entries of the part of the U factor - ! above the current row (see iluk_copyout). - ! uja - integer, dimension(:), input. - ! The column indices of the nonzero entries of the part of the U - ! factor above the current row, stored in uval row by row (see - ! iluk_copyout, called by mld_ziluk_factint), according to the CSR - ! storage format. - ! uirp - integer, dimension(:), input. - ! The indices identifying the first nonzero entry of each row of - ! the U factor above the current row, stored in uval row by row - ! (see iluk_copyout, called by mld_ziluk_factint), according to - ! the CSR storage format. - ! uval - complex(psb_dpk_), dimension(:), input. - ! The entries of the U factor above the current row (except the - ! diagonal ones), stored according to the CSR format. - ! uplevs - integer, dimension(:), input. - ! The fill levels of the nonzero entries in the part of the - ! U factor above the current row. - ! nidx - integer, output. - ! The number of entries of the array row that have been - ! examined during the elimination step. This will be used - ! by the routine iluk_copyout. - ! idxs - integer, dimension(:), allocatable, input/output. - ! The indices of the entries of the array row that have been - ! examined during the elimination step.This will be used by - ! by the routine iluk_copyout. - ! Note: this argument is intent(inout) and not only intent(out) - ! to retain its allocation, done by this routine. - ! - subroutine iluk_fact(fill_in,i,row,rowlevs,heap,d,uja,uirp,uval,uplevs,nidx,idxs,info) - - use psb_base_mod - - implicit none - - ! Arguments - type(psb_i_heap), intent(inout) :: heap - integer(psb_ipk_), intent(in) :: i, fill_in - integer(psb_ipk_), intent(inout) :: nidx,info - integer(psb_ipk_), intent(inout) :: rowlevs(:) - integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) - integer(psb_ipk_), intent(inout) :: uja(:),uirp(:),uplevs(:) - complex(psb_dpk_), intent(inout) :: row(:), uval(:),d(:) - - ! Local variables - integer(psb_ipk_) :: k,j,lrwk,jj,lastk, iret - complex(psb_dpk_) :: rwk - - info = psb_success_ - if (.not.allocated(idxs)) then - allocate(idxs(200),stat=info) - if (info /= psb_success_) return - endif - nidx = 0 - lastk = -1 - - ! - ! Do while there are indices to be processed - ! - do - ! Beware: (iret < 0) means that the heap is empty, not an error. - call heap%get_first(k,iret) - if (iret < 0) return - - ! - ! Just in case an index has been put on the heap more than once. - ! - if (k == lastk) cycle - - lastk = k - nidx = nidx + 1 - if (nidx>size(idxs)) then - call psb_realloc(nidx+psb_heap_resize,idxs,info) - if (info /= psb_success_) return - end if - idxs(nidx) = k - - if ((row(k) /= zzero).and.(rowlevs(k) <= fill_in).and.(ki) then - ! - ! Copy the upper part of the row - ! - if (rowlevs(j) <= fill_in) then - l2 = l2 + 1 - if (size(uval) < l2) then - ! - ! Figure out a good reallocation size! - ! - isz = max((l2/i)*m,int(1.2*l2),l2+100) - call psb_realloc(isz,uval,info) - if (info == psb_success_) call psb_realloc(isz,uja,info) - if (info == psb_success_) call psb_realloc(isz,uplevs,info,pad=(m+1)) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - end if - uja(l2) = j - uval(l2) = row(j) - uplevs(l2) = rowlevs(j) - else if (ialg == mld_milu_n_) then - ! - ! MILU(k): add discarded entries to the diagonal one - ! - d(i) = d(i) + row(j) - end if - ! - ! Re-initialize row(j) and rowlevs(j) - ! - row(j) = zzero - rowlevs(j) = -(m+1) - end if - end do - - ! - ! Store the pointers to the first non occupied entry of in - ! lval and uval - ! - lirp(i+1) = l1 + 1 - uirp(i+1) = l2 + 1 - - ! - ! Check the pivot size - ! - if (abs(d(i)) < d_epstol) then - ! - ! Too small pivot: unstable factorization - ! - info = psb_err_pivot_too_small_ - int_err(1) = i - write(ch_err,'(g20.10)') d(i) - call psb_errpush(info,name,i_err=int_err,a_err=ch_err) - goto 9999 - else - ! - ! Compute 1/pivot - ! - d(i) = zone/d(i) - end if - - ! - ! Scale the upper part - ! - do j=uirp(i), uirp(i+1)-1 - uval(j) = d(i)*uval(j) - end do - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine iluk_copyout - - -end subroutine mld_ziluk_fact diff --git a/mlprec/impl/solver/mld_zilut_fact.f90 b/mlprec/impl/solver/mld_zilut_fact.f90 deleted file mode 100644 index 72a398cd..00000000 --- a/mlprec/impl/solver/mld_zilut_fact.f90 +++ /dev/null @@ -1,1186 +0,0 @@ -! -! -! MLD2P4 version 2.2 -! MultiLevel Domain Decomposition Parallel Preconditioners Package -! based on PSBLAS (Parallel Sparse BLAS version 3.5) -! -! (C) Copyright 2008-2018 -! -! Salvatore Filippone -! Pasqua D'Ambra -! Daniela di Serafino -! -! 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_zilut_fact.f90 -! -! Subroutine: mld_zilut_fact -! Version: complex -! Contains: mld_zilut_factint, ilut_copyin, ilut_fact, ilut_copyout -! -! This routine computes the ILU(k,t) factorization of the diagonal blocks -! of a distributed matrix. This factorization is used to build the 'base -! preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz -! preconditioner) corresponding to a certain level of a multilevel preconditioner. -! -! Details on the above factorization can be found in -! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, -! SIAM, 2003, Chapter 10. -! -! The local matrix is stored into a and blck, as specified in the description -! of the arguments below. The storage format for both the L and U factors is -! CSR. The diagonal of the U factor is stored separately (actually, the -! inverse of the diagonal entries is stored; this is then managed in the -! solve stage associated to the ILU(k,t) factorization). -! -! -! Arguments: -! fill_in - integer, input. -! The fill-in parameter k in ILU(k,t). -! thres - real, input. -! The threshold t, i.e. the drop tolerance, in ILU(k,t). -! a - type(psb_zspmat_type), input. -! The sparse matrix structure containing the local matrix. -! Note that if the 'base' Additive Schwarz preconditioner -! has overlap greater than 0 and the matrix has not been reordered -! (see mld_fact_bld), then a contains only the 'original' local part -! of the distributed matrix, i.e. the rows of the matrix held -! by the calling process according to the initial data distribution. -! l - type(psb_zspmat_type), input/output. -! The L factor in the incomplete factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! u - type(psb_zspmat_type), input/output. -! The U factor (except its diagonal) in the incomplete factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! d - complex(psb_dpk_), dimension(:), input/output. -! The inverse of the diagonal entries of the U factor in the incomplete -! factorization. -! Note: its allocation is managed by the calling routine mld_ilu_bld, -! hence it cannot be only intent(out). -! info - integer, output. -! Error code. -! blck - type(psb_zspmat_type), input, optional, target. -! The sparse matrix structure containing the remote rows of the -! distributed matrix, that have been retrieved by mld_as_bld -! to build an Additive Schwarz base preconditioner with overlap -! greater than 0. If the overlap is 0 or the matrix has been reordered -! (see mld_fact_bld), then blck does not contain any row. -! -subroutine mld_zilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) - - use psb_base_mod - use mld_z_ilu_fact_mod, mld_protect_name => mld_zilut_fact - - implicit none - - ! Arguments - integer(psb_ipk_), intent(in) :: fill_in - real(psb_dpk_), intent(in) :: thres - integer(psb_ipk_), intent(out) :: info - type(psb_zspmat_type),intent(in) :: a - type(psb_zspmat_type),intent(inout) :: l,u - complex(psb_dpk_), intent(inout) :: d(:) - type(psb_zspmat_type),intent(in), optional, target :: blck - integer(psb_ipk_), intent(in), optional :: iscale - ! Local Variables - integer(psb_ipk_) :: l1, l2, m, err_act, iscale_ - - type(psb_zspmat_type), pointer :: blck_ - type(psb_z_csr_sparse_mat) :: ll, uu - real(psb_dpk_) :: scale - character(len=20) :: name, ch_err - - name='mld_zilut_fact' - info = psb_success_ - call psb_erractionsave(err_act) - - if (fill_in < 0) then - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name, & - & i_err=(/ione,fill_in,izero,izero,izero/)) - goto 9999 - end if - ! - ! Point to / allocate memory for the incomplete factorization - ! - if (present(blck)) then - blck_ => blck - else - allocate(blck_,stat=info) - if (info == psb_success_) call blck_%csall(izero,izero,info,ione) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='csall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - if (present(iscale)) then - iscale_ = iscale - else - iscale_ = mld_ilu_scale_none_ - end if - - select case(iscale_) - case(mld_ilu_scale_none_) - scale = sone - case(mld_ilu_scale_maxval_) - scale = max(a%maxval(),blck_%maxval()) - scale = sone/scale - case default - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,i_err=(/ione*9,iscale_,izero,izero,izero/)) - goto 9999 - end select - - m = a%get_nrows() + blck_%get_nrows() - if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& - & (m > size(d)) ) then - write(0,*) 'Wrong allocation status for L,D,U? ',& - & l%get_nrows(),size(d),u%get_nrows() - info = -1 - return - end if - - call l%mv_to(ll) - call u%mv_to(uu) - - ! - ! Compute the ILU(k,t) factorization - ! - call mld_zilut_factint(fill_in,thres,a,blck_,& - & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info,scale) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_zilut_factint' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - ! - ! Store information on the L and U sparse matrices - ! - call l%mv_from(ll) - call l%set_triangle() - call l%set_unit() - call l%set_lower() - call u%mv_from(uu) - call u%set_triangle() - call u%set_unit() - call u%set_upper() - - ! - ! Nullify pointer / deallocate memory - ! - if (present(blck)) then - blck_ => null() - else - call blck_%free() - deallocate(blck_,stat=info) - if(info.ne.0) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - -contains - - ! - ! Subroutine: mld_zilut_factint - ! Version: complex - ! Note: internal subroutine of mld_zilut_fact - ! - ! This routine computes the ILU(k,t) factorization of the diagonal blocks of a - ! distributed matrix. This factorization is used to build the 'base - ! preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz - ! preconditioner) corresponding to a certain level of a multilevel preconditioner. - ! - ! The local matrix to be factorized is stored into a and b, as specified in the - ! description of the arguments below. The storage format for both the L and U - ! factors is CSR. The diagonal of the U factor is stored separately (actually, - ! the inverse of the diagonal entries is stored; this is then managed in the - ! solve stage associated to the ILU(k,t) factorization). - ! - ! - ! Arguments: - ! fill_in - integer, input. - ! The fill-in parameter k in ILU(k,t). - ! thres - real, input. - ! The threshold t, i.e. the drop tolerance, in ILU(k,t). - ! m - integer, output. - ! The total number of rows of the local matrix to be factorized, - ! i.e. ma+mb. - ! a - type(psb_zspmat_type), input. - ! The sparse matrix structure containing the local matrix. - ! Note that, if the 'base' Additive Schwarz preconditioner - ! has overlap greater than 0 and the matrix has not been reordered - ! (see mld_fact_bld), then a contains only the 'original' local part - ! of the distributed matrix, i.e. the rows of the matrix held - ! by the calling process according to the initial data distribution. - ! b - type(psb_zspmat_type), input. - ! The sparse matrix structure containing the remote rows of the - ! distributed matrix, that have been retrieved by mld_as_bld - ! to build an Additive Schwarz base preconditioner with overlap - ! greater than 0. If the overlap is 0 or the matrix has been reordered - ! (see mld_fact_bld), then b does not contain any row. - ! d - complex(psb_dpk_), dimension(:), output. - ! The inverse of the diagonal entries of the U factor in the incomplete - ! factorization. - ! lval - complex(psb_dpk_), dimension(:), input/output. - ! The L factor in the incomplete factorization. - ! lia1 - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the L factor, - ! according to the CSR storage format. - ! lirp - integer, dimension(:), input/output. - ! The indices identifying the first nonzero entry of each row - ! of the L factor in lval, according to the CSR storage format. - ! uval - complex(psb_dpk_), dimension(:), input/output. - ! The U factor in the incomplete factorization. - ! The entries of U are stored according to the CSR format. - ! uja - integer, dimension(:), input/output. - ! The column indices of the nonzero entries of the U factor, - ! according to the CSR storage format. - ! uirp - integer, dimension(:), input/output. - ! The indices identifying the first nonzero entry of each row - ! of the U factor in uval, according to the CSR storage format. - ! l1 - integer, output - ! The number of nonzero entries in lval. - ! l2 - integer, output - ! The number of nonzero entries in uval. - ! info - integer, output. - ! Error code. - ! - subroutine mld_zilut_factint(fill_in,thres,a,b,& - & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info,scale) - - use psb_base_mod - - implicit none - - ! Arguments - integer(psb_ipk_), intent(in) :: fill_in - real(psb_dpk_), intent(in) :: thres - type(psb_zspmat_type),intent(in) :: a,b - integer(psb_ipk_),intent(inout) :: l1,l2,info - integer(psb_ipk_), allocatable, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) - complex(psb_dpk_), allocatable, intent(inout) :: lval(:),uval(:) - complex(psb_dpk_), intent(inout) :: d(:) - real(psb_dpk_), intent(in), optional :: scale - - ! Local Variables - integer(psb_ipk_) :: i, ktrw,err_act,nidx,nlw,nup,jmaxup, ma, mb, m - real(psb_dpk_) :: nrmi - real(psb_dpk_) :: weight - integer(psb_ipk_), allocatable :: idxs(:) - complex(psb_dpk_), allocatable :: row(:) - type(psb_i_heap) :: heap - type(psb_z_coo_sparse_mat) :: trw - character(len=20), parameter :: name='mld_zilut_factint' - character(len=20) :: ch_err - - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - - - ma = a%get_nrows() - mb = b%get_nrows() - m = ma+mb - - ! - ! Allocate a temporary buffer for the ilut_copyin function - ! - call trw%allocate(izero,izero,ione) - if (info == psb_success_) call psb_ensure_size(m+1,lirp,info) - if (info == psb_success_) call psb_ensure_size(m+1,uirp,info) - - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_sp_all') - goto 9999 - end if - - l1=0 - l2=0 - lirp(1) = 1 - uirp(1) = 1 - - ! - ! Allocate memory to hold the entries of a row - ! - allocate(row(m),stat=info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - - row(:) = czero - weight = sone - if (present(scale)) weight = abs(scale) - ! - ! Cycle over the matrix rows - ! - do i = 1, m - - ! - ! At each iteration of the loop we keep in a heap the column indices - ! affected by the factorization. The heap is initialized and filled - ! in the ilut_copyin function, and updated during the elimination, in - ! the ilut_fact routine. The heap is ideal because at each step we need - ! the lowest index, but we also need to insert new items, and the heap - ! allows to do both in log time. - ! - d(i) = czero - if (i<=ma) then - call ilut_copyin(i,ma,a,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& - & row,heap,ktrw,trw,info) - else - call ilut_copyin(i-ma,mb,b,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& - & row,heap,ktrw,trw,info) - endif - - ! - ! Do an elimination step on current row - ! - if (info == psb_success_) call ilut_fact(thres,i,nrmi,row,heap,& - & d,uja,uirp,uval,nidx,idxs,info) - ! - ! Copy the row into lval/d(i)/uval - ! - if (info == psb_success_) call ilut_copyout(fill_in,thres,i,m,& - & nlw,nup,jmaxup,nrmi,row,nidx,idxs,& - & l1,l2,lja,lirp,lval,d,uja,uirp,uval,info) - - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='Copy/factor loop') - goto 9999 - end if - - end do - ! - ! Adjust diagonal accounting for scale factor - ! - if (weight /= sone) then - d(1:m) = d(1:m)*weight - end if - - ! - ! And we're sone, so deallocate the memory - ! - deallocate(row,idxs,stat=info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Deallocate') - goto 9999 - end if - if (info == psb_success_) call trw%free() - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine mld_zilut_factint - - ! - ! Subroutine: ilut_copyin - ! Version: complex - ! Note: internal subroutine of mld_zilut_fact - ! - ! This routine performs the following tasks: - ! - copying a row of a sparse matrix A, stored in the sparse matrix structure a, - ! into the array row; - ! - storing into a heap the column indices of the nonzero entries of the copied - ! row; - ! - computing the column index of the first entry with maximum absolute value - ! in the part of the row belonging to the upper triangle; - ! - computing the 2-norm of the row. - ! The output array row is such that it contains a full row of A, i.e. it contains - ! also the zero entries of the row. This is useful for the elimination step - ! performed by ilut_fact after the call to ilut_copyin (see mld_ilut_factint). - ! - ! If the sparse matrix is in CSR format, a 'straight' copy is performed; - ! otherwise psb_sp_getblk is used to extract a block of rows, which is then - ! copied, row by row, into the array row, through successive calls to - ! ilut_copyin. - ! - ! This routine is used by mld_zilut_factint in the computation of the ILU(k,t) - ! factorization of a local sparse matrix. - ! - ! - ! Arguments: - ! i - integer, input. - ! The local index of the row to be extracted from the - ! sparse matrix structure a. - ! m - integer, input. - ! The number of rows of the local matrix stored into a. - ! a - type(psb_zspmat_type), input. - ! The sparse matrix structure containing the row to be - ! copied. - ! jd - integer, input. - ! The column index of the diagonal entry of the row to be - ! copied. - ! jmin - integer, input. - ! The minimum valid column index. - ! jmax - integer, input. - ! The maximum valid column index. - ! The output matrix will contain a clipped copy taken from - ! a(1:m,jmin:jmax). - ! nlw - integer, output. - ! The number of nonzero entries in the part of the row - ! belonging to the lower triangle of the matrix. - ! nup - integer, output. - ! The number of nonzero entries in the part of the row - ! belonging to the upper triangle of the matrix. - ! jmaxup - integer, output. - ! The column index of the first entry with maximum absolute - ! value in the part of the row belonging to the upper triangle - ! nrmi - real(psb_dpk_), output. - ! The 2-norm of the current row. - ! row - complex(psb_dpk_), dimension(:), input/output. - ! In input it is the null vector (see mld_ilut_factint and - ! ilut_copyout). In output it contains the row extracted - ! from the matrix A. It actually contains a full row, i.e. - ! it contains also the zero entries of the row. - ! rowlevs - integer, dimension(:), input/output. - ! In input rowlevs(k) = -(m+1) for k=1,...,m. In output - ! rowlevs(k) = 0 for 1 <= k <= jmax and A(i,k) /= 0, for - ! future use in ilut_fact. - ! heap - type(psb_int_heap), input/output. - ! The heap containing the column indices of the nonzero - ! entries in the array row. - ! Note: this argument is intent(inout) and not only intent(out) - ! to retain its allocation, sone by psb_init_heap inside this - ! routine. - ! ktrw - integer, input/output. - ! The index identifying the last entry taken from the - ! staging buffer trw. See below. - ! trw - type(psb_zspmat_type), input/output. - ! A staging buffer. If the matrix A is not in CSR format, we use - ! the psb_sp_getblk routine and store its output in trw; when we - ! need to call psb_sp_getblk we do it for a block of rows, and then - ! we consume them from trw in successive calls to this routine, - ! until we empty the buffer. Thus we will make a call to psb_sp_getblk - ! every nrb calls to copyin. If A is in CSR format it is unused. - ! - subroutine ilut_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,& - & nrmi,weight,row,heap,ktrw,trw,info) - use psb_base_mod - implicit none - type(psb_zspmat_type), intent(in) :: a - type(psb_z_coo_sparse_mat), intent(inout) :: trw - integer(psb_ipk_), intent(in) :: i, m,jmin,jmax,jd - integer(psb_ipk_), intent(inout) :: ktrw,nlw,nup,jmaxup,info - real(psb_dpk_), intent(inout) :: nrmi - complex(psb_dpk_), intent(inout) :: row(:) - real(psb_dpk_), intent(in) :: weight - type(psb_i_heap), intent(inout) :: heap - - integer(psb_ipk_) :: k,j,irb,kin,nz - integer(psb_ipk_), parameter :: nrb=40 - real(psb_dpk_) :: dmaxup - real(psb_dpk_), external :: dnrm2 - character(len=20), parameter :: name='mld_zilut_factint' - - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - - call heap%init(info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_init_heap') - goto 9999 - end if - - ! - ! nrmi is the norm of the current sparse row (for the time being, - ! we use the 2-norm). - ! NOTE: the 2-norm below includes also elements that are outside - ! [jmin:jmax] strictly. Is this really important? TO BE CHECKED. - ! - - nlw = 0 - nup = 0 - jmaxup = 0 - dmaxup = szero - nrmi = szero - - select type (aa=> a%a) - type is (psb_z_csr_sparse_mat) - ! - ! Take a fast shortcut if the matrix is stored in CSR format - ! - - do j = aa%irp(i), aa%irp(i+1) - 1 - k = aa%ja(j) - if ((jmin<=k).and.(k<=jmax)) then - row(k) = aa%val(j)*weight - call heap%insert(k,info) - if (info /= psb_success_) exit - if (kjd) then - nup = nup + 1 - if (abs(row(k))>dmaxup) then - jmaxup = k - dmaxup = abs(row(k)) - end if - end if - end if - end do - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_insert_heap') - goto 9999 - end if - - nz = aa%irp(i+1) - aa%irp(i) - nrmi = weight*dnrm2(nz,aa%val(aa%irp(i)),ione) - - - class default - - ! - ! Otherwise use psb_sp_getblk, slower but able (in principle) of - ! handling any format. In this case, a block of rows is extracted - ! instead of a single row, for performance reasons, and these - ! rows are copied one by one into the array row, through successive - ! calls to ilut_copyin. - ! - - if ((mod(i,nrb) == 1).or.(nrb == 1)) then - irb = min(m-i+1,nrb) - call aa%csget(i,i+irb-1,trw,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_sp_getblk') - goto 9999 - end if - ktrw=1 - end if - - kin = ktrw - nz = trw%get_nzeros() - do - if (ktrw > nz) exit - if (trw%ia(ktrw) > i) exit - k = trw%ja(ktrw) - if ((jmin<=k).and.(k<=jmax)) then - row(k) = trw%val(ktrw)*weight - call heap%insert(k,info) - if (info /= psb_success_) exit - if (kjd) then - nup = nup + 1 - if (abs(row(k))>dmaxup) then - jmaxup = k - dmaxup = abs(row(k)) - end if - end if - end if - ktrw = ktrw + 1 - enddo - nz = ktrw - kin - nrmi = weight*dnrm2(nz,trw%val(kin),ione) - end select - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine ilut_copyin - - ! - ! Subroutine: ilut_fact - ! Version: complex - ! Note: internal subroutine of mld_zilut_fact - ! - ! This routine does an elimination step of the ILU(k,t) factorization on a single - ! matrix row (see the calling routine mld_ilut_factint). Actually, only the dropping - ! rule based on the threshold is applied here. The dropping rule based on the - ! fill-in is applied by ilut_copyout. - ! - ! The routine is used by mld_zilut_factint in the computation of the ILU(k,t) - ! factorization of a local sparse matrix. - ! - ! - ! Arguments - ! thres - real, input. - ! The threshold t, i.e. the drop tolerance, in ILU(k,t). - ! i - integer, input. - ! The local index of the row to which the factorization is applied. - ! nrmi - real(psb_dpk_), input. - ! The 2-norm of the row to which the elimination step has to be - ! applied. - ! row - complex(psb_dpk_), dimension(:), input/output. - ! In input it contains the row to which the elimination step - ! has to be applied. In output it contains the row after the - ! elimination step. It actually contains a full row, i.e. - ! it contains also the zero entries of the row. - ! heap - type(psb_i_heap), input/output. - ! The heap containing the column indices of the nonzero entries - ! in the processed row. In input it contains the indices concerning - ! the row before the elimination step, while in output it contains - ! the previous indices plus the ones corresponding to transformed - ! entries in the 'upper part' that have not been dropped. - ! d - complex(psb_dpk_), input. - ! The inverse of the diagonal entries of the part of the U factor - ! above the current row (see ilut_copyout). - ! uja - integer, dimension(:), input. - ! The column indices of the nonzero entries of the part of the U - ! factor above the current row, stored in uval row by row (see - ! ilut_copyout, called by mld_zilut_factint), according to the CSR - ! storage format. - ! uirp - integer, dimension(:), input. - ! The indices identifying the first nonzero entry of each row of - ! the U factor above the current row, stored in uval row by row - ! (see ilut_copyout, called by mld_zilut_factint), according to - ! the CSR storage format. - ! uval - complex(psb_dpk_), dimension(:), input. - ! The entries of the U factor above the current row (except the - ! diagonal ones), stored according to the CSR format. - ! nidx - integer, output. - ! The number of entries of the array row that have been - ! examined during the elimination step. This will be used - ! by the routine ilut_copyout. - ! idxs - integer, dimension(:), allocatable, input/output. - ! The indices of the entries of the array row that have been - ! examined during the elimination step.This will be used by - ! by the routine ilut_copyout. - ! Note: this argument is intent(inout) and not only intent(out) - ! to retain its allocation, sone by this routine. - ! - subroutine ilut_fact(thres,i,nrmi,row,heap,d,uja,uirp,uval,nidx,idxs,info) - - use psb_base_mod - - implicit none - - ! Arguments - type(psb_i_heap), intent(inout) :: heap - integer(psb_ipk_), intent(in) :: i - integer(psb_ipk_), intent(inout) :: nidx,info - real(psb_dpk_), intent(in) :: thres,nrmi - integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) - integer(psb_ipk_), intent(inout) :: uja(:),uirp(:) - complex(psb_dpk_), intent(inout) :: row(:), uval(:),d(:) - - ! Local Variables - integer(psb_ipk_) :: k,j,jj,lastk,iret - complex(psb_dpk_) :: rwk - - info = psb_success_ - call psb_ensure_size(200*ione,idxs,info) - if (info /= psb_success_) return - nidx = 0 - lastk = -1 - ! - ! Do while there are indices to be processed - ! - do - - call heap%get_first(k,iret) - if (iret < 0) exit - - ! - ! An index may have been put on the heap more than once. - ! - if (k == lastk) cycle - - lastk = k - lowert: if (k nidx) exit - if (idxs(idxp) >= i) exit - widx = idxs(idxp) - witem = row(widx) - ! - ! Dropping rule based on the 2-norm - ! - if (abs(witem) < thres*nrmi) cycle - - nz = nz + 1 - xw(nz) = witem - xwid(nz) = widx - call heap%insert(witem,widx,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_insert_heap') - goto 9999 - end if - end do - - ! - ! Now we have to take out the first nlw+fill_in entries - ! - if (nz <= nlw+fill_in) then - ! - ! Just copy everything from xw, and it is already ordered - ! - else - nz = nlw+fill_in - do k=1,nz - call heap%get_first(witem,widx,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_heap_get_first') - goto 9999 - end if - - xw(k) = witem - xwid(k) = widx - end do - end if - - ! - ! Now put things back into ascending column order - ! - call psb_msort(xwid(1:nz),indx(1:nz),dir=psb_sort_up_) - - ! - ! Copy out the lower part of the row - ! - do k=1,nz - l1 = l1 + 1 - if (size(lval) < l1) then - ! - ! Figure out a good reallocation size! - ! - isz = (max((l1/i)*m,int(1.2*l1),l1+100)) - call psb_realloc(isz,lval,info) - if (info == psb_success_) call psb_realloc(isz,lja,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - end if - lja(l1) = xwid(k) - lval(l1) = xw(indx(k)) - end do - - ! - ! Make sure idxp points to the diagonal entry - ! - if (idxp <= size(idxs)) then - if (idxs(idxp) < i) then - do - idxp = idxp + 1 - if (idxp > nidx) exit - if (idxs(idxp) >= i) exit - end do - end if - end if - if (idxp > size(idxs)) then -!!$ write(0,*) 'Warning: missing diagonal element in the row ' - else - if (idxs(idxp) > i) then -!!$ write(0,*) 'Warning: missing diagonal element in the row ' - else if (idxs(idxp) /= i) then -!!$ write(0,*) 'Warning: impossible error: diagonal has vanished' - else - ! - ! Copy the diagonal entry - ! - widx = idxs(idxp) - witem = row(widx) - d(i) = witem - if (abs(d(i)) < d_epstol) then - ! - ! Too small pivot: unstable factorization - ! - info = psb_err_pivot_too_small_ - int_err(1) = i - write(ch_err,'(g20.10)') d(i) - call psb_errpush(info,name,i_err=int_err,a_err=ch_err) - goto 9999 - else - ! - ! Compute 1/pivot - ! - d(i) = cone/d(i) - end if - end if - end if - - ! - ! Now the upper part - ! - - call heap%init(info,dir=psb_asort_down_) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_init_heap') - goto 9999 - end if - - nz = 0 - do - - idxp = idxp + 1 - if (idxp > nidx) exit - widx = idxs(idxp) - if (widx <= i) then -!!$ write(0,*) 'Warning: lower triangle in upper copy',widx,i,idxp,idxs(idxp) - cycle - end if - if (widx > m) then -!!$ write(0,*) 'Warning: impossible value',widx,i,idxp,idxs(idxp) - cycle - end if - witem = row(widx) - ! - ! Dropping rule based on the 2-norm. But keep the jmaxup-th entry anyway. - ! - if ((widx /= jmaxup) .and. (abs(witem) < thres*nrmi)) then - cycle - end if - - nz = nz + 1 - xw(nz) = witem - xwid(nz) = widx - call heap%insert(witem,widx,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_insert_heap') - goto 9999 - end if - - end do - - ! - ! Now we have to take out the first nup-fill_in entries. But make sure - ! we include entry jmaxup. - ! - if (nz <= nup+fill_in) then - ! - ! Just copy everything from xw - ! - fndmaxup=.true. - else - fndmaxup = .false. - nz = nup+fill_in - do k=1,nz - call heap%get_first(witem,widx,info) - xw(k) = witem - xwid(k) = widx - if (widx == jmaxup) fndmaxup=.true. - end do - end if - if ((i c_mumps_solver_get_fmt procedure, nopass :: get_id => c_mumps_solver_get_id procedure, pass(sv) :: is_global => c_mumps_solver_is_global -#if defined(HAVE_FINAL) final :: c_mumps_solver_finalize -#endif end type mld_c_mumps_solver_type @@ -114,9 +112,7 @@ module mld_c_mumps_solver & c_mumps_solver_default, c_mumps_solver_get_fmt, & & c_mumps_solver_clone_settings, & & c_mumps_solver_get_id, c_mumps_solver_is_global -#if defined(HAVE_FINAL) private :: c_mumps_solver_finalize -#endif interface subroutine c_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& @@ -301,7 +297,6 @@ contains #endif end subroutine c_mumps_solver_free -#if defined(HAVE_FINAL) subroutine c_mumps_solver_finalize(sv) Implicit None @@ -317,7 +312,6 @@ subroutine c_mumps_solver_finalize(sv) return end subroutine c_mumps_solver_finalize -#endif subroutine c_mumps_solver_descr(sv,info,iout,coarse) diff --git a/mlprec/mld_c_slu_solver.F90 b/mlprec/mld_c_slu_solver.F90 index 5f324d96..48780b82 100644 --- a/mlprec/mld_c_slu_solver.F90 +++ b/mlprec/mld_c_slu_solver.F90 @@ -72,9 +72,7 @@ module mld_c_slu_solver procedure, pass(sv) :: sizeof => c_slu_solver_sizeof procedure, nopass :: get_fmt => c_slu_solver_get_fmt procedure, nopass :: get_id => c_slu_solver_get_id -#if defined(HAVE_FINAL) final :: c_slu_solver_finalize -#endif end type mld_c_slu_solver_type @@ -83,9 +81,7 @@ module mld_c_slu_solver & c_slu_solver_sizeof, c_slu_solver_apply_vect, & & c_slu_solver_get_fmt, c_slu_solver_get_id, & & c_slu_solver_clear_data -#if defined(HAVE_FINAL) private :: c_slu_solver_finalize -#endif @@ -371,7 +367,6 @@ contains return end subroutine c_slu_solver_clear_data -#if defined(HAVE_FINAL) subroutine c_slu_solver_finalize(sv) Implicit None @@ -387,7 +382,6 @@ contains return end subroutine c_slu_solver_finalize -#endif subroutine c_slu_solver_descr(sv,info,iout,coarse) diff --git a/mlprec/mld_d_ilu_solver.f90 b/mlprec/mld_d_ilu_solver.f90 index 026e676f..2ef71e30 100644 --- a/mlprec/mld_d_ilu_solver.f90 +++ b/mlprec/mld_d_ilu_solver.f90 @@ -58,7 +58,7 @@ module mld_d_ilu_solver use mld_base_prec_type, only : mld_fact_names use mld_d_base_solver_mod - use mld_d_ilu_fact_mod + use psb_d_ilu_fact_mod type, extends(mld_d_base_solver_type) :: mld_d_ilu_solver_type type(psb_dspmat_type) :: l, u @@ -234,7 +234,7 @@ contains ! Arguments class(mld_d_ilu_solver_type), intent(inout) :: sv - sv%fact_type = mld_ilu_n_ + sv%fact_type = psb_ilu_n_ sv%fill_in = 0 sv%thresh = dzero @@ -255,13 +255,13 @@ contains info = psb_success_ call mld_check_def(sv%fact_type,& - & 'Factorization',mld_ilu_n_,is_legal_ilu_fact) + & 'Factorization',psb_ilu_n_,is_legal_ilu_fact) select case(sv%fact_type) - case(mld_ilu_n_,mld_milu_n_) + case(psb_ilu_n_,psb_milu_n_) call mld_check_def(sv%fill_in,& & 'Level',izero,is_int_non_negative) - case(mld_ilu_t_) + case(psb_ilu_t_) call mld_check_def(sv%thresh,& & 'Eps',dzero,is_legal_d_fact_thrs) end select @@ -432,9 +432,9 @@ contains write(iout_,*) ' Incomplete factorization solver: ',& & mld_fact_names(sv%fact_type) select case(sv%fact_type) - case(mld_ilu_n_,mld_milu_n_) + case(psb_ilu_n_,psb_milu_n_) write(iout_,*) ' Fill level:',sv%fill_in - case(mld_ilu_t_) + case(psb_ilu_t_) write(iout_,*) ' Fill level:',sv%fill_in write(iout_,*) ' Fill threshold :',sv%thresh end select @@ -489,7 +489,7 @@ contains implicit none integer(psb_ipk_) :: val - val = mld_ilu_n_ + val = psb_ilu_n_ end function d_ilu_solver_get_id function d_ilu_solver_get_wrksize() result(val) diff --git a/mlprec/mld_d_mumps_solver.F90 b/mlprec/mld_d_mumps_solver.F90 index 62097154..d2a3a655 100644 --- a/mlprec/mld_d_mumps_solver.F90 +++ b/mlprec/mld_d_mumps_solver.F90 @@ -100,9 +100,7 @@ module mld_d_mumps_solver procedure, nopass :: get_fmt => d_mumps_solver_get_fmt procedure, nopass :: get_id => d_mumps_solver_get_id procedure, pass(sv) :: is_global => d_mumps_solver_is_global -#if defined(HAVE_FINAL) final :: d_mumps_solver_finalize -#endif end type mld_d_mumps_solver_type @@ -114,9 +112,7 @@ module mld_d_mumps_solver & d_mumps_solver_default, d_mumps_solver_get_fmt, & & d_mumps_solver_clone_settings, & & d_mumps_solver_get_id, d_mumps_solver_is_global -#if defined(HAVE_FINAL) private :: d_mumps_solver_finalize -#endif interface subroutine d_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& @@ -301,7 +297,6 @@ contains #endif end subroutine d_mumps_solver_free -#if defined(HAVE_FINAL) subroutine d_mumps_solver_finalize(sv) Implicit None @@ -317,7 +312,6 @@ subroutine d_mumps_solver_finalize(sv) return end subroutine d_mumps_solver_finalize -#endif subroutine d_mumps_solver_descr(sv,info,iout,coarse) diff --git a/mlprec/mld_d_slu_solver.F90 b/mlprec/mld_d_slu_solver.F90 index e203ca8d..89dbc94b 100644 --- a/mlprec/mld_d_slu_solver.F90 +++ b/mlprec/mld_d_slu_solver.F90 @@ -72,9 +72,7 @@ module mld_d_slu_solver procedure, pass(sv) :: sizeof => d_slu_solver_sizeof procedure, nopass :: get_fmt => d_slu_solver_get_fmt procedure, nopass :: get_id => d_slu_solver_get_id -#if defined(HAVE_FINAL) final :: d_slu_solver_finalize -#endif end type mld_d_slu_solver_type @@ -83,9 +81,7 @@ module mld_d_slu_solver & d_slu_solver_sizeof, d_slu_solver_apply_vect, & & d_slu_solver_get_fmt, d_slu_solver_get_id, & & d_slu_solver_clear_data -#if defined(HAVE_FINAL) private :: d_slu_solver_finalize -#endif @@ -371,7 +367,6 @@ contains return end subroutine d_slu_solver_clear_data -#if defined(HAVE_FINAL) subroutine d_slu_solver_finalize(sv) Implicit None @@ -387,7 +382,6 @@ contains return end subroutine d_slu_solver_finalize -#endif subroutine d_slu_solver_descr(sv,info,iout,coarse) diff --git a/mlprec/mld_d_sludist_solver.F90 b/mlprec/mld_d_sludist_solver.F90 index 74328f5b..89f7ca97 100644 --- a/mlprec/mld_d_sludist_solver.F90 +++ b/mlprec/mld_d_sludist_solver.F90 @@ -72,9 +72,7 @@ module mld_d_sludist_solver procedure, nopass :: get_fmt => d_sludist_solver_get_fmt procedure, nopass :: get_id => d_sludist_solver_get_id procedure, pass(sv) :: is_global => d_sludist_solver_is_global -#if defined(HAVE_FINAL) final :: d_sludist_solver_finalize -#endif end type mld_d_sludist_solver_type @@ -83,9 +81,7 @@ module mld_d_sludist_solver & d_sludist_solver_sizeof, d_sludist_solver_apply_vect, & & d_sludist_solver_get_fmt, d_sludist_solver_get_id, & & d_sludist_solver_is_global, d_sludist_solver_clear_data -#if defined(HAVE_FINAL) private :: d_sludist_solver_finalize -#endif interface @@ -389,7 +385,6 @@ contains val = .true. end function d_sludist_solver_is_global -#if defined(HAVE_FINAL) subroutine d_sludist_solver_finalize(sv) Implicit None @@ -405,7 +400,6 @@ contains return end subroutine d_sludist_solver_finalize -#endif subroutine d_sludist_solver_descr(sv,info,iout,coarse) diff --git a/mlprec/mld_d_umf_solver.F90 b/mlprec/mld_d_umf_solver.F90 index 13e3824c..cb018aa2 100644 --- a/mlprec/mld_d_umf_solver.F90 +++ b/mlprec/mld_d_umf_solver.F90 @@ -71,9 +71,7 @@ module mld_d_umf_solver procedure, pass(sv) :: sizeof => d_umf_solver_sizeof procedure, nopass :: get_fmt => d_umf_solver_get_fmt procedure, nopass :: get_id => d_umf_solver_get_id -#if defined(HAVE_FINAL) final :: d_umf_solver_finalize -#endif end type mld_d_umf_solver_type @@ -82,9 +80,7 @@ module mld_d_umf_solver & d_umf_solver_sizeof, d_umf_solver_apply_vect, & & d_umf_solver_get_fmt, d_umf_solver_get_id, & & d_umf_solver_clear_data -#if defined(HAVE_FINAL) private :: d_umf_solver_finalize -#endif @@ -377,7 +373,6 @@ contains return end subroutine d_umf_solver_clear_data -#if defined(HAVE_FINAL) subroutine d_umf_solver_finalize(sv) Implicit None @@ -393,7 +388,6 @@ contains return end subroutine d_umf_solver_finalize -#endif subroutine d_umf_solver_descr(sv,info,iout,coarse) diff --git a/mlprec/mld_s_ilu_solver.f90 b/mlprec/mld_s_ilu_solver.f90 index b785ce04..051af244 100644 --- a/mlprec/mld_s_ilu_solver.f90 +++ b/mlprec/mld_s_ilu_solver.f90 @@ -58,7 +58,7 @@ module mld_s_ilu_solver use mld_base_prec_type, only : mld_fact_names use mld_s_base_solver_mod - use mld_s_ilu_fact_mod + use psb_s_ilu_fact_mod type, extends(mld_s_base_solver_type) :: mld_s_ilu_solver_type type(psb_sspmat_type) :: l, u @@ -234,7 +234,7 @@ contains ! Arguments class(mld_s_ilu_solver_type), intent(inout) :: sv - sv%fact_type = mld_ilu_n_ + sv%fact_type = psb_ilu_n_ sv%fill_in = 0 sv%thresh = szero @@ -255,13 +255,13 @@ contains info = psb_success_ call mld_check_def(sv%fact_type,& - & 'Factorization',mld_ilu_n_,is_legal_ilu_fact) + & 'Factorization',psb_ilu_n_,is_legal_ilu_fact) select case(sv%fact_type) - case(mld_ilu_n_,mld_milu_n_) + case(psb_ilu_n_,psb_milu_n_) call mld_check_def(sv%fill_in,& & 'Level',izero,is_int_non_negative) - case(mld_ilu_t_) + case(psb_ilu_t_) call mld_check_def(sv%thresh,& & 'Eps',szero,is_legal_s_fact_thrs) end select @@ -432,9 +432,9 @@ contains write(iout_,*) ' Incomplete factorization solver: ',& & mld_fact_names(sv%fact_type) select case(sv%fact_type) - case(mld_ilu_n_,mld_milu_n_) + case(psb_ilu_n_,psb_milu_n_) write(iout_,*) ' Fill level:',sv%fill_in - case(mld_ilu_t_) + case(psb_ilu_t_) write(iout_,*) ' Fill level:',sv%fill_in write(iout_,*) ' Fill threshold :',sv%thresh end select @@ -489,7 +489,7 @@ contains implicit none integer(psb_ipk_) :: val - val = mld_ilu_n_ + val = psb_ilu_n_ end function s_ilu_solver_get_id function s_ilu_solver_get_wrksize() result(val) diff --git a/mlprec/mld_s_mumps_solver.F90 b/mlprec/mld_s_mumps_solver.F90 index 51b09abb..d3951a9f 100644 --- a/mlprec/mld_s_mumps_solver.F90 +++ b/mlprec/mld_s_mumps_solver.F90 @@ -100,9 +100,7 @@ module mld_s_mumps_solver procedure, nopass :: get_fmt => s_mumps_solver_get_fmt procedure, nopass :: get_id => s_mumps_solver_get_id procedure, pass(sv) :: is_global => s_mumps_solver_is_global -#if defined(HAVE_FINAL) final :: s_mumps_solver_finalize -#endif end type mld_s_mumps_solver_type @@ -114,9 +112,7 @@ module mld_s_mumps_solver & s_mumps_solver_default, s_mumps_solver_get_fmt, & & s_mumps_solver_clone_settings, & & s_mumps_solver_get_id, s_mumps_solver_is_global -#if defined(HAVE_FINAL) private :: s_mumps_solver_finalize -#endif interface subroutine s_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& @@ -301,7 +297,6 @@ contains #endif end subroutine s_mumps_solver_free -#if defined(HAVE_FINAL) subroutine s_mumps_solver_finalize(sv) Implicit None @@ -317,7 +312,6 @@ subroutine s_mumps_solver_finalize(sv) return end subroutine s_mumps_solver_finalize -#endif subroutine s_mumps_solver_descr(sv,info,iout,coarse) diff --git a/mlprec/mld_s_slu_solver.F90 b/mlprec/mld_s_slu_solver.F90 index 266ad4ac..0886eb48 100644 --- a/mlprec/mld_s_slu_solver.F90 +++ b/mlprec/mld_s_slu_solver.F90 @@ -72,9 +72,7 @@ module mld_s_slu_solver procedure, pass(sv) :: sizeof => s_slu_solver_sizeof procedure, nopass :: get_fmt => s_slu_solver_get_fmt procedure, nopass :: get_id => s_slu_solver_get_id -#if defined(HAVE_FINAL) final :: s_slu_solver_finalize -#endif end type mld_s_slu_solver_type @@ -83,9 +81,7 @@ module mld_s_slu_solver & s_slu_solver_sizeof, s_slu_solver_apply_vect, & & s_slu_solver_get_fmt, s_slu_solver_get_id, & & s_slu_solver_clear_data -#if defined(HAVE_FINAL) private :: s_slu_solver_finalize -#endif @@ -371,7 +367,6 @@ contains return end subroutine s_slu_solver_clear_data -#if defined(HAVE_FINAL) subroutine s_slu_solver_finalize(sv) Implicit None @@ -387,7 +382,6 @@ contains return end subroutine s_slu_solver_finalize -#endif subroutine s_slu_solver_descr(sv,info,iout,coarse) diff --git a/mlprec/mld_z_ilu_solver.f90 b/mlprec/mld_z_ilu_solver.f90 index 0b98de2b..18d13b06 100644 --- a/mlprec/mld_z_ilu_solver.f90 +++ b/mlprec/mld_z_ilu_solver.f90 @@ -58,7 +58,7 @@ module mld_z_ilu_solver use mld_base_prec_type, only : mld_fact_names use mld_z_base_solver_mod - use mld_z_ilu_fact_mod + use psb_z_ilu_fact_mod type, extends(mld_z_base_solver_type) :: mld_z_ilu_solver_type type(psb_zspmat_type) :: l, u @@ -234,7 +234,7 @@ contains ! Arguments class(mld_z_ilu_solver_type), intent(inout) :: sv - sv%fact_type = mld_ilu_n_ + sv%fact_type = psb_ilu_n_ sv%fill_in = 0 sv%thresh = dzero @@ -255,13 +255,13 @@ contains info = psb_success_ call mld_check_def(sv%fact_type,& - & 'Factorization',mld_ilu_n_,is_legal_ilu_fact) + & 'Factorization',psb_ilu_n_,is_legal_ilu_fact) select case(sv%fact_type) - case(mld_ilu_n_,mld_milu_n_) + case(psb_ilu_n_,psb_milu_n_) call mld_check_def(sv%fill_in,& & 'Level',izero,is_int_non_negative) - case(mld_ilu_t_) + case(psb_ilu_t_) call mld_check_def(sv%thresh,& & 'Eps',dzero,is_legal_d_fact_thrs) end select @@ -432,9 +432,9 @@ contains write(iout_,*) ' Incomplete factorization solver: ',& & mld_fact_names(sv%fact_type) select case(sv%fact_type) - case(mld_ilu_n_,mld_milu_n_) + case(psb_ilu_n_,psb_milu_n_) write(iout_,*) ' Fill level:',sv%fill_in - case(mld_ilu_t_) + case(psb_ilu_t_) write(iout_,*) ' Fill level:',sv%fill_in write(iout_,*) ' Fill threshold :',sv%thresh end select @@ -489,7 +489,7 @@ contains implicit none integer(psb_ipk_) :: val - val = mld_ilu_n_ + val = psb_ilu_n_ end function z_ilu_solver_get_id function z_ilu_solver_get_wrksize() result(val) diff --git a/mlprec/mld_z_mumps_solver.F90 b/mlprec/mld_z_mumps_solver.F90 index af71fa2f..8f461a73 100644 --- a/mlprec/mld_z_mumps_solver.F90 +++ b/mlprec/mld_z_mumps_solver.F90 @@ -100,9 +100,7 @@ module mld_z_mumps_solver procedure, nopass :: get_fmt => z_mumps_solver_get_fmt procedure, nopass :: get_id => z_mumps_solver_get_id procedure, pass(sv) :: is_global => z_mumps_solver_is_global -#if defined(HAVE_FINAL) final :: z_mumps_solver_finalize -#endif end type mld_z_mumps_solver_type @@ -114,9 +112,7 @@ module mld_z_mumps_solver & z_mumps_solver_default, z_mumps_solver_get_fmt, & & z_mumps_solver_clone_settings, & & z_mumps_solver_get_id, z_mumps_solver_is_global -#if defined(HAVE_FINAL) private :: z_mumps_solver_finalize -#endif interface subroutine z_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& @@ -301,7 +297,6 @@ contains #endif end subroutine z_mumps_solver_free -#if defined(HAVE_FINAL) subroutine z_mumps_solver_finalize(sv) Implicit None @@ -317,7 +312,6 @@ subroutine z_mumps_solver_finalize(sv) return end subroutine z_mumps_solver_finalize -#endif subroutine z_mumps_solver_descr(sv,info,iout,coarse) diff --git a/mlprec/mld_z_slu_solver.F90 b/mlprec/mld_z_slu_solver.F90 index 0d6483eb..ca43e6e9 100644 --- a/mlprec/mld_z_slu_solver.F90 +++ b/mlprec/mld_z_slu_solver.F90 @@ -72,9 +72,7 @@ module mld_z_slu_solver procedure, pass(sv) :: sizeof => z_slu_solver_sizeof procedure, nopass :: get_fmt => z_slu_solver_get_fmt procedure, nopass :: get_id => z_slu_solver_get_id -#if defined(HAVE_FINAL) final :: z_slu_solver_finalize -#endif end type mld_z_slu_solver_type @@ -83,9 +81,7 @@ module mld_z_slu_solver & z_slu_solver_sizeof, z_slu_solver_apply_vect, & & z_slu_solver_get_fmt, z_slu_solver_get_id, & & z_slu_solver_clear_data -#if defined(HAVE_FINAL) private :: z_slu_solver_finalize -#endif @@ -371,7 +367,6 @@ contains return end subroutine z_slu_solver_clear_data -#if defined(HAVE_FINAL) subroutine z_slu_solver_finalize(sv) Implicit None @@ -387,7 +382,6 @@ contains return end subroutine z_slu_solver_finalize -#endif subroutine z_slu_solver_descr(sv,info,iout,coarse) diff --git a/mlprec/mld_z_sludist_solver.F90 b/mlprec/mld_z_sludist_solver.F90 index ffe73637..ba276ead 100644 --- a/mlprec/mld_z_sludist_solver.F90 +++ b/mlprec/mld_z_sludist_solver.F90 @@ -72,9 +72,7 @@ module mld_z_sludist_solver procedure, nopass :: get_fmt => z_sludist_solver_get_fmt procedure, nopass :: get_id => z_sludist_solver_get_id procedure, pass(sv) :: is_global => z_sludist_solver_is_global -#if defined(HAVE_FINAL) final :: z_sludist_solver_finalize -#endif end type mld_z_sludist_solver_type @@ -83,9 +81,7 @@ module mld_z_sludist_solver & z_sludist_solver_sizeof, z_sludist_solver_apply_vect, & & z_sludist_solver_get_fmt, z_sludist_solver_get_id, & & z_sludist_solver_is_global, z_sludist_solver_clear_data -#if defined(HAVE_FINAL) private :: z_sludist_solver_finalize -#endif interface @@ -389,7 +385,6 @@ contains val = .true. end function z_sludist_solver_is_global -#if defined(HAVE_FINAL) subroutine z_sludist_solver_finalize(sv) Implicit None @@ -405,7 +400,6 @@ contains return end subroutine z_sludist_solver_finalize -#endif subroutine z_sludist_solver_descr(sv,info,iout,coarse) diff --git a/mlprec/mld_z_umf_solver.F90 b/mlprec/mld_z_umf_solver.F90 index 01de3ee6..3ea111aa 100644 --- a/mlprec/mld_z_umf_solver.F90 +++ b/mlprec/mld_z_umf_solver.F90 @@ -71,9 +71,7 @@ module mld_z_umf_solver procedure, pass(sv) :: sizeof => z_umf_solver_sizeof procedure, nopass :: get_fmt => z_umf_solver_get_fmt procedure, nopass :: get_id => z_umf_solver_get_id -#if defined(HAVE_FINAL) final :: z_umf_solver_finalize -#endif end type mld_z_umf_solver_type @@ -82,9 +80,7 @@ module mld_z_umf_solver & z_umf_solver_sizeof, z_umf_solver_apply_vect, & & z_umf_solver_get_fmt, z_umf_solver_get_id, & & z_umf_solver_clear_data -#if defined(HAVE_FINAL) private :: z_umf_solver_finalize -#endif @@ -377,7 +373,6 @@ contains return end subroutine z_umf_solver_clear_data -#if defined(HAVE_FINAL) subroutine z_umf_solver_finalize(sv) Implicit None @@ -393,7 +388,6 @@ contains return end subroutine z_umf_solver_finalize -#endif subroutine z_umf_solver_descr(sv,info,iout,coarse)