From 441c607c4a7ce2eac285ad3000b54200e439851c Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 5 May 2020 14:03:35 +0200 Subject: [PATCH] Added L1-BJAC smoother. --- mlprec/impl/level/mld_d_base_onelev_csetc.F90 | 5 + mlprec/impl/level/mld_d_base_onelev_cseti.F90 | 5 + mlprec/impl/mld_d_smoothers_bld.f90 | 2 +- mlprec/impl/mld_dcprecset.F90 | 16 +- mlprec/impl/smoother/Makefile | 14 +- .../impl/smoother/mld_c_jac_smoother_bld.f90 | 2 - .../smoother/mld_c_l1_jac_smoother_bld.f90 | 149 ++++++++++++++++++ .../smoother/mld_c_l1_jac_smoother_clone.f90 | 88 +++++++++++ .../smoother/mld_c_l1_jac_smoother_descr.f90 | 103 ++++++++++++ .../impl/smoother/mld_d_jac_smoother_bld.f90 | 2 - .../smoother/mld_d_l1_jac_smoother_bld.f90 | 149 ++++++++++++++++++ .../smoother/mld_d_l1_jac_smoother_clone.f90 | 88 +++++++++++ .../smoother/mld_d_l1_jac_smoother_descr.f90 | 103 ++++++++++++ .../impl/smoother/mld_s_jac_smoother_bld.f90 | 2 - .../smoother/mld_s_l1_jac_smoother_bld.f90 | 149 ++++++++++++++++++ .../smoother/mld_s_l1_jac_smoother_clone.f90 | 88 +++++++++++ .../smoother/mld_s_l1_jac_smoother_descr.f90 | 103 ++++++++++++ .../impl/smoother/mld_z_jac_smoother_bld.f90 | 2 - .../smoother/mld_z_l1_jac_smoother_bld.f90 | 149 ++++++++++++++++++ .../smoother/mld_z_l1_jac_smoother_clone.f90 | 88 +++++++++++ .../smoother/mld_z_l1_jac_smoother_descr.f90 | 103 ++++++++++++ mlprec/mld_base_prec_type.F90 | 14 +- mlprec/mld_d_jac_smoother.f90 | 60 +++++++ 23 files changed, 1463 insertions(+), 21 deletions(-) create mode 100644 mlprec/impl/smoother/mld_c_l1_jac_smoother_bld.f90 create mode 100644 mlprec/impl/smoother/mld_c_l1_jac_smoother_clone.f90 create mode 100644 mlprec/impl/smoother/mld_c_l1_jac_smoother_descr.f90 create mode 100644 mlprec/impl/smoother/mld_d_l1_jac_smoother_bld.f90 create mode 100644 mlprec/impl/smoother/mld_d_l1_jac_smoother_clone.f90 create mode 100644 mlprec/impl/smoother/mld_d_l1_jac_smoother_descr.f90 create mode 100644 mlprec/impl/smoother/mld_s_l1_jac_smoother_bld.f90 create mode 100644 mlprec/impl/smoother/mld_s_l1_jac_smoother_clone.f90 create mode 100644 mlprec/impl/smoother/mld_s_l1_jac_smoother_descr.f90 create mode 100644 mlprec/impl/smoother/mld_z_l1_jac_smoother_bld.f90 create mode 100644 mlprec/impl/smoother/mld_z_l1_jac_smoother_clone.f90 create mode 100644 mlprec/impl/smoother/mld_z_l1_jac_smoother_descr.f90 diff --git a/mlprec/impl/level/mld_d_base_onelev_csetc.F90 b/mlprec/impl/level/mld_d_base_onelev_csetc.F90 index dad1541b..543184ef 100644 --- a/mlprec/impl/level/mld_d_base_onelev_csetc.F90 +++ b/mlprec/impl/level/mld_d_base_onelev_csetc.F90 @@ -77,6 +77,7 @@ subroutine mld_d_base_onelev_csetc(lv,what,val,info,pos,idx) integer(psb_ipk_) :: ival 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_l1_jac_smoother_type) :: mld_d_l1_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 @@ -137,6 +138,10 @@ subroutine mld_d_base_onelev_csetc(lv,what,val,info,pos,idx) call lv%set(mld_d_jac_smoother_mold,info,pos=pos) if (info == 0) call lv%set(mld_d_ilu_solver_mold,info,pos=pos) + case ('L1-BJAC') + call lv%set(mld_d_l1_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_d_ilu_solver_mold,info,pos=pos) + case ('AS') call lv%set(mld_d_as_smoother_mold,info,pos=pos) if (info == 0) call lv%set(mld_d_ilu_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 1d2faeb9..dcc643f6 100644 --- a/mlprec/impl/level/mld_d_base_onelev_cseti.F90 +++ b/mlprec/impl/level/mld_d_base_onelev_cseti.F90 @@ -76,6 +76,7 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos,idx) 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_l1_jac_smoother_type) :: mld_d_l1_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 @@ -131,6 +132,10 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos,idx) call lv%set(mld_d_jac_smoother_mold,info,pos=pos) if (info == 0) call lv%set(mld_d_ilu_solver_mold,info,pos=pos) + case (mld_l1_bjac_) + call lv%set(mld_d_l1_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_d_ilu_solver_mold,info,pos=pos) + case (mld_as_) call lv%set(mld_d_as_smoother_mold,info,pos=pos) if (info == 0) call lv%set(mld_d_ilu_solver_mold,info,pos=pos) diff --git a/mlprec/impl/mld_d_smoothers_bld.f90 b/mlprec/impl/mld_d_smoothers_bld.f90 index 167cca50..dfed9902 100644 --- a/mlprec/impl/mld_d_smoothers_bld.f90 +++ b/mlprec/impl/mld_d_smoothers_bld.f90 @@ -256,7 +256,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_, mld_l1_jac_) + case(mld_bjac_,mld_l1_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 3345087c..be551424 100644 --- a/mlprec/impl/mld_dcprecset.F90 +++ b/mlprec/impl/mld_dcprecset.F90 @@ -197,8 +197,8 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx) if (nlev_ > 1) then call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos) select case (val) - case(mld_bjac_) - call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + case(mld_bjac_,mld_l1_bjac_) + call p%precv(nlev_)%set('SMOOTHER_TYPE',val,info,pos=pos) #if defined(HAVE_UMF_) call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos) #elif defined(HAVE_SLU_) @@ -345,8 +345,8 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx) if (nlev_ > 1) then call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos) select case (val) - case(mld_bjac_) - call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + case(mld_bjac_,mld_l1_bjac_) + call p%precv(nlev_)%set('SMOOTHER_TYPE',val,info,pos=pos) #if defined(HAVE_UMF_) call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos) #elif defined(HAVE_SLU_) @@ -612,8 +612,8 @@ subroutine mld_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx) if (nlev_ > 1) then call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos) select case (psb_toupper(trim(string))) - case('BJAC') - call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos) + case('BJAC', 'L1_BJAC') + call p%precv(nlev_)%set('SMOOTHER_TYPE',psb_toupper(trim(string)),info,pos=pos) #if defined(HAVE_UMF_) call p%precv(nlev_)%set('SUB_SOLVE','UMF',info,pos=pos) #elif defined(HAVE_SLU_) @@ -742,8 +742,8 @@ subroutine mld_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx) if (nlev_ > 1) then call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos) select case (string) - case('BJAC') - call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos) + case('BJAC', 'L1_BJAC') + call p%precv(nlev_)%set('SMOOTHER_TYPE',psb_toupper(trim(string)),info,pos=pos) #if defined(HAVE_UMF_) call p%precv(nlev_)%set('SUB_SOLVE','UMF',info,pos=pos) #elif defined(HAVE_SLU_) diff --git a/mlprec/impl/smoother/Makefile b/mlprec/impl/smoother/Makefile index f929a99f..6e268af2 100644 --- a/mlprec/impl/smoother/Makefile +++ b/mlprec/impl/smoother/Makefile @@ -43,6 +43,9 @@ mld_c_jac_smoother_cnv.o \ mld_c_jac_smoother_csetc.o \ mld_c_jac_smoother_cseti.o \ mld_c_jac_smoother_csetr.o \ +mld_c_l1_jac_smoother_bld.o \ +mld_c_l1_jac_smoother_descr.o \ +mld_c_l1_jac_smoother_clone.o \ mld_d_as_smoother_apply.o \ mld_d_as_smoother_apply_vect.o \ mld_d_as_smoother_bld.o \ @@ -79,6 +82,9 @@ mld_d_jac_smoother_cnv.o \ mld_d_jac_smoother_csetc.o \ mld_d_jac_smoother_cseti.o \ mld_d_jac_smoother_csetr.o \ +mld_d_l1_jac_smoother_bld.o \ +mld_d_l1_jac_smoother_descr.o \ +mld_d_l1_jac_smoother_clone.o \ mld_s_as_smoother_apply.o \ mld_s_as_smoother_apply_vect.o \ mld_s_as_smoother_bld.o \ @@ -115,6 +121,9 @@ mld_s_jac_smoother_cnv.o \ mld_s_jac_smoother_csetc.o \ mld_s_jac_smoother_cseti.o \ mld_s_jac_smoother_csetr.o \ +mld_s_l1_jac_smoother_bld.o \ +mld_s_l1_jac_smoother_descr.o \ +mld_s_l1_jac_smoother_clone.o \ mld_z_as_smoother_apply.o \ mld_z_as_smoother_apply_vect.o \ mld_z_as_smoother_bld.o \ @@ -150,7 +159,10 @@ mld_z_jac_smoother_clone.o \ mld_z_jac_smoother_cnv.o \ mld_z_jac_smoother_csetc.o \ mld_z_jac_smoother_cseti.o \ -mld_z_jac_smoother_csetr.o +mld_z_jac_smoother_csetr.o \ +mld_z_l1_jac_smoother_bld.o \ +mld_z_l1_jac_smoother_descr.o \ +mld_z_l1_jac_smoother_clone.o \ LIBNAME=libmld_prec.a diff --git a/mlprec/impl/smoother/mld_c_jac_smoother_bld.f90 b/mlprec/impl/smoother/mld_c_jac_smoother_bld.f90 index 556d7fe2..4be96326 100644 --- a/mlprec/impl/smoother/mld_c_jac_smoother_bld.f90 +++ b/mlprec/impl/smoother/mld_c_jac_smoother_bld.f90 @@ -52,8 +52,6 @@ subroutine mld_c_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) class(psb_i_base_vect_type), intent(in), optional :: imold ! Local variables integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nzeros - complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) - type(psb_c_coo_sparse_mat) :: tmpcoo integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level character(len=20) :: name='c_jac_smoother_bld', ch_err diff --git a/mlprec/impl/smoother/mld_c_l1_jac_smoother_bld.f90 b/mlprec/impl/smoother/mld_c_l1_jac_smoother_bld.f90 new file mode 100644 index 00000000..16af38ce --- /dev/null +++ b/mlprec/impl/smoother/mld_c_l1_jac_smoother_bld.f90 @@ -0,0 +1,149 @@ +! +! +! MLD2P4 version 2.2 +! MultiLevel Domain Decomposition Parallel Preconditioners Package +! based on PSBLAS (Parallel Sparse BLAS version 3.5) +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the MLD2P4 group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine mld_c_l1_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) + + use psb_base_mod + use mld_c_diag_solver + use mld_c_jac_smoother, mld_protect_name => mld_c_l1_jac_smoother_bld + Implicit None + + ! Arguments + type(psb_cspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(mld_c_l1_jac_smoother_type), intent(inout) :: sm + integer(psb_ipk_), intent(out) :: info + 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, nzeros + real(psb_spk_), allocatable :: arwsum(:) + type(psb_c_coo_sparse_mat) :: tmpcoo + type(psb_c_csr_sparse_mat) :: tmpcsr + type(psb_cspmat_type) :: tmpa + integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level, nz + character(len=20) :: name='c_l1_jac_smoother_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() + n_col = desc_a%get_local_cols() + nrow_a = a%get_nrows() + nztota = a%get_nzeros() + + if( sm%checkres ) sm%pa => a + + select type (smsv => sm%sv) + class is (mld_c_diag_solver_type) + call sm%nd%free() + sm%pa => a + sm%nd_nnz_tot = nztota + + call psb_sum(ictxt,sm%nd_nnz_tot) + call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold) + + class default + if (smsv%is_global()) then + ! Do not put anything into SM%ND since the solver + ! is acting globally. + call sm%nd%free() + sm%nd_nnz_tot = 0 + call psb_sum(ictxt,sm%nd_nnz_tot) + call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold) + else + call a%csclip(sm%nd,info,& + & jmin=nrow_a+1,rscale=.false.,cscale=.false.) + if (info == psb_success_) then + if (present(amold)) then + call sm%nd%cscnv(info,& + & mold=amold,dupl=psb_dupl_add_) + else + call sm%nd%cscnv(info,& + & type='csr',dupl=psb_dupl_add_) + endif + end if + sm%nd_nnz_tot = sm%nd%get_nzeros() + call psb_sum(ictxt,sm%nd_nnz_tot) + arwsum = sm%nd%arwsum(info) + call a%cp_to(tmpcoo) + call tmpcoo%set_dupl(psb_dupl_add_) + nz = tmpcoo%get_nzeros() + call tmpcoo%reallocate(nz+n_row) + do i=1, n_row + tmpcoo%ia(nz+i) = i + tmpcoo%ja(nz+i) = i + tmpcoo%val(nz+i) = arwsum(i) + end do + call tmpcoo%set_nzeros(nz+n_row) + call tmpcoo%fix(info) + call tmpcoo%mv_to_fmt(tmpcsr,info) + call tmpa%mv_from(tmpcsr) + call sm%sv%build(tmpa,desc_a,info,amold=amold,vmold=vmold) + end if + end select + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='clip & psb_spcnv csr 4') + goto 9999 + end if + + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='solver build') + 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_jac_smoother_bld diff --git a/mlprec/impl/smoother/mld_c_l1_jac_smoother_clone.f90 b/mlprec/impl/smoother/mld_c_l1_jac_smoother_clone.f90 new file mode 100644 index 00000000..cbd80b81 --- /dev/null +++ b/mlprec/impl/smoother/mld_c_l1_jac_smoother_clone.f90 @@ -0,0 +1,88 @@ +! +! +! MLD2P4 version 2.2 +! MultiLevel Domain Decomposition Parallel Preconditioners Package +! based on PSBLAS (Parallel Sparse BLAS version 3.5) +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the MLD2P4 group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine mld_c_l1_jac_smoother_clone(sm,smout,info) + + use psb_base_mod + use mld_c_jac_smoother, mld_protect_name => mld_c_l1_jac_smoother_clone + + Implicit None + + ! Arguments + class(mld_c_l1_jac_smoother_type), intent(inout) :: sm + class(mld_c_base_smoother_type), allocatable, intent(inout) :: smout + integer(psb_ipk_), intent(out) :: info + ! Local variables + integer(psb_ipk_) :: err_act + + + info=psb_success_ + call psb_erractionsave(err_act) + + if (allocated(smout)) then + call smout%free(info) + if (info == psb_success_) deallocate(smout, stat=info) + end if + if (info == psb_success_) & + & allocate(mld_c_l1_jac_smoother_type :: smout, stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + + select type(smo => smout) + type is (mld_c_l1_jac_smoother_type) + smo%nd_nnz_tot = sm%nd_nnz_tot + call sm%nd%clone(smo%nd,info) + if ((info==psb_success_).and.(allocated(sm%sv))) then + allocate(smout%sv,mold=sm%sv,stat=info) + if (info == psb_success_) call sm%sv%clone(smo%sv,info) + end if + + class default + info = psb_err_internal_error_ + end select + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_c_l1_jac_smoother_clone diff --git a/mlprec/impl/smoother/mld_c_l1_jac_smoother_descr.f90 b/mlprec/impl/smoother/mld_c_l1_jac_smoother_descr.f90 new file mode 100644 index 00000000..1656652b --- /dev/null +++ b/mlprec/impl/smoother/mld_c_l1_jac_smoother_descr.f90 @@ -0,0 +1,103 @@ +! +! +! MLD2P4 version 2.2 +! MultiLevel Domain Decomposition Parallel Preconditioners Package +! based on PSBLAS (Parallel Sparse BLAS version 3.5) +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the MLD2P4 group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine mld_c_l1_jac_smoother_descr(sm,info,iout,coarse) + + use psb_base_mod + use mld_c_diag_solver + use mld_c_jac_smoother, mld_protect_name => mld_c_l1_jac_smoother_descr + use mld_c_diag_solver + use mld_c_gs_solver + + Implicit None + + ! Arguments + class(mld_c_l1_jac_smoother_type), intent(in) :: sm + 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_jac_smoother_descr' + integer(psb_ipk_) :: iout_ + logical :: coarse_ + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(coarse)) then + coarse_ = coarse + else + coarse_ = .false. + end if + if (present(iout)) then + iout_ = iout + else + iout_ = psb_out_unit + endif + + if (.not.coarse_) then + if (allocated(sm%sv)) then + select type(smv=>sm%sv) + class is (mld_c_diag_solver_type) + write(iout_,*) ' Point Jacobi ' + write(iout_,*) ' Local diagonal:' + call smv%descr(info,iout_,coarse=coarse) + class is (mld_c_bwgs_solver_type) + write(iout_,*) ' Hybrid Backward Gauss-Seidel ' + class is (mld_c_gs_solver_type) + write(iout_,*) ' Hybrid Forward Gauss-Seidel ' + class default + write(iout_,*) ' L1-Block Jacobi ' + write(iout_,*) ' Local solver details:' + call smv%descr(info,iout_,coarse=coarse) + end select + + else + write(iout_,*) ' L1-Block Jacobi ' + end if + else + if (allocated(sm%sv)) then + call sm%sv%descr(info,iout_,coarse=coarse) + end if + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine mld_c_l1_jac_smoother_descr diff --git a/mlprec/impl/smoother/mld_d_jac_smoother_bld.f90 b/mlprec/impl/smoother/mld_d_jac_smoother_bld.f90 index b1d44b6a..867b87d2 100644 --- a/mlprec/impl/smoother/mld_d_jac_smoother_bld.f90 +++ b/mlprec/impl/smoother/mld_d_jac_smoother_bld.f90 @@ -52,8 +52,6 @@ subroutine mld_d_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) class(psb_i_base_vect_type), intent(in), optional :: imold ! Local variables integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nzeros - real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) - type(psb_d_coo_sparse_mat) :: tmpcoo integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level character(len=20) :: name='d_jac_smoother_bld', ch_err diff --git a/mlprec/impl/smoother/mld_d_l1_jac_smoother_bld.f90 b/mlprec/impl/smoother/mld_d_l1_jac_smoother_bld.f90 new file mode 100644 index 00000000..ba0fc984 --- /dev/null +++ b/mlprec/impl/smoother/mld_d_l1_jac_smoother_bld.f90 @@ -0,0 +1,149 @@ +! +! +! MLD2P4 version 2.2 +! MultiLevel Domain Decomposition Parallel Preconditioners Package +! based on PSBLAS (Parallel Sparse BLAS version 3.5) +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the MLD2P4 group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine mld_d_l1_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) + + use psb_base_mod + use mld_d_diag_solver + use mld_d_jac_smoother, mld_protect_name => mld_d_l1_jac_smoother_bld + Implicit None + + ! Arguments + type(psb_dspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(mld_d_l1_jac_smoother_type), intent(inout) :: sm + integer(psb_ipk_), intent(out) :: info + 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, nzeros + real(psb_dpk_), allocatable :: arwsum(:) + type(psb_d_coo_sparse_mat) :: tmpcoo + type(psb_d_csr_sparse_mat) :: tmpcsr + type(psb_dspmat_type) :: tmpa + integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level, nz + character(len=20) :: name='d_l1_jac_smoother_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() + n_col = desc_a%get_local_cols() + nrow_a = a%get_nrows() + nztota = a%get_nzeros() + + if( sm%checkres ) sm%pa => a + + select type (smsv => sm%sv) + class is (mld_d_diag_solver_type) + call sm%nd%free() + sm%pa => a + sm%nd_nnz_tot = nztota + + call psb_sum(ictxt,sm%nd_nnz_tot) + call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold) + + class default + if (smsv%is_global()) then + ! Do not put anything into SM%ND since the solver + ! is acting globally. + call sm%nd%free() + sm%nd_nnz_tot = 0 + call psb_sum(ictxt,sm%nd_nnz_tot) + call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold) + else + call a%csclip(sm%nd,info,& + & jmin=nrow_a+1,rscale=.false.,cscale=.false.) + if (info == psb_success_) then + if (present(amold)) then + call sm%nd%cscnv(info,& + & mold=amold,dupl=psb_dupl_add_) + else + call sm%nd%cscnv(info,& + & type='csr',dupl=psb_dupl_add_) + endif + end if + sm%nd_nnz_tot = sm%nd%get_nzeros() + call psb_sum(ictxt,sm%nd_nnz_tot) + arwsum = sm%nd%arwsum(info) + call a%cp_to(tmpcoo) + call tmpcoo%set_dupl(psb_dupl_add_) + nz = tmpcoo%get_nzeros() + call tmpcoo%reallocate(nz+n_row) + do i=1, n_row + tmpcoo%ia(nz+i) = i + tmpcoo%ja(nz+i) = i + tmpcoo%val(nz+i) = arwsum(i) + end do + call tmpcoo%set_nzeros(nz+n_row) + call tmpcoo%fix(info) + call tmpcoo%mv_to_fmt(tmpcsr,info) + call tmpa%mv_from(tmpcsr) + call sm%sv%build(tmpa,desc_a,info,amold=amold,vmold=vmold) + end if + end select + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='clip & psb_spcnv csr 4') + goto 9999 + end if + + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='solver build') + 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_jac_smoother_bld diff --git a/mlprec/impl/smoother/mld_d_l1_jac_smoother_clone.f90 b/mlprec/impl/smoother/mld_d_l1_jac_smoother_clone.f90 new file mode 100644 index 00000000..3ecf3ee3 --- /dev/null +++ b/mlprec/impl/smoother/mld_d_l1_jac_smoother_clone.f90 @@ -0,0 +1,88 @@ +! +! +! MLD2P4 version 2.2 +! MultiLevel Domain Decomposition Parallel Preconditioners Package +! based on PSBLAS (Parallel Sparse BLAS version 3.5) +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the MLD2P4 group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine mld_d_l1_jac_smoother_clone(sm,smout,info) + + use psb_base_mod + use mld_d_jac_smoother, mld_protect_name => mld_d_l1_jac_smoother_clone + + Implicit None + + ! Arguments + class(mld_d_l1_jac_smoother_type), intent(inout) :: sm + class(mld_d_base_smoother_type), allocatable, intent(inout) :: smout + integer(psb_ipk_), intent(out) :: info + ! Local variables + integer(psb_ipk_) :: err_act + + + info=psb_success_ + call psb_erractionsave(err_act) + + if (allocated(smout)) then + call smout%free(info) + if (info == psb_success_) deallocate(smout, stat=info) + end if + if (info == psb_success_) & + & allocate(mld_d_l1_jac_smoother_type :: smout, stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + + select type(smo => smout) + type is (mld_d_l1_jac_smoother_type) + smo%nd_nnz_tot = sm%nd_nnz_tot + call sm%nd%clone(smo%nd,info) + if ((info==psb_success_).and.(allocated(sm%sv))) then + allocate(smout%sv,mold=sm%sv,stat=info) + if (info == psb_success_) call sm%sv%clone(smo%sv,info) + end if + + class default + info = psb_err_internal_error_ + end select + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_d_l1_jac_smoother_clone diff --git a/mlprec/impl/smoother/mld_d_l1_jac_smoother_descr.f90 b/mlprec/impl/smoother/mld_d_l1_jac_smoother_descr.f90 new file mode 100644 index 00000000..42b89793 --- /dev/null +++ b/mlprec/impl/smoother/mld_d_l1_jac_smoother_descr.f90 @@ -0,0 +1,103 @@ +! +! +! MLD2P4 version 2.2 +! MultiLevel Domain Decomposition Parallel Preconditioners Package +! based on PSBLAS (Parallel Sparse BLAS version 3.5) +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the MLD2P4 group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine mld_d_l1_jac_smoother_descr(sm,info,iout,coarse) + + use psb_base_mod + use mld_d_diag_solver + use mld_d_jac_smoother, mld_protect_name => mld_d_l1_jac_smoother_descr + use mld_d_diag_solver + use mld_d_gs_solver + + Implicit None + + ! Arguments + class(mld_d_l1_jac_smoother_type), intent(in) :: sm + 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_jac_smoother_descr' + integer(psb_ipk_) :: iout_ + logical :: coarse_ + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(coarse)) then + coarse_ = coarse + else + coarse_ = .false. + end if + if (present(iout)) then + iout_ = iout + else + iout_ = psb_out_unit + endif + + if (.not.coarse_) then + if (allocated(sm%sv)) then + select type(smv=>sm%sv) + class is (mld_d_diag_solver_type) + write(iout_,*) ' Point Jacobi ' + write(iout_,*) ' Local diagonal:' + call smv%descr(info,iout_,coarse=coarse) + class is (mld_d_bwgs_solver_type) + write(iout_,*) ' Hybrid Backward Gauss-Seidel ' + class is (mld_d_gs_solver_type) + write(iout_,*) ' Hybrid Forward Gauss-Seidel ' + class default + write(iout_,*) ' L1-Block Jacobi ' + write(iout_,*) ' Local solver details:' + call smv%descr(info,iout_,coarse=coarse) + end select + + else + write(iout_,*) ' L1-Block Jacobi ' + end if + else + if (allocated(sm%sv)) then + call sm%sv%descr(info,iout_,coarse=coarse) + end if + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine mld_d_l1_jac_smoother_descr diff --git a/mlprec/impl/smoother/mld_s_jac_smoother_bld.f90 b/mlprec/impl/smoother/mld_s_jac_smoother_bld.f90 index c37ca90d..f0e1cad2 100644 --- a/mlprec/impl/smoother/mld_s_jac_smoother_bld.f90 +++ b/mlprec/impl/smoother/mld_s_jac_smoother_bld.f90 @@ -52,8 +52,6 @@ subroutine mld_s_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) class(psb_i_base_vect_type), intent(in), optional :: imold ! Local variables integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nzeros - real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) - type(psb_s_coo_sparse_mat) :: tmpcoo integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level character(len=20) :: name='s_jac_smoother_bld', ch_err diff --git a/mlprec/impl/smoother/mld_s_l1_jac_smoother_bld.f90 b/mlprec/impl/smoother/mld_s_l1_jac_smoother_bld.f90 new file mode 100644 index 00000000..f69bcf32 --- /dev/null +++ b/mlprec/impl/smoother/mld_s_l1_jac_smoother_bld.f90 @@ -0,0 +1,149 @@ +! +! +! MLD2P4 version 2.2 +! MultiLevel Domain Decomposition Parallel Preconditioners Package +! based on PSBLAS (Parallel Sparse BLAS version 3.5) +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the MLD2P4 group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine mld_s_l1_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) + + use psb_base_mod + use mld_s_diag_solver + use mld_s_jac_smoother, mld_protect_name => mld_s_l1_jac_smoother_bld + Implicit None + + ! Arguments + type(psb_sspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(mld_s_l1_jac_smoother_type), intent(inout) :: sm + integer(psb_ipk_), intent(out) :: info + 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, nzeros + real(psb_spk_), allocatable :: arwsum(:) + type(psb_s_coo_sparse_mat) :: tmpcoo + type(psb_s_csr_sparse_mat) :: tmpcsr + type(psb_sspmat_type) :: tmpa + integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level, nz + character(len=20) :: name='s_l1_jac_smoother_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() + n_col = desc_a%get_local_cols() + nrow_a = a%get_nrows() + nztota = a%get_nzeros() + + if( sm%checkres ) sm%pa => a + + select type (smsv => sm%sv) + class is (mld_s_diag_solver_type) + call sm%nd%free() + sm%pa => a + sm%nd_nnz_tot = nztota + + call psb_sum(ictxt,sm%nd_nnz_tot) + call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold) + + class default + if (smsv%is_global()) then + ! Do not put anything into SM%ND since the solver + ! is acting globally. + call sm%nd%free() + sm%nd_nnz_tot = 0 + call psb_sum(ictxt,sm%nd_nnz_tot) + call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold) + else + call a%csclip(sm%nd,info,& + & jmin=nrow_a+1,rscale=.false.,cscale=.false.) + if (info == psb_success_) then + if (present(amold)) then + call sm%nd%cscnv(info,& + & mold=amold,dupl=psb_dupl_add_) + else + call sm%nd%cscnv(info,& + & type='csr',dupl=psb_dupl_add_) + endif + end if + sm%nd_nnz_tot = sm%nd%get_nzeros() + call psb_sum(ictxt,sm%nd_nnz_tot) + arwsum = sm%nd%arwsum(info) + call a%cp_to(tmpcoo) + call tmpcoo%set_dupl(psb_dupl_add_) + nz = tmpcoo%get_nzeros() + call tmpcoo%reallocate(nz+n_row) + do i=1, n_row + tmpcoo%ia(nz+i) = i + tmpcoo%ja(nz+i) = i + tmpcoo%val(nz+i) = arwsum(i) + end do + call tmpcoo%set_nzeros(nz+n_row) + call tmpcoo%fix(info) + call tmpcoo%mv_to_fmt(tmpcsr,info) + call tmpa%mv_from(tmpcsr) + call sm%sv%build(tmpa,desc_a,info,amold=amold,vmold=vmold) + end if + end select + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='clip & psb_spcnv csr 4') + goto 9999 + end if + + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='solver build') + 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_jac_smoother_bld diff --git a/mlprec/impl/smoother/mld_s_l1_jac_smoother_clone.f90 b/mlprec/impl/smoother/mld_s_l1_jac_smoother_clone.f90 new file mode 100644 index 00000000..d15baa85 --- /dev/null +++ b/mlprec/impl/smoother/mld_s_l1_jac_smoother_clone.f90 @@ -0,0 +1,88 @@ +! +! +! MLD2P4 version 2.2 +! MultiLevel Domain Decomposition Parallel Preconditioners Package +! based on PSBLAS (Parallel Sparse BLAS version 3.5) +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the MLD2P4 group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine mld_s_l1_jac_smoother_clone(sm,smout,info) + + use psb_base_mod + use mld_s_jac_smoother, mld_protect_name => mld_s_l1_jac_smoother_clone + + Implicit None + + ! Arguments + class(mld_s_l1_jac_smoother_type), intent(inout) :: sm + class(mld_s_base_smoother_type), allocatable, intent(inout) :: smout + integer(psb_ipk_), intent(out) :: info + ! Local variables + integer(psb_ipk_) :: err_act + + + info=psb_success_ + call psb_erractionsave(err_act) + + if (allocated(smout)) then + call smout%free(info) + if (info == psb_success_) deallocate(smout, stat=info) + end if + if (info == psb_success_) & + & allocate(mld_s_l1_jac_smoother_type :: smout, stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + + select type(smo => smout) + type is (mld_s_l1_jac_smoother_type) + smo%nd_nnz_tot = sm%nd_nnz_tot + call sm%nd%clone(smo%nd,info) + if ((info==psb_success_).and.(allocated(sm%sv))) then + allocate(smout%sv,mold=sm%sv,stat=info) + if (info == psb_success_) call sm%sv%clone(smo%sv,info) + end if + + class default + info = psb_err_internal_error_ + end select + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_s_l1_jac_smoother_clone diff --git a/mlprec/impl/smoother/mld_s_l1_jac_smoother_descr.f90 b/mlprec/impl/smoother/mld_s_l1_jac_smoother_descr.f90 new file mode 100644 index 00000000..4b072054 --- /dev/null +++ b/mlprec/impl/smoother/mld_s_l1_jac_smoother_descr.f90 @@ -0,0 +1,103 @@ +! +! +! MLD2P4 version 2.2 +! MultiLevel Domain Decomposition Parallel Preconditioners Package +! based on PSBLAS (Parallel Sparse BLAS version 3.5) +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the MLD2P4 group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine mld_s_l1_jac_smoother_descr(sm,info,iout,coarse) + + use psb_base_mod + use mld_s_diag_solver + use mld_s_jac_smoother, mld_protect_name => mld_s_l1_jac_smoother_descr + use mld_s_diag_solver + use mld_s_gs_solver + + Implicit None + + ! Arguments + class(mld_s_l1_jac_smoother_type), intent(in) :: sm + 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_jac_smoother_descr' + integer(psb_ipk_) :: iout_ + logical :: coarse_ + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(coarse)) then + coarse_ = coarse + else + coarse_ = .false. + end if + if (present(iout)) then + iout_ = iout + else + iout_ = psb_out_unit + endif + + if (.not.coarse_) then + if (allocated(sm%sv)) then + select type(smv=>sm%sv) + class is (mld_s_diag_solver_type) + write(iout_,*) ' Point Jacobi ' + write(iout_,*) ' Local diagonal:' + call smv%descr(info,iout_,coarse=coarse) + class is (mld_s_bwgs_solver_type) + write(iout_,*) ' Hybrid Backward Gauss-Seidel ' + class is (mld_s_gs_solver_type) + write(iout_,*) ' Hybrid Forward Gauss-Seidel ' + class default + write(iout_,*) ' L1-Block Jacobi ' + write(iout_,*) ' Local solver details:' + call smv%descr(info,iout_,coarse=coarse) + end select + + else + write(iout_,*) ' L1-Block Jacobi ' + end if + else + if (allocated(sm%sv)) then + call sm%sv%descr(info,iout_,coarse=coarse) + end if + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine mld_s_l1_jac_smoother_descr diff --git a/mlprec/impl/smoother/mld_z_jac_smoother_bld.f90 b/mlprec/impl/smoother/mld_z_jac_smoother_bld.f90 index b723201f..b919c5b7 100644 --- a/mlprec/impl/smoother/mld_z_jac_smoother_bld.f90 +++ b/mlprec/impl/smoother/mld_z_jac_smoother_bld.f90 @@ -52,8 +52,6 @@ subroutine mld_z_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) class(psb_i_base_vect_type), intent(in), optional :: imold ! Local variables integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nzeros - complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) - type(psb_z_coo_sparse_mat) :: tmpcoo integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level character(len=20) :: name='z_jac_smoother_bld', ch_err diff --git a/mlprec/impl/smoother/mld_z_l1_jac_smoother_bld.f90 b/mlprec/impl/smoother/mld_z_l1_jac_smoother_bld.f90 new file mode 100644 index 00000000..ff210e23 --- /dev/null +++ b/mlprec/impl/smoother/mld_z_l1_jac_smoother_bld.f90 @@ -0,0 +1,149 @@ +! +! +! MLD2P4 version 2.2 +! MultiLevel Domain Decomposition Parallel Preconditioners Package +! based on PSBLAS (Parallel Sparse BLAS version 3.5) +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the MLD2P4 group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine mld_z_l1_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) + + use psb_base_mod + use mld_z_diag_solver + use mld_z_jac_smoother, mld_protect_name => mld_z_l1_jac_smoother_bld + Implicit None + + ! Arguments + type(psb_zspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(mld_z_l1_jac_smoother_type), intent(inout) :: sm + integer(psb_ipk_), intent(out) :: info + 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, nzeros + real(psb_dpk_), allocatable :: arwsum(:) + type(psb_z_coo_sparse_mat) :: tmpcoo + type(psb_z_csr_sparse_mat) :: tmpcsr + type(psb_zspmat_type) :: tmpa + integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level, nz + character(len=20) :: name='z_l1_jac_smoother_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() + n_col = desc_a%get_local_cols() + nrow_a = a%get_nrows() + nztota = a%get_nzeros() + + if( sm%checkres ) sm%pa => a + + select type (smsv => sm%sv) + class is (mld_z_diag_solver_type) + call sm%nd%free() + sm%pa => a + sm%nd_nnz_tot = nztota + + call psb_sum(ictxt,sm%nd_nnz_tot) + call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold) + + class default + if (smsv%is_global()) then + ! Do not put anything into SM%ND since the solver + ! is acting globally. + call sm%nd%free() + sm%nd_nnz_tot = 0 + call psb_sum(ictxt,sm%nd_nnz_tot) + call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold) + else + call a%csclip(sm%nd,info,& + & jmin=nrow_a+1,rscale=.false.,cscale=.false.) + if (info == psb_success_) then + if (present(amold)) then + call sm%nd%cscnv(info,& + & mold=amold,dupl=psb_dupl_add_) + else + call sm%nd%cscnv(info,& + & type='csr',dupl=psb_dupl_add_) + endif + end if + sm%nd_nnz_tot = sm%nd%get_nzeros() + call psb_sum(ictxt,sm%nd_nnz_tot) + arwsum = sm%nd%arwsum(info) + call a%cp_to(tmpcoo) + call tmpcoo%set_dupl(psb_dupl_add_) + nz = tmpcoo%get_nzeros() + call tmpcoo%reallocate(nz+n_row) + do i=1, n_row + tmpcoo%ia(nz+i) = i + tmpcoo%ja(nz+i) = i + tmpcoo%val(nz+i) = arwsum(i) + end do + call tmpcoo%set_nzeros(nz+n_row) + call tmpcoo%fix(info) + call tmpcoo%mv_to_fmt(tmpcsr,info) + call tmpa%mv_from(tmpcsr) + call sm%sv%build(tmpa,desc_a,info,amold=amold,vmold=vmold) + end if + end select + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='clip & psb_spcnv csr 4') + goto 9999 + end if + + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='solver build') + 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_jac_smoother_bld diff --git a/mlprec/impl/smoother/mld_z_l1_jac_smoother_clone.f90 b/mlprec/impl/smoother/mld_z_l1_jac_smoother_clone.f90 new file mode 100644 index 00000000..02e83d99 --- /dev/null +++ b/mlprec/impl/smoother/mld_z_l1_jac_smoother_clone.f90 @@ -0,0 +1,88 @@ +! +! +! MLD2P4 version 2.2 +! MultiLevel Domain Decomposition Parallel Preconditioners Package +! based on PSBLAS (Parallel Sparse BLAS version 3.5) +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the MLD2P4 group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine mld_z_l1_jac_smoother_clone(sm,smout,info) + + use psb_base_mod + use mld_z_jac_smoother, mld_protect_name => mld_z_l1_jac_smoother_clone + + Implicit None + + ! Arguments + class(mld_z_l1_jac_smoother_type), intent(inout) :: sm + class(mld_z_base_smoother_type), allocatable, intent(inout) :: smout + integer(psb_ipk_), intent(out) :: info + ! Local variables + integer(psb_ipk_) :: err_act + + + info=psb_success_ + call psb_erractionsave(err_act) + + if (allocated(smout)) then + call smout%free(info) + if (info == psb_success_) deallocate(smout, stat=info) + end if + if (info == psb_success_) & + & allocate(mld_z_l1_jac_smoother_type :: smout, stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + + select type(smo => smout) + type is (mld_z_l1_jac_smoother_type) + smo%nd_nnz_tot = sm%nd_nnz_tot + call sm%nd%clone(smo%nd,info) + if ((info==psb_success_).and.(allocated(sm%sv))) then + allocate(smout%sv,mold=sm%sv,stat=info) + if (info == psb_success_) call sm%sv%clone(smo%sv,info) + end if + + class default + info = psb_err_internal_error_ + end select + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_z_l1_jac_smoother_clone diff --git a/mlprec/impl/smoother/mld_z_l1_jac_smoother_descr.f90 b/mlprec/impl/smoother/mld_z_l1_jac_smoother_descr.f90 new file mode 100644 index 00000000..5e4ec17d --- /dev/null +++ b/mlprec/impl/smoother/mld_z_l1_jac_smoother_descr.f90 @@ -0,0 +1,103 @@ +! +! +! MLD2P4 version 2.2 +! MultiLevel Domain Decomposition Parallel Preconditioners Package +! based on PSBLAS (Parallel Sparse BLAS version 3.5) +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the MLD2P4 group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine mld_z_l1_jac_smoother_descr(sm,info,iout,coarse) + + use psb_base_mod + use mld_z_diag_solver + use mld_z_jac_smoother, mld_protect_name => mld_z_l1_jac_smoother_descr + use mld_z_diag_solver + use mld_z_gs_solver + + Implicit None + + ! Arguments + class(mld_z_l1_jac_smoother_type), intent(in) :: sm + 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_jac_smoother_descr' + integer(psb_ipk_) :: iout_ + logical :: coarse_ + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(coarse)) then + coarse_ = coarse + else + coarse_ = .false. + end if + if (present(iout)) then + iout_ = iout + else + iout_ = psb_out_unit + endif + + if (.not.coarse_) then + if (allocated(sm%sv)) then + select type(smv=>sm%sv) + class is (mld_z_diag_solver_type) + write(iout_,*) ' Point Jacobi ' + write(iout_,*) ' Local diagonal:' + call smv%descr(info,iout_,coarse=coarse) + class is (mld_z_bwgs_solver_type) + write(iout_,*) ' Hybrid Backward Gauss-Seidel ' + class is (mld_z_gs_solver_type) + write(iout_,*) ' Hybrid Forward Gauss-Seidel ' + class default + write(iout_,*) ' L1-Block Jacobi ' + write(iout_,*) ' Local solver details:' + call smv%descr(info,iout_,coarse=coarse) + end select + + else + write(iout_,*) ' L1-Block Jacobi ' + end if + else + if (allocated(sm%sv)) then + call sm%sv%descr(info,iout_,coarse=coarse) + end if + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine mld_z_l1_jac_smoother_descr diff --git a/mlprec/mld_base_prec_type.F90 b/mlprec/mld_base_prec_type.F90 index a371390b..f7f4707f 100644 --- a/mlprec/mld_base_prec_type.F90 +++ b/mlprec/mld_base_prec_type.F90 @@ -208,8 +208,9 @@ module mld_base_prec_type integer(psb_ipk_), parameter :: mld_jac_ = 1 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_l1_bjac_ = 4 + integer(psb_ipk_), parameter :: mld_as_ = 5 + integer(psb_ipk_), parameter :: mld_max_prec_ = 5 integer(psb_ipk_), parameter :: mld_fbgs_ = mld_max_prec_+1 ! ! Constants for pre/post signaling. Now only used internally @@ -386,7 +387,7 @@ module mld_base_prec_type & mld_fact_names(0:mld_max_sub_solve_)=(/& & 'none ','Jacobi ',& & 'L1-Jacobi ','none ','none ',& - & 'none ','Point Jacobi ',& + & 'none ','none ','Point Jacobi ',& & 'L1-Jacobi ','Gauss-Seidel ','ILU(n) ',& & 'MILU(n) ','ILU(t,n) ',& & 'SuperLU ','UMFPACK LU ',& @@ -509,6 +510,8 @@ contains val = mld_noprec_ case('BJAC') val = mld_bjac_ + case('L1-BJAC') + val = mld_l1_bjac_ case('JAC','JACOBI') val = mld_jac_ case('L1-JACOBI') @@ -698,6 +701,11 @@ contains & pm%sweeps_pre write(iout,*) ' Coarse solver: ',& & 'Block Jacobi' + case (mld_l1_bjac_) + write(iout,*) ' Number of sweeps : ',& + & pm%sweeps_pre + write(iout,*) ' Coarse solver: ',& + & 'L1-Block Jacobi' case (mld_jac_) write(iout,*) ' Number of sweeps : ',& & pm%sweeps_pre diff --git a/mlprec/mld_d_jac_smoother.f90 b/mlprec/mld_d_jac_smoother.f90 index cf7f9821..4149f341 100644 --- a/mlprec/mld_d_jac_smoother.f90 +++ b/mlprec/mld_d_jac_smoother.f90 @@ -86,11 +86,21 @@ module mld_d_jac_smoother procedure, nopass :: get_id => d_jac_smoother_get_id end type mld_d_jac_smoother_type + type, extends(mld_d_jac_smoother_type) :: mld_d_l1_jac_smoother_type + contains + procedure, pass(sm) :: build => mld_d_l1_jac_smoother_bld + procedure, pass(sm) :: clone => mld_d_l1_jac_smoother_clone + procedure, pass(sm) :: descr => mld_d_l1_jac_smoother_descr + procedure, nopass :: get_fmt => d_l1_jac_smoother_get_fmt + procedure, nopass :: get_id => d_l1_jac_smoother_get_id + end type mld_d_l1_jac_smoother_type + private :: d_jac_smoother_free, & & d_jac_smoother_sizeof, d_jac_smoother_get_nzeros, & & d_jac_smoother_get_fmt, d_jac_smoother_get_id, & & d_jac_smoother_get_wrksize + private :: d_l1_jac_smoother_get_fmt, d_l1_jac_smoother_get_id interface @@ -237,6 +247,42 @@ module mld_d_jac_smoother end subroutine mld_d_jac_smoother_csetr end interface + interface + subroutine mld_d_l1_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) + import :: psb_desc_type, mld_d_l1_jac_smoother_type, psb_d_vect_type, psb_dpk_, & + & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_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_jac_smoother_type), intent(inout) :: sm + integer(psb_ipk_), intent(out) :: info + 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_jac_smoother_bld + end interface + + interface + subroutine mld_d_l1_jac_smoother_clone(sm,smout,info) + import :: mld_d_l1_jac_smoother_type, psb_dpk_, & + & mld_d_base_smoother_type, psb_ipk_ + class(mld_d_l1_jac_smoother_type), intent(inout) :: sm + class(mld_d_base_smoother_type), allocatable, intent(inout) :: smout + integer(psb_ipk_), intent(out) :: info + end subroutine mld_d_l1_jac_smoother_clone + end interface + + interface + subroutine mld_d_l1_jac_smoother_descr(sm,info,iout,coarse) + import :: mld_d_l1_jac_smoother_type, psb_ipk_ + class(mld_d_l1_jac_smoother_type), intent(in) :: sm + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + logical, intent(in), optional :: coarse + end subroutine mld_d_l1_jac_smoother_descr + end interface + + contains @@ -352,4 +398,18 @@ contains val = mld_jac_ end function d_jac_smoother_get_id + function d_l1_jac_smoother_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "L1-Jacobi smoother" + end function d_l1_jac_smoother_get_fmt + + function d_l1_jac_smoother_get_id() result(val) + implicit none + integer(psb_ipk_) :: val + + val = mld_l1_jac_ + end function d_l1_jac_smoother_get_id + end module mld_d_jac_smoother