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

Changes for new L1-Jacobi smoother/solver.

Browse Source
This commit is contained in:
Salvatore Filippone
2019-05-07 17:24:01 +01:00
parent b2047f95e0
commit 88976ec108
33 changed files with 1000 additions and 62 deletions
Download Patch File Download Diff File Expand all files Collapse all files
mlprec/impl/level/mld_c_base_onelev_cseti.F90
+19 -8
View File
@@ -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)
mlprec/impl/level/mld_d_base_onelev_cseti.F90
+20 -9
View File
@@ -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)
mlprec/impl/level/mld_s_base_onelev_cseti.F90
+19 -8
View File
@@ -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)
mlprec/impl/level/mld_z_base_onelev_cseti.F90
+20 -9
View File
@@ -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)
mlprec/impl/mld_c_smoothers_bld.f90
+1 -1
View File
@@ -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 ',&
mlprec/impl/mld_ccprecset.F90
+1
View File
@@ -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
mlprec/impl/mld_d_smoothers_bld.f90
+1 -1
View File
@@ -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 ',&
mlprec/impl/mld_dcprecset.F90
+1
View File
@@ -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
mlprec/impl/mld_s_smoothers_bld.f90
+1 -1
View File
@@ -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 ',&
mlprec/impl/mld_scprecset.F90
+1
View File
@@ -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
mlprec/impl/mld_z_smoothers_bld.f90
+1 -1
View File
@@ -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 ',&
mlprec/impl/mld_zcprecset.F90
+1
View File
@@ -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
mlprec/impl/solver/mld_c_diag_solver_bld.f90
+78
View File
@@ -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
mlprec/impl/solver/mld_c_diag_solver_clone.f90
+2 -2
View File
@@ -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)
mlprec/impl/solver/mld_c_diag_solver_dmp.f90
+46
View File
@@ -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
mlprec/impl/solver/mld_d_diag_solver_bld.f90
+78
View File
@@ -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
mlprec/impl/solver/mld_d_diag_solver_clone.f90
+2 -2
View File
@@ -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)
mlprec/impl/solver/mld_d_diag_solver_dmp.f90
+46
View File
@@ -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
mlprec/impl/solver/mld_s_diag_solver_bld.f90
+78
View File
@@ -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
mlprec/impl/solver/mld_s_diag_solver_clone.f90
+2 -2
View File
@@ -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)
mlprec/impl/solver/mld_s_diag_solver_dmp.f90
+46
View File
@@ -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
mlprec/impl/solver/mld_z_diag_solver_bld.f90
+78
View File
@@ -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
mlprec/impl/solver/mld_z_diag_solver_clone.f90
+2 -2
View File
@@ -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)
mlprec/impl/solver/mld_z_diag_solver_dmp.f90
+46
View File
@@ -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
mlprec/mld_base_prec_type.F90
+22 -16
View File
@@ -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')
mlprec/mld_c_diag_solver.f90
+96
View File
@@ -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
mlprec/mld_c_prec_mod.f90
+1
View File
@@ -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
mlprec/mld_d_diag_solver.f90
+96
View File
@@ -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
mlprec/mld_d_prec_mod.f90
+1
View File
@@ -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
mlprec/mld_s_diag_solver.f90
+96
View File
@@ -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
mlprec/mld_s_prec_mod.f90
+1
View File
@@ -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
mlprec/mld_z_diag_solver.f90
+96
View File
@@ -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
mlprec/mld_z_prec_mod.f90
+1
View File
@@ -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