From 88976ec108e500ceaefee32d4e14a232bc2d3341 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 7 May 2019 17:24:01 +0100 Subject: [PATCH] Changes for new L1-Jacobi smoother/solver. --- mlprec/impl/level/mld_c_base_onelev_cseti.F90 | 27 ++++-- mlprec/impl/level/mld_d_base_onelev_cseti.F90 | 29 ++++-- mlprec/impl/level/mld_s_base_onelev_cseti.F90 | 27 ++++-- mlprec/impl/level/mld_z_base_onelev_cseti.F90 | 29 ++++-- mlprec/impl/mld_c_smoothers_bld.f90 | 2 +- mlprec/impl/mld_ccprecset.F90 | 1 + mlprec/impl/mld_d_smoothers_bld.f90 | 2 +- mlprec/impl/mld_dcprecset.F90 | 1 + mlprec/impl/mld_s_smoothers_bld.f90 | 2 +- mlprec/impl/mld_scprecset.F90 | 1 + mlprec/impl/mld_z_smoothers_bld.f90 | 2 +- mlprec/impl/mld_zcprecset.F90 | 1 + mlprec/impl/solver/mld_c_diag_solver_bld.f90 | 78 +++++++++++++++ .../impl/solver/mld_c_diag_solver_clone.f90 | 4 +- mlprec/impl/solver/mld_c_diag_solver_dmp.f90 | 46 +++++++++ mlprec/impl/solver/mld_d_diag_solver_bld.f90 | 78 +++++++++++++++ .../impl/solver/mld_d_diag_solver_clone.f90 | 4 +- mlprec/impl/solver/mld_d_diag_solver_dmp.f90 | 46 +++++++++ mlprec/impl/solver/mld_s_diag_solver_bld.f90 | 78 +++++++++++++++ .../impl/solver/mld_s_diag_solver_clone.f90 | 4 +- mlprec/impl/solver/mld_s_diag_solver_dmp.f90 | 46 +++++++++ mlprec/impl/solver/mld_z_diag_solver_bld.f90 | 78 +++++++++++++++ .../impl/solver/mld_z_diag_solver_clone.f90 | 4 +- mlprec/impl/solver/mld_z_diag_solver_dmp.f90 | 46 +++++++++ mlprec/mld_base_prec_type.F90 | 38 ++++---- mlprec/mld_c_diag_solver.f90 | 96 +++++++++++++++++++ mlprec/mld_c_prec_mod.f90 | 1 + mlprec/mld_d_diag_solver.f90 | 96 +++++++++++++++++++ mlprec/mld_d_prec_mod.f90 | 1 + mlprec/mld_s_diag_solver.f90 | 96 +++++++++++++++++++ mlprec/mld_s_prec_mod.f90 | 1 + mlprec/mld_z_diag_solver.f90 | 96 +++++++++++++++++++ mlprec/mld_z_prec_mod.f90 | 1 + 33 files changed, 1000 insertions(+), 62 deletions(-) diff --git a/mlprec/impl/level/mld_c_base_onelev_cseti.F90 b/mlprec/impl/level/mld_c_base_onelev_cseti.F90 index 2aede23f..d686c5b0 100644 --- a/mlprec/impl/level/mld_c_base_onelev_cseti.F90 +++ b/mlprec/impl/level/mld_c_base_onelev_cseti.F90 @@ -45,6 +45,7 @@ subroutine mld_c_base_onelev_cseti(lv,what,val,info,pos,idx) use mld_c_jac_smoother use mld_c_as_smoother use mld_c_diag_solver + use mld_c_l1_diag_solver use mld_c_ilu_solver use mld_c_id_solver use mld_c_gs_solver @@ -67,14 +68,15 @@ subroutine mld_c_base_onelev_cseti(lv,what,val,info,pos,idx) ! Local integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='c_base_onelev_cseti' - type(mld_c_base_smoother_type) :: mld_c_base_smoother_mold - type(mld_c_jac_smoother_type) :: mld_c_jac_smoother_mold - type(mld_c_as_smoother_type) :: mld_c_as_smoother_mold - type(mld_c_diag_solver_type) :: mld_c_diag_solver_mold - type(mld_c_ilu_solver_type) :: mld_c_ilu_solver_mold - type(mld_c_id_solver_type) :: mld_c_id_solver_mold - type(mld_c_gs_solver_type) :: mld_c_gs_solver_mold - type(mld_c_bwgs_solver_type) :: mld_c_bwgs_solver_mold + type(mld_c_base_smoother_type) :: mld_c_base_smoother_mold + type(mld_c_jac_smoother_type) :: mld_c_jac_smoother_mold + type(mld_c_as_smoother_type) :: mld_c_as_smoother_mold + type(mld_c_diag_solver_type) :: mld_c_diag_solver_mold + type(mld_c_l1_diag_solver_type) :: mld_c_l1_diag_solver_mold + type(mld_c_ilu_solver_type) :: mld_c_ilu_solver_mold + type(mld_c_id_solver_type) :: mld_c_id_solver_mold + type(mld_c_gs_solver_type) :: mld_c_gs_solver_mold + type(mld_c_bwgs_solver_type) :: mld_c_bwgs_solver_mold #if defined(HAVE_SLU_) type(mld_c_slu_solver_type) :: mld_c_slu_solver_mold #endif @@ -100,6 +102,7 @@ subroutine mld_c_base_onelev_cseti(lv,what,val,info,pos,idx) select case (psb_toupper(what)) case ('SMOOTHER_TYPE') + select case (val) case (mld_noprec_) call lv%set(mld_c_base_smoother_mold,info,pos=pos) @@ -108,6 +111,11 @@ subroutine mld_c_base_onelev_cseti(lv,what,val,info,pos,idx) case (mld_jac_) call lv%set(mld_c_jac_smoother_mold,info,pos=pos) if (info == 0) call lv%set(mld_c_diag_solver_mold,info,pos=pos) + + case (mld_l1_jac_) + + call lv%set(mld_c_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_c_l1_diag_solver_mold,info,pos=pos) case (mld_bjac_) call lv%set(mld_c_jac_smoother_mold,info,pos=pos) @@ -144,6 +152,9 @@ subroutine mld_c_base_onelev_cseti(lv,what,val,info,pos,idx) case (mld_diag_scale_) call lv%set(mld_c_diag_solver_mold,info,pos=pos) + case (mld_l1_diag_scale_) + call lv%set(mld_c_l1_diag_solver_mold,info,pos=pos) + case (mld_gs_) call lv%set(mld_c_gs_solver_mold,info,pos=pos) diff --git a/mlprec/impl/level/mld_d_base_onelev_cseti.F90 b/mlprec/impl/level/mld_d_base_onelev_cseti.F90 index 74631029..a50354b5 100644 --- a/mlprec/impl/level/mld_d_base_onelev_cseti.F90 +++ b/mlprec/impl/level/mld_d_base_onelev_cseti.F90 @@ -45,6 +45,7 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos,idx) use mld_d_jac_smoother use mld_d_as_smoother use mld_d_diag_solver + use mld_d_l1_diag_solver use mld_d_ilu_solver use mld_d_id_solver use mld_d_gs_solver @@ -73,16 +74,17 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos,idx) ! Local integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='d_base_onelev_cseti' - type(mld_d_base_smoother_type) :: mld_d_base_smoother_mold - type(mld_d_jac_smoother_type) :: mld_d_jac_smoother_mold - type(mld_d_as_smoother_type) :: mld_d_as_smoother_mold - type(mld_d_diag_solver_type) :: mld_d_diag_solver_mold - type(mld_d_ilu_solver_type) :: mld_d_ilu_solver_mold - type(mld_d_id_solver_type) :: mld_d_id_solver_mold - type(mld_d_gs_solver_type) :: mld_d_gs_solver_mold - type(mld_d_bwgs_solver_type) :: mld_d_bwgs_solver_mold + type(mld_d_base_smoother_type) :: mld_d_base_smoother_mold + type(mld_d_jac_smoother_type) :: mld_d_jac_smoother_mold + type(mld_d_as_smoother_type) :: mld_d_as_smoother_mold + type(mld_d_diag_solver_type) :: mld_d_diag_solver_mold + type(mld_d_l1_diag_solver_type) :: mld_d_l1_diag_solver_mold + type(mld_d_ilu_solver_type) :: mld_d_ilu_solver_mold + type(mld_d_id_solver_type) :: mld_d_id_solver_mold + type(mld_d_gs_solver_type) :: mld_d_gs_solver_mold + type(mld_d_bwgs_solver_type) :: mld_d_bwgs_solver_mold #if defined(HAVE_UMF_) - type(mld_d_umf_solver_type) :: mld_d_umf_solver_mold + type(mld_d_umf_solver_type) :: mld_d_umf_solver_mold #endif #if defined(HAVE_SLUDIST_) type(mld_d_sludist_solver_type) :: mld_d_sludist_solver_mold @@ -112,6 +114,7 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos,idx) select case (psb_toupper(what)) case ('SMOOTHER_TYPE') + select case (val) case (mld_noprec_) call lv%set(mld_d_base_smoother_mold,info,pos=pos) @@ -120,6 +123,11 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos,idx) case (mld_jac_) call lv%set(mld_d_jac_smoother_mold,info,pos=pos) if (info == 0) call lv%set(mld_d_diag_solver_mold,info,pos=pos) + + case (mld_l1_jac_) + + call lv%set(mld_d_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_d_l1_diag_solver_mold,info,pos=pos) case (mld_bjac_) call lv%set(mld_d_jac_smoother_mold,info,pos=pos) @@ -156,6 +164,9 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos,idx) case (mld_diag_scale_) call lv%set(mld_d_diag_solver_mold,info,pos=pos) + case (mld_l1_diag_scale_) + call lv%set(mld_d_l1_diag_solver_mold,info,pos=pos) + case (mld_gs_) call lv%set(mld_d_gs_solver_mold,info,pos=pos) diff --git a/mlprec/impl/level/mld_s_base_onelev_cseti.F90 b/mlprec/impl/level/mld_s_base_onelev_cseti.F90 index 5c5ffbf1..b3599bfa 100644 --- a/mlprec/impl/level/mld_s_base_onelev_cseti.F90 +++ b/mlprec/impl/level/mld_s_base_onelev_cseti.F90 @@ -45,6 +45,7 @@ subroutine mld_s_base_onelev_cseti(lv,what,val,info,pos,idx) use mld_s_jac_smoother use mld_s_as_smoother use mld_s_diag_solver + use mld_s_l1_diag_solver use mld_s_ilu_solver use mld_s_id_solver use mld_s_gs_solver @@ -67,14 +68,15 @@ subroutine mld_s_base_onelev_cseti(lv,what,val,info,pos,idx) ! Local integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='s_base_onelev_cseti' - type(mld_s_base_smoother_type) :: mld_s_base_smoother_mold - type(mld_s_jac_smoother_type) :: mld_s_jac_smoother_mold - type(mld_s_as_smoother_type) :: mld_s_as_smoother_mold - type(mld_s_diag_solver_type) :: mld_s_diag_solver_mold - type(mld_s_ilu_solver_type) :: mld_s_ilu_solver_mold - type(mld_s_id_solver_type) :: mld_s_id_solver_mold - type(mld_s_gs_solver_type) :: mld_s_gs_solver_mold - type(mld_s_bwgs_solver_type) :: mld_s_bwgs_solver_mold + type(mld_s_base_smoother_type) :: mld_s_base_smoother_mold + type(mld_s_jac_smoother_type) :: mld_s_jac_smoother_mold + type(mld_s_as_smoother_type) :: mld_s_as_smoother_mold + type(mld_s_diag_solver_type) :: mld_s_diag_solver_mold + type(mld_s_l1_diag_solver_type) :: mld_s_l1_diag_solver_mold + type(mld_s_ilu_solver_type) :: mld_s_ilu_solver_mold + type(mld_s_id_solver_type) :: mld_s_id_solver_mold + type(mld_s_gs_solver_type) :: mld_s_gs_solver_mold + type(mld_s_bwgs_solver_type) :: mld_s_bwgs_solver_mold #if defined(HAVE_SLU_) type(mld_s_slu_solver_type) :: mld_s_slu_solver_mold #endif @@ -100,6 +102,7 @@ subroutine mld_s_base_onelev_cseti(lv,what,val,info,pos,idx) select case (psb_toupper(what)) case ('SMOOTHER_TYPE') + select case (val) case (mld_noprec_) call lv%set(mld_s_base_smoother_mold,info,pos=pos) @@ -108,6 +111,11 @@ subroutine mld_s_base_onelev_cseti(lv,what,val,info,pos,idx) case (mld_jac_) call lv%set(mld_s_jac_smoother_mold,info,pos=pos) if (info == 0) call lv%set(mld_s_diag_solver_mold,info,pos=pos) + + case (mld_l1_jac_) + + call lv%set(mld_s_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_s_l1_diag_solver_mold,info,pos=pos) case (mld_bjac_) call lv%set(mld_s_jac_smoother_mold,info,pos=pos) @@ -144,6 +152,9 @@ subroutine mld_s_base_onelev_cseti(lv,what,val,info,pos,idx) case (mld_diag_scale_) call lv%set(mld_s_diag_solver_mold,info,pos=pos) + case (mld_l1_diag_scale_) + call lv%set(mld_s_l1_diag_solver_mold,info,pos=pos) + case (mld_gs_) call lv%set(mld_s_gs_solver_mold,info,pos=pos) diff --git a/mlprec/impl/level/mld_z_base_onelev_cseti.F90 b/mlprec/impl/level/mld_z_base_onelev_cseti.F90 index 9ea87251..9e55e491 100644 --- a/mlprec/impl/level/mld_z_base_onelev_cseti.F90 +++ b/mlprec/impl/level/mld_z_base_onelev_cseti.F90 @@ -45,6 +45,7 @@ subroutine mld_z_base_onelev_cseti(lv,what,val,info,pos,idx) use mld_z_jac_smoother use mld_z_as_smoother use mld_z_diag_solver + use mld_z_l1_diag_solver use mld_z_ilu_solver use mld_z_id_solver use mld_z_gs_solver @@ -73,16 +74,17 @@ subroutine mld_z_base_onelev_cseti(lv,what,val,info,pos,idx) ! Local integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='z_base_onelev_cseti' - type(mld_z_base_smoother_type) :: mld_z_base_smoother_mold - type(mld_z_jac_smoother_type) :: mld_z_jac_smoother_mold - type(mld_z_as_smoother_type) :: mld_z_as_smoother_mold - type(mld_z_diag_solver_type) :: mld_z_diag_solver_mold - type(mld_z_ilu_solver_type) :: mld_z_ilu_solver_mold - type(mld_z_id_solver_type) :: mld_z_id_solver_mold - type(mld_z_gs_solver_type) :: mld_z_gs_solver_mold - type(mld_z_bwgs_solver_type) :: mld_z_bwgs_solver_mold + type(mld_z_base_smoother_type) :: mld_z_base_smoother_mold + type(mld_z_jac_smoother_type) :: mld_z_jac_smoother_mold + type(mld_z_as_smoother_type) :: mld_z_as_smoother_mold + type(mld_z_diag_solver_type) :: mld_z_diag_solver_mold + type(mld_z_l1_diag_solver_type) :: mld_z_l1_diag_solver_mold + type(mld_z_ilu_solver_type) :: mld_z_ilu_solver_mold + type(mld_z_id_solver_type) :: mld_z_id_solver_mold + type(mld_z_gs_solver_type) :: mld_z_gs_solver_mold + type(mld_z_bwgs_solver_type) :: mld_z_bwgs_solver_mold #if defined(HAVE_UMF_) - type(mld_z_umf_solver_type) :: mld_z_umf_solver_mold + type(mld_z_umf_solver_type) :: mld_z_umf_solver_mold #endif #if defined(HAVE_SLUDIST_) type(mld_z_sludist_solver_type) :: mld_z_sludist_solver_mold @@ -112,6 +114,7 @@ subroutine mld_z_base_onelev_cseti(lv,what,val,info,pos,idx) select case (psb_toupper(what)) case ('SMOOTHER_TYPE') + select case (val) case (mld_noprec_) call lv%set(mld_z_base_smoother_mold,info,pos=pos) @@ -120,6 +123,11 @@ subroutine mld_z_base_onelev_cseti(lv,what,val,info,pos,idx) case (mld_jac_) call lv%set(mld_z_jac_smoother_mold,info,pos=pos) if (info == 0) call lv%set(mld_z_diag_solver_mold,info,pos=pos) + + case (mld_l1_jac_) + + call lv%set(mld_z_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_z_l1_diag_solver_mold,info,pos=pos) case (mld_bjac_) call lv%set(mld_z_jac_smoother_mold,info,pos=pos) @@ -156,6 +164,9 @@ subroutine mld_z_base_onelev_cseti(lv,what,val,info,pos,idx) case (mld_diag_scale_) call lv%set(mld_z_diag_solver_mold,info,pos=pos) + case (mld_l1_diag_scale_) + call lv%set(mld_z_l1_diag_solver_mold,info,pos=pos) + case (mld_gs_) call lv%set(mld_z_gs_solver_mold,info,pos=pos) diff --git a/mlprec/impl/mld_c_smoothers_bld.f90 b/mlprec/impl/mld_c_smoothers_bld.f90 index 9580998d..8d38a0fe 100644 --- a/mlprec/impl/mld_c_smoothers_bld.f90 +++ b/mlprec/impl/mld_c_smoothers_bld.f90 @@ -258,7 +258,7 @@ subroutine mld_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold) & ' but the coarse matrix has been changed to replicated' end if - case(mld_bjac_,mld_jac_) + case(mld_bjac_,mld_jac_, mld_l1_jac_) if (prec%precv(iszv)%parms%coarse_mat /= mld_distr_mat_) then write(psb_err_unit,*) & & 'MLD2P4: Warning: original coarse solver was requested as ',& diff --git a/mlprec/impl/mld_ccprecset.F90 b/mlprec/impl/mld_ccprecset.F90 index bd4f0985..01cb0bfc 100644 --- a/mlprec/impl/mld_ccprecset.F90 +++ b/mlprec/impl/mld_ccprecset.F90 @@ -82,6 +82,7 @@ subroutine mld_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx) use mld_c_jac_smoother use mld_c_as_smoother use mld_c_diag_solver + use mld_c_l1_diag_solver use mld_c_ilu_solver use mld_c_id_solver use mld_c_gs_solver diff --git a/mlprec/impl/mld_d_smoothers_bld.f90 b/mlprec/impl/mld_d_smoothers_bld.f90 index 0c5fe7c6..4e6f6a76 100644 --- a/mlprec/impl/mld_d_smoothers_bld.f90 +++ b/mlprec/impl/mld_d_smoothers_bld.f90 @@ -258,7 +258,7 @@ subroutine mld_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold) & ' but the coarse matrix has been changed to replicated' end if - case(mld_bjac_,mld_jac_) + case(mld_bjac_,mld_jac_, mld_l1_jac_) if (prec%precv(iszv)%parms%coarse_mat /= mld_distr_mat_) then write(psb_err_unit,*) & & 'MLD2P4: Warning: original coarse solver was requested as ',& diff --git a/mlprec/impl/mld_dcprecset.F90 b/mlprec/impl/mld_dcprecset.F90 index 0338d640..0bb34341 100644 --- a/mlprec/impl/mld_dcprecset.F90 +++ b/mlprec/impl/mld_dcprecset.F90 @@ -82,6 +82,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx) use mld_d_jac_smoother use mld_d_as_smoother use mld_d_diag_solver + use mld_d_l1_diag_solver use mld_d_ilu_solver use mld_d_id_solver use mld_d_gs_solver diff --git a/mlprec/impl/mld_s_smoothers_bld.f90 b/mlprec/impl/mld_s_smoothers_bld.f90 index 6c6797fa..cc588cec 100644 --- a/mlprec/impl/mld_s_smoothers_bld.f90 +++ b/mlprec/impl/mld_s_smoothers_bld.f90 @@ -258,7 +258,7 @@ subroutine mld_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold) & ' but the coarse matrix has been changed to replicated' end if - case(mld_bjac_,mld_jac_) + case(mld_bjac_,mld_jac_, mld_l1_jac_) if (prec%precv(iszv)%parms%coarse_mat /= mld_distr_mat_) then write(psb_err_unit,*) & & 'MLD2P4: Warning: original coarse solver was requested as ',& diff --git a/mlprec/impl/mld_scprecset.F90 b/mlprec/impl/mld_scprecset.F90 index 0032994b..6917a2cc 100644 --- a/mlprec/impl/mld_scprecset.F90 +++ b/mlprec/impl/mld_scprecset.F90 @@ -82,6 +82,7 @@ subroutine mld_scprecseti(p,what,val,info,ilev,ilmax,pos,idx) use mld_s_jac_smoother use mld_s_as_smoother use mld_s_diag_solver + use mld_s_l1_diag_solver use mld_s_ilu_solver use mld_s_id_solver use mld_s_gs_solver diff --git a/mlprec/impl/mld_z_smoothers_bld.f90 b/mlprec/impl/mld_z_smoothers_bld.f90 index 1d69b66f..be99c1d3 100644 --- a/mlprec/impl/mld_z_smoothers_bld.f90 +++ b/mlprec/impl/mld_z_smoothers_bld.f90 @@ -258,7 +258,7 @@ subroutine mld_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold) & ' but the coarse matrix has been changed to replicated' end if - case(mld_bjac_,mld_jac_) + case(mld_bjac_,mld_jac_, mld_l1_jac_) if (prec%precv(iszv)%parms%coarse_mat /= mld_distr_mat_) then write(psb_err_unit,*) & & 'MLD2P4: Warning: original coarse solver was requested as ',& diff --git a/mlprec/impl/mld_zcprecset.F90 b/mlprec/impl/mld_zcprecset.F90 index 72de1558..93deb77e 100644 --- a/mlprec/impl/mld_zcprecset.F90 +++ b/mlprec/impl/mld_zcprecset.F90 @@ -82,6 +82,7 @@ subroutine mld_zcprecseti(p,what,val,info,ilev,ilmax,pos,idx) use mld_z_jac_smoother use mld_z_as_smoother use mld_z_diag_solver + use mld_z_l1_diag_solver use mld_z_ilu_solver use mld_z_id_solver use mld_z_gs_solver diff --git a/mlprec/impl/solver/mld_c_diag_solver_bld.f90 b/mlprec/impl/solver/mld_c_diag_solver_bld.f90 index d17d125b..874b2ebc 100644 --- a/mlprec/impl/solver/mld_c_diag_solver_bld.f90 +++ b/mlprec/impl/solver/mld_c_diag_solver_bld.f90 @@ -111,3 +111,81 @@ subroutine mld_c_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) return end subroutine mld_c_diag_solver_bld + + +subroutine mld_c_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) + + use psb_base_mod + use mld_c_l1_diag_solver, mld_protect_name => mld_c_l1_diag_solver_bld + + Implicit None + + ! Arguments + type(psb_cspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(mld_c_l1_diag_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + type(psb_cspmat_type), intent(in), target, optional :: b + class(psb_c_base_sparse_mat), intent(in), optional :: amold + class(psb_c_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + ! Local variables + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota + complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + complex(psb_spk_), allocatable :: tdb(:) + integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level + character(len=20) :: name='c_l1_diag_solver_bld', ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + n_row = desc_a%get_local_rows() + nrow_a = a%get_nrows() + + sv%d = a%arwsum(info) + if (info == psb_success_) call psb_realloc(n_row,sv%d,info) + if (present(b)) then + tdb=b%arwsum(info) + if (size(tdb)+nrow_a > n_row) call psb_realloc(nrow_a+size(tdb),sv%d,info) + if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) + end if + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='arwsum') + goto 9999 + end if + + do i=1,n_row + if (sv%d(i) == czero) then + sv%d(i) = cone + else + sv%d(i) = cone/sv%d(i) + end if + end do + allocate(sv%dv,stat=info) + if (info == psb_success_) then + call sv%dv%bld(sv%d) + if (present(vmold)) call sv%dv%cnv(vmold) + call sv%dv%sync() + else + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='Allocate sv%dv') + goto 9999 + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_c_l1_diag_solver_bld diff --git a/mlprec/impl/solver/mld_c_diag_solver_clone.f90 b/mlprec/impl/solver/mld_c_diag_solver_clone.f90 index 1fd53b26..935beafe 100644 --- a/mlprec/impl/solver/mld_c_diag_solver_clone.f90 +++ b/mlprec/impl/solver/mld_c_diag_solver_clone.f90 @@ -57,14 +57,14 @@ subroutine mld_c_diag_solver_clone(sv,svout,info) if (info == psb_success_) deallocate(svout, stat=info) end if if (info == psb_success_) & - & allocate(mld_c_diag_solver_type :: svout, stat=info) + & allocate(svout, mold=sv, stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ goto 9999 end if select type(svo => svout) - type is (mld_c_diag_solver_type) + class is (mld_c_diag_solver_type) call psb_safe_ab_cpy(sv%d,svo%d,info) if (info == psb_success_) & & call sv%dv%clone(svo%dv,info) diff --git a/mlprec/impl/solver/mld_c_diag_solver_dmp.f90 b/mlprec/impl/solver/mld_c_diag_solver_dmp.f90 index 63846d37..beb2a1eb 100644 --- a/mlprec/impl/solver/mld_c_diag_solver_dmp.f90 +++ b/mlprec/impl/solver/mld_c_diag_solver_dmp.f90 @@ -81,3 +81,49 @@ subroutine mld_c_diag_solver_dmp(sv,ictxt,level,info,prefix,head,solver) end if end subroutine mld_c_diag_solver_dmp +subroutine mld_c_l1_diag_solver_dmp(sv,ictxt,level,info,prefix,head,solver) + + use psb_base_mod + use mld_c_l1_diag_solver, mld_protect_name => mld_c_l1_diag_solver_dmp + implicit none + class(mld_c_l1_diag_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(in) :: ictxt,level + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: solver + integer(psb_ipk_) :: i, j, il1, iln, lname, lev + integer(psb_ipk_) :: icontxt,iam, np + character(len=80) :: prefix_ + character(len=120) :: fname ! len should be at least 20 more than + logical :: solver_ + ! len of prefix_ + + info = 0 + + + call psb_info(ictxt,iam,np) + + if (present(solver)) then + solver_ = solver + else + solver_ = .false. + end if + + if (solver_) then + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_slv_c" + end if + lname = len_trim(prefix_) + fname = trim(prefix_) + write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam + lname = lname + 5 + + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_l1_diag.mtx' + if (allocated(sv%d)) & + & call psb_geprt(fname,sv%d,head=head) + + end if + +end subroutine mld_c_l1_diag_solver_dmp diff --git a/mlprec/impl/solver/mld_d_diag_solver_bld.f90 b/mlprec/impl/solver/mld_d_diag_solver_bld.f90 index c0be2077..37361b93 100644 --- a/mlprec/impl/solver/mld_d_diag_solver_bld.f90 +++ b/mlprec/impl/solver/mld_d_diag_solver_bld.f90 @@ -111,3 +111,81 @@ subroutine mld_d_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) return end subroutine mld_d_diag_solver_bld + + +subroutine mld_d_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) + + use psb_base_mod + use mld_d_l1_diag_solver, mld_protect_name => mld_d_l1_diag_solver_bld + + Implicit None + + ! Arguments + type(psb_dspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(mld_d_l1_diag_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + type(psb_dspmat_type), intent(in), target, optional :: b + class(psb_d_base_sparse_mat), intent(in), optional :: amold + class(psb_d_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + ! Local variables + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota + real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) + real(psb_dpk_), allocatable :: tdb(:) + integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level + character(len=20) :: name='d_l1_diag_solver_bld', ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + n_row = desc_a%get_local_rows() + nrow_a = a%get_nrows() + + sv%d = a%arwsum(info) + if (info == psb_success_) call psb_realloc(n_row,sv%d,info) + if (present(b)) then + tdb=b%arwsum(info) + if (size(tdb)+nrow_a > n_row) call psb_realloc(nrow_a+size(tdb),sv%d,info) + if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) + end if + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='arwsum') + goto 9999 + end if + + do i=1,n_row + if (sv%d(i) == dzero) then + sv%d(i) = done + else + sv%d(i) = done/sv%d(i) + end if + end do + allocate(sv%dv,stat=info) + if (info == psb_success_) then + call sv%dv%bld(sv%d) + if (present(vmold)) call sv%dv%cnv(vmold) + call sv%dv%sync() + else + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='Allocate sv%dv') + goto 9999 + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_d_l1_diag_solver_bld diff --git a/mlprec/impl/solver/mld_d_diag_solver_clone.f90 b/mlprec/impl/solver/mld_d_diag_solver_clone.f90 index 15d29217..bf2238f0 100644 --- a/mlprec/impl/solver/mld_d_diag_solver_clone.f90 +++ b/mlprec/impl/solver/mld_d_diag_solver_clone.f90 @@ -57,14 +57,14 @@ subroutine mld_d_diag_solver_clone(sv,svout,info) if (info == psb_success_) deallocate(svout, stat=info) end if if (info == psb_success_) & - & allocate(mld_d_diag_solver_type :: svout, stat=info) + & allocate(svout, mold=sv, stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ goto 9999 end if select type(svo => svout) - type is (mld_d_diag_solver_type) + class is (mld_d_diag_solver_type) call psb_safe_ab_cpy(sv%d,svo%d,info) if (info == psb_success_) & & call sv%dv%clone(svo%dv,info) diff --git a/mlprec/impl/solver/mld_d_diag_solver_dmp.f90 b/mlprec/impl/solver/mld_d_diag_solver_dmp.f90 index 21d58955..c6119c1a 100644 --- a/mlprec/impl/solver/mld_d_diag_solver_dmp.f90 +++ b/mlprec/impl/solver/mld_d_diag_solver_dmp.f90 @@ -81,3 +81,49 @@ subroutine mld_d_diag_solver_dmp(sv,ictxt,level,info,prefix,head,solver) end if end subroutine mld_d_diag_solver_dmp +subroutine mld_d_l1_diag_solver_dmp(sv,ictxt,level,info,prefix,head,solver) + + use psb_base_mod + use mld_d_l1_diag_solver, mld_protect_name => mld_d_l1_diag_solver_dmp + implicit none + class(mld_d_l1_diag_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(in) :: ictxt,level + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: solver + integer(psb_ipk_) :: i, j, il1, iln, lname, lev + integer(psb_ipk_) :: icontxt,iam, np + character(len=80) :: prefix_ + character(len=120) :: fname ! len should be at least 20 more than + logical :: solver_ + ! len of prefix_ + + info = 0 + + + call psb_info(ictxt,iam,np) + + if (present(solver)) then + solver_ = solver + else + solver_ = .false. + end if + + if (solver_) then + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_slv_d" + end if + lname = len_trim(prefix_) + fname = trim(prefix_) + write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam + lname = lname + 5 + + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_l1_diag.mtx' + if (allocated(sv%d)) & + & call psb_geprt(fname,sv%d,head=head) + + end if + +end subroutine mld_d_l1_diag_solver_dmp diff --git a/mlprec/impl/solver/mld_s_diag_solver_bld.f90 b/mlprec/impl/solver/mld_s_diag_solver_bld.f90 index ade06ea9..b2fca56b 100644 --- a/mlprec/impl/solver/mld_s_diag_solver_bld.f90 +++ b/mlprec/impl/solver/mld_s_diag_solver_bld.f90 @@ -111,3 +111,81 @@ subroutine mld_s_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) return end subroutine mld_s_diag_solver_bld + + +subroutine mld_s_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) + + use psb_base_mod + use mld_s_l1_diag_solver, mld_protect_name => mld_s_l1_diag_solver_bld + + Implicit None + + ! Arguments + type(psb_sspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(mld_s_l1_diag_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + type(psb_sspmat_type), intent(in), target, optional :: b + class(psb_s_base_sparse_mat), intent(in), optional :: amold + class(psb_s_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + ! Local variables + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota + real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + real(psb_spk_), allocatable :: tdb(:) + integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level + character(len=20) :: name='s_l1_diag_solver_bld', ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + n_row = desc_a%get_local_rows() + nrow_a = a%get_nrows() + + sv%d = a%arwsum(info) + if (info == psb_success_) call psb_realloc(n_row,sv%d,info) + if (present(b)) then + tdb=b%arwsum(info) + if (size(tdb)+nrow_a > n_row) call psb_realloc(nrow_a+size(tdb),sv%d,info) + if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) + end if + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='arwsum') + goto 9999 + end if + + do i=1,n_row + if (sv%d(i) == szero) then + sv%d(i) = sone + else + sv%d(i) = sone/sv%d(i) + end if + end do + allocate(sv%dv,stat=info) + if (info == psb_success_) then + call sv%dv%bld(sv%d) + if (present(vmold)) call sv%dv%cnv(vmold) + call sv%dv%sync() + else + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='Allocate sv%dv') + goto 9999 + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_s_l1_diag_solver_bld diff --git a/mlprec/impl/solver/mld_s_diag_solver_clone.f90 b/mlprec/impl/solver/mld_s_diag_solver_clone.f90 index f642e9f0..c40b7fbc 100644 --- a/mlprec/impl/solver/mld_s_diag_solver_clone.f90 +++ b/mlprec/impl/solver/mld_s_diag_solver_clone.f90 @@ -57,14 +57,14 @@ subroutine mld_s_diag_solver_clone(sv,svout,info) if (info == psb_success_) deallocate(svout, stat=info) end if if (info == psb_success_) & - & allocate(mld_s_diag_solver_type :: svout, stat=info) + & allocate(svout, mold=sv, stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ goto 9999 end if select type(svo => svout) - type is (mld_s_diag_solver_type) + class is (mld_s_diag_solver_type) call psb_safe_ab_cpy(sv%d,svo%d,info) if (info == psb_success_) & & call sv%dv%clone(svo%dv,info) diff --git a/mlprec/impl/solver/mld_s_diag_solver_dmp.f90 b/mlprec/impl/solver/mld_s_diag_solver_dmp.f90 index ae3695b8..b201e712 100644 --- a/mlprec/impl/solver/mld_s_diag_solver_dmp.f90 +++ b/mlprec/impl/solver/mld_s_diag_solver_dmp.f90 @@ -81,3 +81,49 @@ subroutine mld_s_diag_solver_dmp(sv,ictxt,level,info,prefix,head,solver) end if end subroutine mld_s_diag_solver_dmp +subroutine mld_s_l1_diag_solver_dmp(sv,ictxt,level,info,prefix,head,solver) + + use psb_base_mod + use mld_s_l1_diag_solver, mld_protect_name => mld_s_l1_diag_solver_dmp + implicit none + class(mld_s_l1_diag_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(in) :: ictxt,level + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: solver + integer(psb_ipk_) :: i, j, il1, iln, lname, lev + integer(psb_ipk_) :: icontxt,iam, np + character(len=80) :: prefix_ + character(len=120) :: fname ! len should be at least 20 more than + logical :: solver_ + ! len of prefix_ + + info = 0 + + + call psb_info(ictxt,iam,np) + + if (present(solver)) then + solver_ = solver + else + solver_ = .false. + end if + + if (solver_) then + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_slv_s" + end if + lname = len_trim(prefix_) + fname = trim(prefix_) + write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam + lname = lname + 5 + + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_l1_diag.mtx' + if (allocated(sv%d)) & + & call psb_geprt(fname,sv%d,head=head) + + end if + +end subroutine mld_s_l1_diag_solver_dmp diff --git a/mlprec/impl/solver/mld_z_diag_solver_bld.f90 b/mlprec/impl/solver/mld_z_diag_solver_bld.f90 index 3c570663..a19a5a1f 100644 --- a/mlprec/impl/solver/mld_z_diag_solver_bld.f90 +++ b/mlprec/impl/solver/mld_z_diag_solver_bld.f90 @@ -111,3 +111,81 @@ subroutine mld_z_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) return end subroutine mld_z_diag_solver_bld + + +subroutine mld_z_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) + + use psb_base_mod + use mld_z_l1_diag_solver, mld_protect_name => mld_z_l1_diag_solver_bld + + Implicit None + + ! Arguments + type(psb_zspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(mld_z_l1_diag_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + type(psb_zspmat_type), intent(in), target, optional :: b + class(psb_z_base_sparse_mat), intent(in), optional :: amold + class(psb_z_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + ! Local variables + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota + complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) + complex(psb_dpk_), allocatable :: tdb(:) + integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level + character(len=20) :: name='z_l1_diag_solver_bld', ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + n_row = desc_a%get_local_rows() + nrow_a = a%get_nrows() + + sv%d = a%arwsum(info) + if (info == psb_success_) call psb_realloc(n_row,sv%d,info) + if (present(b)) then + tdb=b%arwsum(info) + if (size(tdb)+nrow_a > n_row) call psb_realloc(nrow_a+size(tdb),sv%d,info) + if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) + end if + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='arwsum') + goto 9999 + end if + + do i=1,n_row + if (sv%d(i) == zzero) then + sv%d(i) = zone + else + sv%d(i) = zone/sv%d(i) + end if + end do + allocate(sv%dv,stat=info) + if (info == psb_success_) then + call sv%dv%bld(sv%d) + if (present(vmold)) call sv%dv%cnv(vmold) + call sv%dv%sync() + else + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='Allocate sv%dv') + goto 9999 + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_z_l1_diag_solver_bld diff --git a/mlprec/impl/solver/mld_z_diag_solver_clone.f90 b/mlprec/impl/solver/mld_z_diag_solver_clone.f90 index 508b503e..a576d499 100644 --- a/mlprec/impl/solver/mld_z_diag_solver_clone.f90 +++ b/mlprec/impl/solver/mld_z_diag_solver_clone.f90 @@ -57,14 +57,14 @@ subroutine mld_z_diag_solver_clone(sv,svout,info) if (info == psb_success_) deallocate(svout, stat=info) end if if (info == psb_success_) & - & allocate(mld_z_diag_solver_type :: svout, stat=info) + & allocate(svout, mold=sv, stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ goto 9999 end if select type(svo => svout) - type is (mld_z_diag_solver_type) + class is (mld_z_diag_solver_type) call psb_safe_ab_cpy(sv%d,svo%d,info) if (info == psb_success_) & & call sv%dv%clone(svo%dv,info) diff --git a/mlprec/impl/solver/mld_z_diag_solver_dmp.f90 b/mlprec/impl/solver/mld_z_diag_solver_dmp.f90 index fe69026d..78663f21 100644 --- a/mlprec/impl/solver/mld_z_diag_solver_dmp.f90 +++ b/mlprec/impl/solver/mld_z_diag_solver_dmp.f90 @@ -81,3 +81,49 @@ subroutine mld_z_diag_solver_dmp(sv,ictxt,level,info,prefix,head,solver) end if end subroutine mld_z_diag_solver_dmp +subroutine mld_z_l1_diag_solver_dmp(sv,ictxt,level,info,prefix,head,solver) + + use psb_base_mod + use mld_z_l1_diag_solver, mld_protect_name => mld_z_l1_diag_solver_dmp + implicit none + class(mld_z_l1_diag_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(in) :: ictxt,level + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: solver + integer(psb_ipk_) :: i, j, il1, iln, lname, lev + integer(psb_ipk_) :: icontxt,iam, np + character(len=80) :: prefix_ + character(len=120) :: fname ! len should be at least 20 more than + logical :: solver_ + ! len of prefix_ + + info = 0 + + + call psb_info(ictxt,iam,np) + + if (present(solver)) then + solver_ = solver + else + solver_ = .false. + end if + + if (solver_) then + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_slv_z" + end if + lname = len_trim(prefix_) + fname = trim(prefix_) + write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam + lname = lname + 5 + + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_l1_diag.mtx' + if (allocated(sv%d)) & + & call psb_geprt(fname,sv%d,head=head) + + end if + +end subroutine mld_z_l1_diag_solver_dmp diff --git a/mlprec/mld_base_prec_type.F90 b/mlprec/mld_base_prec_type.F90 index c6d3957e..a371390b 100644 --- a/mlprec/mld_base_prec_type.F90 +++ b/mlprec/mld_base_prec_type.F90 @@ -206,10 +206,11 @@ module mld_base_prec_type integer(psb_ipk_), parameter :: mld_noprec_ = 0 integer(psb_ipk_), parameter :: mld_base_smooth_ = 0 integer(psb_ipk_), parameter :: mld_jac_ = 1 - integer(psb_ipk_), parameter :: mld_bjac_ = 2 - integer(psb_ipk_), parameter :: mld_as_ = 3 - integer(psb_ipk_), parameter :: mld_max_prec_ = 3 - integer(psb_ipk_), parameter :: mld_fbgs_ = 4 + integer(psb_ipk_), parameter :: mld_l1_jac_ = 2 + integer(psb_ipk_), parameter :: mld_bjac_ = 3 + integer(psb_ipk_), parameter :: mld_as_ = 4 + integer(psb_ipk_), parameter :: mld_max_prec_ = 4 + integer(psb_ipk_), parameter :: mld_fbgs_ = mld_max_prec_+1 ! ! Constants for pre/post signaling. Now only used internally ! @@ -225,16 +226,17 @@ module mld_base_prec_type integer(psb_ipk_), parameter :: mld_slv_delta_ = mld_max_prec_+1 integer(psb_ipk_), parameter :: mld_f_none_ = mld_slv_delta_+0 integer(psb_ipk_), parameter :: mld_diag_scale_ = mld_slv_delta_+1 - integer(psb_ipk_), parameter :: mld_gs_ = mld_slv_delta_+2 - integer(psb_ipk_), parameter :: mld_ilu_n_ = mld_slv_delta_+3 - integer(psb_ipk_), parameter :: mld_milu_n_ = mld_slv_delta_+4 - integer(psb_ipk_), parameter :: mld_ilu_t_ = mld_slv_delta_+5 - integer(psb_ipk_), parameter :: mld_slu_ = mld_slv_delta_+6 - integer(psb_ipk_), parameter :: mld_umf_ = mld_slv_delta_+7 - integer(psb_ipk_), parameter :: mld_sludist_ = mld_slv_delta_+8 - integer(psb_ipk_), parameter :: mld_mumps_ = mld_slv_delta_+9 - integer(psb_ipk_), parameter :: mld_bwgs_ = mld_slv_delta_+10 - integer(psb_ipk_), parameter :: mld_max_sub_solve_ = mld_slv_delta_+10 + integer(psb_ipk_), parameter :: mld_l1_diag_scale_ = mld_slv_delta_+2 + integer(psb_ipk_), parameter :: mld_gs_ = mld_slv_delta_+3 + integer(psb_ipk_), parameter :: mld_ilu_n_ = mld_slv_delta_+4 + integer(psb_ipk_), parameter :: mld_milu_n_ = mld_slv_delta_+5 + integer(psb_ipk_), parameter :: mld_ilu_t_ = mld_slv_delta_+6 + integer(psb_ipk_), parameter :: mld_slu_ = mld_slv_delta_+7 + integer(psb_ipk_), parameter :: mld_umf_ = mld_slv_delta_+8 + integer(psb_ipk_), parameter :: mld_sludist_ = mld_slv_delta_+9 + integer(psb_ipk_), parameter :: mld_mumps_ = mld_slv_delta_+10 + integer(psb_ipk_), parameter :: mld_bwgs_ = mld_slv_delta_+11 + integer(psb_ipk_), parameter :: mld_max_sub_solve_ = mld_slv_delta_+11 integer(psb_ipk_), parameter :: mld_min_sub_solve_ = mld_diag_scale_ ! @@ -383,9 +385,9 @@ module mld_base_prec_type character(len=15), parameter :: & & mld_fact_names(0:mld_max_sub_solve_)=(/& & 'none ','Jacobi ',& - & 'none ','none ',& + & 'L1-Jacobi ','none ','none ',& & 'none ','Point Jacobi ',& - & 'Gauss-Seidel ','ILU(n) ',& + & 'L1-Jacobi ','Gauss-Seidel ','ILU(n) ',& & 'MILU(n) ','ILU(t,n) ',& & 'SuperLU ','UMFPACK LU ',& & 'SuperLU_Dist ','MUMPS ',& @@ -465,6 +467,8 @@ contains val = mld_sludist_ case('DIAG') val = mld_diag_scale_ + case('L1-DIAG') + val = mld_l1_diag_scale_ case('ADD') val = mld_add_ml_ case('MULT_DEV') @@ -507,6 +511,8 @@ contains val = mld_bjac_ case('JAC','JACOBI') val = mld_jac_ + case('L1-JACOBI') + val = mld_l1_jac_ case('AS') val = mld_as_ case('A_NORMI') diff --git a/mlprec/mld_c_diag_solver.f90 b/mlprec/mld_c_diag_solver.f90 index f6fb8323..e1b3ac84 100644 --- a/mlprec/mld_c_diag_solver.f90 +++ b/mlprec/mld_c_diag_solver.f90 @@ -274,3 +274,99 @@ contains end function c_diag_solver_get_id end module mld_c_diag_solver + + +module mld_c_l1_diag_solver + + use mld_c_diag_solver + + type, extends(mld_c_diag_solver_type) :: mld_c_l1_diag_solver_type + contains + procedure, pass(sv) :: dump => mld_c_l1_diag_solver_dmp + procedure, pass(sv) :: build => mld_c_l1_diag_solver_bld + procedure, pass(sv) :: descr => c_l1_diag_solver_descr + procedure, nopass :: get_fmt => c_l1_diag_solver_get_fmt + procedure, nopass :: get_id => c_l1_diag_solver_get_id + end type mld_c_l1_diag_solver_type + + + private :: c_l1_diag_solver_descr, & + & c_l1_diag_solver_get_fmt, c_l1_diag_solver_get_id + + interface + subroutine mld_c_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) + import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, & + & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, & + & mld_c_l1_diag_solver_type, psb_ipk_, psb_i_base_vect_type + type(psb_cspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(mld_c_l1_diag_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + type(psb_cspmat_type), intent(in), target, optional :: b + class(psb_c_base_sparse_mat), intent(in), optional :: amold + class(psb_c_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + end subroutine mld_c_l1_diag_solver_bld + end interface + + interface + subroutine mld_c_l1_diag_solver_dmp(sv,ictxt,level,info,prefix,head,solver) + import :: psb_desc_type, mld_c_l1_diag_solver_type, psb_c_vect_type, psb_spk_, & + & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, & + & psb_ipk_ + implicit none + class(mld_c_l1_diag_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(in) :: ictxt + integer(psb_ipk_), intent(in) :: level + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: solver + end subroutine mld_c_l1_diag_solver_dmp + end interface + +contains + + subroutine c_l1_diag_solver_descr(sv,info,iout,coarse) + + Implicit None + + ! Arguments + class(mld_c_l1_diag_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + logical, intent(in), optional :: coarse + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='mld_c_l1_diag_solver_descr' + integer(psb_ipk_) :: iout_ + + info = psb_success_ + if (present(iout)) then + iout_ = iout + else + iout_ = psb_out_unit + endif + + write(iout_,*) ' L1 Diagonal solver ' + + return + + end subroutine c_l1_diag_solver_descr + + function c_l1_diag_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "L1 Diag solver" + end function c_l1_diag_solver_get_fmt + + function c_l1_diag_solver_get_id() result(val) + implicit none + integer(psb_ipk_) :: val + + val = mld_l1_diag_scale_ + end function c_l1_diag_solver_get_id + +end module mld_c_l1_diag_solver + diff --git a/mlprec/mld_c_prec_mod.f90 b/mlprec/mld_c_prec_mod.f90 index 990e4055..e3b46672 100644 --- a/mlprec/mld_c_prec_mod.f90 +++ b/mlprec/mld_c_prec_mod.f90 @@ -49,6 +49,7 @@ module mld_c_prec_mod use mld_c_as_smoother use mld_c_id_solver use mld_c_diag_solver + use mld_c_l1_diag_solver use mld_c_ilu_solver use mld_c_gs_solver diff --git a/mlprec/mld_d_diag_solver.f90 b/mlprec/mld_d_diag_solver.f90 index 2d713cca..b3a6cb47 100644 --- a/mlprec/mld_d_diag_solver.f90 +++ b/mlprec/mld_d_diag_solver.f90 @@ -274,3 +274,99 @@ contains end function d_diag_solver_get_id end module mld_d_diag_solver + + +module mld_d_l1_diag_solver + + use mld_d_diag_solver + + type, extends(mld_d_diag_solver_type) :: mld_d_l1_diag_solver_type + contains + procedure, pass(sv) :: dump => mld_d_l1_diag_solver_dmp + procedure, pass(sv) :: build => mld_d_l1_diag_solver_bld + procedure, pass(sv) :: descr => d_l1_diag_solver_descr + procedure, nopass :: get_fmt => d_l1_diag_solver_get_fmt + procedure, nopass :: get_id => d_l1_diag_solver_get_id + end type mld_d_l1_diag_solver_type + + + private :: d_l1_diag_solver_descr, & + & d_l1_diag_solver_get_fmt, d_l1_diag_solver_get_id + + interface + subroutine mld_d_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) + import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, & + & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, & + & mld_d_l1_diag_solver_type, psb_ipk_, psb_i_base_vect_type + type(psb_dspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(mld_d_l1_diag_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + type(psb_dspmat_type), intent(in), target, optional :: b + class(psb_d_base_sparse_mat), intent(in), optional :: amold + class(psb_d_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + end subroutine mld_d_l1_diag_solver_bld + end interface + + interface + subroutine mld_d_l1_diag_solver_dmp(sv,ictxt,level,info,prefix,head,solver) + import :: psb_desc_type, mld_d_l1_diag_solver_type, psb_d_vect_type, psb_dpk_, & + & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, & + & psb_ipk_ + implicit none + class(mld_d_l1_diag_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(in) :: ictxt + integer(psb_ipk_), intent(in) :: level + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: solver + end subroutine mld_d_l1_diag_solver_dmp + end interface + +contains + + subroutine d_l1_diag_solver_descr(sv,info,iout,coarse) + + Implicit None + + ! Arguments + class(mld_d_l1_diag_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + logical, intent(in), optional :: coarse + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='mld_d_l1_diag_solver_descr' + integer(psb_ipk_) :: iout_ + + info = psb_success_ + if (present(iout)) then + iout_ = iout + else + iout_ = psb_out_unit + endif + + write(iout_,*) ' L1 Diagonal solver ' + + return + + end subroutine d_l1_diag_solver_descr + + function d_l1_diag_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "L1 Diag solver" + end function d_l1_diag_solver_get_fmt + + function d_l1_diag_solver_get_id() result(val) + implicit none + integer(psb_ipk_) :: val + + val = mld_l1_diag_scale_ + end function d_l1_diag_solver_get_id + +end module mld_d_l1_diag_solver + diff --git a/mlprec/mld_d_prec_mod.f90 b/mlprec/mld_d_prec_mod.f90 index aff3a958..c0822a2d 100644 --- a/mlprec/mld_d_prec_mod.f90 +++ b/mlprec/mld_d_prec_mod.f90 @@ -49,6 +49,7 @@ module mld_d_prec_mod use mld_d_as_smoother use mld_d_id_solver use mld_d_diag_solver + use mld_d_l1_diag_solver use mld_d_ilu_solver use mld_d_gs_solver diff --git a/mlprec/mld_s_diag_solver.f90 b/mlprec/mld_s_diag_solver.f90 index 5b36d49e..18b4b7bc 100644 --- a/mlprec/mld_s_diag_solver.f90 +++ b/mlprec/mld_s_diag_solver.f90 @@ -274,3 +274,99 @@ contains end function s_diag_solver_get_id end module mld_s_diag_solver + + +module mld_s_l1_diag_solver + + use mld_s_diag_solver + + type, extends(mld_s_diag_solver_type) :: mld_s_l1_diag_solver_type + contains + procedure, pass(sv) :: dump => mld_s_l1_diag_solver_dmp + procedure, pass(sv) :: build => mld_s_l1_diag_solver_bld + procedure, pass(sv) :: descr => s_l1_diag_solver_descr + procedure, nopass :: get_fmt => s_l1_diag_solver_get_fmt + procedure, nopass :: get_id => s_l1_diag_solver_get_id + end type mld_s_l1_diag_solver_type + + + private :: s_l1_diag_solver_descr, & + & s_l1_diag_solver_get_fmt, s_l1_diag_solver_get_id + + interface + subroutine mld_s_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) + import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, & + & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, & + & mld_s_l1_diag_solver_type, psb_ipk_, psb_i_base_vect_type + type(psb_sspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(mld_s_l1_diag_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + type(psb_sspmat_type), intent(in), target, optional :: b + class(psb_s_base_sparse_mat), intent(in), optional :: amold + class(psb_s_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + end subroutine mld_s_l1_diag_solver_bld + end interface + + interface + subroutine mld_s_l1_diag_solver_dmp(sv,ictxt,level,info,prefix,head,solver) + import :: psb_desc_type, mld_s_l1_diag_solver_type, psb_s_vect_type, psb_spk_, & + & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, & + & psb_ipk_ + implicit none + class(mld_s_l1_diag_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(in) :: ictxt + integer(psb_ipk_), intent(in) :: level + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: solver + end subroutine mld_s_l1_diag_solver_dmp + end interface + +contains + + subroutine s_l1_diag_solver_descr(sv,info,iout,coarse) + + Implicit None + + ! Arguments + class(mld_s_l1_diag_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + logical, intent(in), optional :: coarse + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='mld_s_l1_diag_solver_descr' + integer(psb_ipk_) :: iout_ + + info = psb_success_ + if (present(iout)) then + iout_ = iout + else + iout_ = psb_out_unit + endif + + write(iout_,*) ' L1 Diagonal solver ' + + return + + end subroutine s_l1_diag_solver_descr + + function s_l1_diag_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "L1 Diag solver" + end function s_l1_diag_solver_get_fmt + + function s_l1_diag_solver_get_id() result(val) + implicit none + integer(psb_ipk_) :: val + + val = mld_l1_diag_scale_ + end function s_l1_diag_solver_get_id + +end module mld_s_l1_diag_solver + diff --git a/mlprec/mld_s_prec_mod.f90 b/mlprec/mld_s_prec_mod.f90 index 15655dba..baf88de6 100644 --- a/mlprec/mld_s_prec_mod.f90 +++ b/mlprec/mld_s_prec_mod.f90 @@ -49,6 +49,7 @@ module mld_s_prec_mod use mld_s_as_smoother use mld_s_id_solver use mld_s_diag_solver + use mld_s_l1_diag_solver use mld_s_ilu_solver use mld_s_gs_solver diff --git a/mlprec/mld_z_diag_solver.f90 b/mlprec/mld_z_diag_solver.f90 index 6adbd5d7..1928c505 100644 --- a/mlprec/mld_z_diag_solver.f90 +++ b/mlprec/mld_z_diag_solver.f90 @@ -274,3 +274,99 @@ contains end function z_diag_solver_get_id end module mld_z_diag_solver + + +module mld_z_l1_diag_solver + + use mld_z_diag_solver + + type, extends(mld_z_diag_solver_type) :: mld_z_l1_diag_solver_type + contains + procedure, pass(sv) :: dump => mld_z_l1_diag_solver_dmp + procedure, pass(sv) :: build => mld_z_l1_diag_solver_bld + procedure, pass(sv) :: descr => z_l1_diag_solver_descr + procedure, nopass :: get_fmt => z_l1_diag_solver_get_fmt + procedure, nopass :: get_id => z_l1_diag_solver_get_id + end type mld_z_l1_diag_solver_type + + + private :: z_l1_diag_solver_descr, & + & z_l1_diag_solver_get_fmt, z_l1_diag_solver_get_id + + interface + subroutine mld_z_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) + import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, & + & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, & + & mld_z_l1_diag_solver_type, psb_ipk_, psb_i_base_vect_type + type(psb_zspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(mld_z_l1_diag_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + type(psb_zspmat_type), intent(in), target, optional :: b + class(psb_z_base_sparse_mat), intent(in), optional :: amold + class(psb_z_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + end subroutine mld_z_l1_diag_solver_bld + end interface + + interface + subroutine mld_z_l1_diag_solver_dmp(sv,ictxt,level,info,prefix,head,solver) + import :: psb_desc_type, mld_z_l1_diag_solver_type, psb_z_vect_type, psb_dpk_, & + & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, & + & psb_ipk_ + implicit none + class(mld_z_l1_diag_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(in) :: ictxt + integer(psb_ipk_), intent(in) :: level + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: solver + end subroutine mld_z_l1_diag_solver_dmp + end interface + +contains + + subroutine z_l1_diag_solver_descr(sv,info,iout,coarse) + + Implicit None + + ! Arguments + class(mld_z_l1_diag_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + logical, intent(in), optional :: coarse + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='mld_z_l1_diag_solver_descr' + integer(psb_ipk_) :: iout_ + + info = psb_success_ + if (present(iout)) then + iout_ = iout + else + iout_ = psb_out_unit + endif + + write(iout_,*) ' L1 Diagonal solver ' + + return + + end subroutine z_l1_diag_solver_descr + + function z_l1_diag_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "L1 Diag solver" + end function z_l1_diag_solver_get_fmt + + function z_l1_diag_solver_get_id() result(val) + implicit none + integer(psb_ipk_) :: val + + val = mld_l1_diag_scale_ + end function z_l1_diag_solver_get_id + +end module mld_z_l1_diag_solver + diff --git a/mlprec/mld_z_prec_mod.f90 b/mlprec/mld_z_prec_mod.f90 index f1c0443a..d9f979ff 100644 --- a/mlprec/mld_z_prec_mod.f90 +++ b/mlprec/mld_z_prec_mod.f90 @@ -49,6 +49,7 @@ module mld_z_prec_mod use mld_z_as_smoother use mld_z_id_solver use mld_z_diag_solver + use mld_z_l1_diag_solver use mld_z_ilu_solver use mld_z_gs_solver