From 34926cdb94038229f43ac1442d725ca9890b9eb1 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 26 Feb 2016 12:35:24 +0000 Subject: [PATCH] mld2p4-2: mlprec/impl/mld_dcprecset.F90 mlprec/impl/mld_dprecset.F90 mlprec/impl/solver/Makefile mlprec/impl/solver/mld_d_gs_solver_bld.f90 mlprec/mld_base_prec_type.F90 mlprec/mld_d_gs_solver.f90 GS set & bld. --- mlprec/impl/mld_dcprecset.F90 | 242 +++++++++++++-------- mlprec/impl/mld_dprecset.F90 | 241 ++++++++++++-------- mlprec/impl/solver/Makefile | 1 + mlprec/impl/solver/mld_d_gs_solver_bld.f90 | 118 ++++++++++ mlprec/mld_base_prec_type.F90 | 17 +- mlprec/mld_d_gs_solver.f90 | 164 +++++++------- 6 files changed, 508 insertions(+), 275 deletions(-) create mode 100644 mlprec/impl/solver/mld_d_gs_solver_bld.f90 diff --git a/mlprec/impl/mld_dcprecset.F90 b/mlprec/impl/mld_dcprecset.F90 index 4dfd7d63..648a7a6f 100644 --- a/mlprec/impl/mld_dcprecset.F90 +++ b/mlprec/impl/mld_dcprecset.F90 @@ -85,6 +85,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev) use mld_d_diag_solver use mld_d_ilu_solver use mld_d_id_solver + use mld_d_gs_solver #if defined(HAVE_UMF_) use mld_d_umf_solver #endif @@ -455,123 +456,178 @@ contains ! select case (val) case (mld_f_none_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_d_id_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_d_id_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_d_id_solver_type :: level%sm%sv, stat=info) - endif if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_d_id_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_d_id_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_d_id_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) & + & call level%sm%sv%default() + end if + else + write(0,*) 'Calling set_solver without a smoother?' + info = -5 end if - case (mld_diag_scale_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_d_diag_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_d_diag_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_d_diag_solver_type :: level%sm%sv, stat=info) - endif if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_d_diag_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_d_diag_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_d_diag_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) & + & call level%sm%sv%default() + end if + else + write(0,*) 'Calling set_solver without a smoother?' + info = -5 end if - + + case (mld_gs_) + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_d_gs_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_d_gs_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_d_gs_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm%sv)) then + call level%sm%sv%default() + else + endif + + else + write(0,*) 'Calling set_solver without a smoother?' + info = -5 + end if + + case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_d_ilu_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_d_ilu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_d_ilu_solver_type :: level%sm%sv, stat=info) - endif if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_d_ilu_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_d_ilu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_d_ilu_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) & + & call level%sm%sv%default() + end if + call level%sm%sv%set('SUB_SOLVE',val,info) + else + write(0,*) 'Calling set_solver without a smoother?' + info = -5 end if - call level%sm%sv%set('SUB_SOLVE',val,info) #ifdef HAVE_SLU_ case (mld_slu_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_d_slu_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_d_slu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_d_slu_solver_type :: level%sm%sv, stat=info) - endif if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_d_slu_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_d_slu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_d_slu_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) & + & call level%sm%sv%default() + end if + else + write(0,*) 'Calling set_solver without a smoother?' + info = -5 end if #endif #ifdef HAVE_UMF_ case (mld_umf_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_d_umf_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_d_umf_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_d_umf_solver_type :: level%sm%sv, stat=info) - endif if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_d_umf_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_d_umf_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_d_umf_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) & + & call level%sm%sv%default() + end if + else + write(0,*) 'Calling set_solver without a smoother?' + info = -5 end if #endif #ifdef HAVE_SLUDIST_ case (mld_sludist_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_d_sludist_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_d_sludist_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_d_sludist_solver_type :: level%sm%sv, stat=info) - endif if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_d_sludist_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_d_sludist_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_d_sludist_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) & + & call level%sm%sv%default() + end if + else + write(0,*) 'Calling set_solver without a smoother?' + info = -5 end if #endif case default diff --git a/mlprec/impl/mld_dprecset.F90 b/mlprec/impl/mld_dprecset.F90 index 2e7cc705..41cc1700 100644 --- a/mlprec/impl/mld_dprecset.F90 +++ b/mlprec/impl/mld_dprecset.F90 @@ -85,6 +85,7 @@ subroutine mld_dprecseti(p,what,val,info,ilev) use mld_d_diag_solver use mld_d_ilu_solver use mld_d_id_solver + use mld_d_gs_solver #if defined(HAVE_UMF_) use mld_d_umf_solver #endif @@ -456,123 +457,176 @@ contains ! select case (val) case (mld_f_none_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_d_id_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_d_id_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_d_id_solver_type :: level%sm%sv, stat=info) - endif if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_d_id_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_d_id_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_d_id_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) & + & call level%sm%sv%default() + end if + else + write(0,*) 'Calling set_solver without a smoother?' + info = -5 end if - + case (mld_diag_scale_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_d_diag_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_d_diag_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_d_diag_solver_type :: level%sm%sv, stat=info) - endif if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_d_diag_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_d_diag_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_d_diag_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) & + & call level%sm%sv%default() + end if + else + write(0,*) 'Calling set_solver without a smoother?' + info = -5 + end if + + case (mld_gs_) + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_d_gs_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_d_gs_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_d_gs_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm%sv)) then + call level%sm%sv%default() + end if + + else + write(0,*) 'Calling set_solver without a smoother?' + info = -5 end if - + case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_d_ilu_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_d_ilu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_d_ilu_solver_type :: level%sm%sv, stat=info) - endif if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_d_ilu_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_d_ilu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_d_ilu_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) & + & call level%sm%sv%default() + end if + call level%sm%sv%set(mld_sub_solve_,val,info) + else + write(0,*) 'Calling set_solver without a smoother?' + info = -5 end if - call level%sm%sv%set(mld_sub_solve_,val,info) #ifdef HAVE_UMF_ case (mld_umf_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_d_umf_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_d_umf_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_d_umf_solver_type :: level%sm%sv, stat=info) - endif if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_d_umf_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_d_umf_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_d_umf_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) & + & call level%sm%sv%default() + end if + else + write(0,*) 'Calling set_solver without a smoother?' + info = -5 end if #endif #ifdef HAVE_SLUDIST_ case (mld_sludist_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_d_sludist_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_d_sludist_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_d_sludist_solver_type :: level%sm%sv, stat=info) - endif if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_d_sludist_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_d_sludist_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_d_sludist_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) & + & call level%sm%sv%default() + end if + else + write(0,*) 'Calling set_solver without a smoother?' + info = -5 end if #endif #ifdef HAVE_SLU_ case (mld_slu_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_d_slu_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_d_slu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_d_slu_solver_type :: level%sm%sv, stat=info) - endif + if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_d_slu_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_d_slu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_d_slu_solver_type :: level%sm%sv, stat=info) + endif + else + write(0,*) 'Calling set_solver without a smoother?' + info = -5 end if + + #endif case default ! @@ -580,6 +634,7 @@ contains ! end select + end subroutine onelev_set_solver diff --git a/mlprec/impl/solver/Makefile b/mlprec/impl/solver/Makefile index db7ddb78..0fee27e9 100644 --- a/mlprec/impl/solver/Makefile +++ b/mlprec/impl/solver/Makefile @@ -57,6 +57,7 @@ mld_d_diag_solver_apply_vect.o \ mld_d_diag_solver_bld.o \ mld_d_diag_solver_clone.o \ mld_d_diag_solver_cnv.o \ +mld_d_gs_solver_bld.o \ mld_d_id_solver_apply.o \ mld_d_id_solver_apply_vect.o \ mld_d_id_solver_clone.o \ diff --git a/mlprec/impl/solver/mld_d_gs_solver_bld.f90 b/mlprec/impl/solver/mld_d_gs_solver_bld.f90 new file mode 100644 index 00000000..0b79b5df --- /dev/null +++ b/mlprec/impl/solver/mld_d_gs_solver_bld.f90 @@ -0,0 +1,118 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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_gs_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) + + use psb_base_mod + use mld_d_gs_solver, mld_protect_name => mld_d_gs_solver_bld + + Implicit None + + ! Arguments + type(psb_dspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_d_gs_solver_type), intent(inout) :: sv + character, intent(in) :: upd + 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(:) + integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level + character(len=20) :: name='d_gs_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() + + if (psb_toupper(upd) == 'F') then + nrow_a = a%get_nrows() + nztota = a%get_nzeros() +!!$ if (present(b)) then +!!$ nztota = nztota + b%get_nzeros() +!!$ end if + if (sv%eps <= dzero) then + ! + ! This cuts out the off-diagonal part, because it's supposed to + ! be handled by the outer Jacobi smoother. + ! + call a%tril(sv%l,info) + call a%triu(sv%u,info,diag=1,jmax=nrow_a) + + else + + info = psb_err_missing_override_method_ + call psb_errpush(info,name) + goto 9999 + end if + + + + call sv%l%set_asb() + call sv%l%trim() + call sv%u%set_asb() + call sv%u%trim() + + if (present(amold)) then + call sv%l%cscnv(info,mold=amold) + call sv%u%cscnv(info,mold=amold) + end if + + 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_gs_solver_bld diff --git a/mlprec/mld_base_prec_type.F90 b/mlprec/mld_base_prec_type.F90 index 00253aa0..635be97e 100644 --- a/mlprec/mld_base_prec_type.F90 +++ b/mlprec/mld_base_prec_type.F90 @@ -181,13 +181,14 @@ 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_ilu_n_ = mld_slv_delta_+2 - integer(psb_ipk_), parameter :: mld_milu_n_ = mld_slv_delta_+3 - integer(psb_ipk_), parameter :: mld_ilu_t_ = mld_slv_delta_+4 - integer(psb_ipk_), parameter :: mld_slu_ = mld_slv_delta_+5 - integer(psb_ipk_), parameter :: mld_umf_ = mld_slv_delta_+6 - integer(psb_ipk_), parameter :: mld_sludist_ = mld_slv_delta_+7 - integer(psb_ipk_), parameter :: mld_max_sub_solve_= mld_slv_delta_+7 + 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_max_sub_solve_= mld_slv_delta_+8 integer(psb_ipk_), parameter :: mld_min_sub_solve_= mld_diag_scale_ ! ! Legal values for entry: mld_sub_ren_ @@ -364,6 +365,8 @@ contains val = psb_avg_ case('FACT_NONE') val = mld_f_none_ + case('GS') + val = mld_gs_ case('ILU') val = mld_ilu_n_ case('MILU') diff --git a/mlprec/mld_d_gs_solver.f90 b/mlprec/mld_d_gs_solver.f90 index 0d91ecc6..8b803240 100644 --- a/mlprec/mld_d_gs_solver.f90 +++ b/mlprec/mld_d_gs_solver.f90 @@ -52,13 +52,13 @@ module mld_d_gs_solver integer(psb_ipk_) :: sweeps real(psb_dpk_) :: eps contains - procedure, pass(sv) :: dump => mld_d_gs_solver_dmp +!!$ procedure, pass(sv) :: dump => mld_d_gs_solver_dmp procedure, pass(sv) :: ccheck => d_gs_solver_check - procedure, pass(sv) :: clone => mld_d_gs_solver_clone +!!$ procedure, pass(sv) :: clone => mld_d_gs_solver_clone procedure, pass(sv) :: build => mld_d_gs_solver_bld - procedure, pass(sv) :: cnv => mld_d_gs_solver_cnv - procedure, pass(sv) :: apply_v => mld_d_gs_solver_apply_vect - procedure, pass(sv) :: apply_a => mld_d_gs_solver_apply +!!$ procedure, pass(sv) :: cnv => mld_d_gs_solver_cnv +!!$ procedure, pass(sv) :: apply_v => mld_d_gs_solver_apply_vect +!!$ procedure, pass(sv) :: apply_a => mld_d_gs_solver_apply procedure, pass(sv) :: free => d_gs_solver_free procedure, pass(sv) :: seti => d_gs_solver_seti procedure, pass(sv) :: setc => d_gs_solver_setc @@ -83,38 +83,38 @@ module mld_d_gs_solver & d_gs_solver_get_fmt, d_gs_solver_check - interface - subroutine mld_d_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) - import :: psb_desc_type, mld_d_gs_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 - type(psb_desc_type), intent(in) :: desc_data - class(mld_d_gs_solver_type), intent(inout) :: sv - type(psb_d_vect_type),intent(inout) :: x - type(psb_d_vect_type),intent(inout) :: y - real(psb_dpk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans - real(psb_dpk_),target, intent(inout) :: work(:) - integer(psb_ipk_), intent(out) :: info - end subroutine mld_d_gs_solver_apply_vect - end interface - - interface - subroutine mld_d_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) - import :: psb_desc_type, mld_d_gs_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 - type(psb_desc_type), intent(in) :: desc_data - class(mld_d_gs_solver_type), intent(inout) :: sv - real(psb_dpk_),intent(inout) :: x(:) - real(psb_dpk_),intent(inout) :: y(:) - real(psb_dpk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans - real(psb_dpk_),target, intent(inout) :: work(:) - integer(psb_ipk_), intent(out) :: info - end subroutine mld_d_gs_solver_apply - end interface - +!!$ interface +!!$ subroutine mld_d_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) +!!$ import :: psb_desc_type, mld_d_gs_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 +!!$ type(psb_desc_type), intent(in) :: desc_data +!!$ class(mld_d_gs_solver_type), intent(inout) :: sv +!!$ type(psb_d_vect_type),intent(inout) :: x +!!$ type(psb_d_vect_type),intent(inout) :: y +!!$ real(psb_dpk_),intent(in) :: alpha,beta +!!$ character(len=1),intent(in) :: trans +!!$ real(psb_dpk_),target, intent(inout) :: work(:) +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine mld_d_gs_solver_apply_vect +!!$ end interface +!!$ +!!$ interface +!!$ subroutine mld_d_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) +!!$ import :: psb_desc_type, mld_d_gs_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 +!!$ type(psb_desc_type), intent(in) :: desc_data +!!$ class(mld_d_gs_solver_type), intent(inout) :: sv +!!$ real(psb_dpk_),intent(inout) :: x(:) +!!$ real(psb_dpk_),intent(inout) :: y(:) +!!$ real(psb_dpk_),intent(in) :: alpha,beta +!!$ character(len=1),intent(in) :: trans +!!$ real(psb_dpk_),target, intent(inout) :: work(:) +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine mld_d_gs_solver_apply +!!$ end interface +!!$ interface subroutine mld_d_gs_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) import :: psb_desc_type, mld_d_gs_solver_type, psb_d_vect_type, psb_dpk_, & @@ -132,49 +132,49 @@ module mld_d_gs_solver class(psb_i_base_vect_type), intent(in), optional :: imold end subroutine mld_d_gs_solver_bld end interface - - interface - subroutine mld_d_gs_solver_cnv(sv,info,amold,vmold,imold) - import :: mld_d_gs_solver_type, psb_dpk_, & - & psb_d_base_sparse_mat, psb_d_base_vect_type,& - & psb_ipk_, psb_i_base_vect_type - implicit none - class(mld_d_gs_solver_type), intent(inout) :: sv - 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_gs_solver_cnv - end interface - - interface - subroutine mld_d_gs_solver_dmp(sv,ictxt,level,info,prefix,head,solver) - import :: psb_desc_type, mld_d_gs_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_gs_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_gs_solver_dmp - end interface - - interface - subroutine mld_d_gs_solver_clone(sv,svout,info) - 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_base_solver_type, mld_d_gs_solver_type, psb_ipk_ - Implicit None - - ! Arguments - class(mld_d_gs_solver_type), intent(inout) :: sv - class(mld_d_base_solver_type), allocatable, intent(inout) :: svout - integer(psb_ipk_), intent(out) :: info - end subroutine mld_d_gs_solver_clone - end interface +!!$ +!!$ interface +!!$ subroutine mld_d_gs_solver_cnv(sv,info,amold,vmold,imold) +!!$ import :: mld_d_gs_solver_type, psb_dpk_, & +!!$ & psb_d_base_sparse_mat, psb_d_base_vect_type,& +!!$ & psb_ipk_, psb_i_base_vect_type +!!$ implicit none +!!$ class(mld_d_gs_solver_type), intent(inout) :: sv +!!$ 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_gs_solver_cnv +!!$ end interface +!!$ +!!$ interface +!!$ subroutine mld_d_gs_solver_dmp(sv,ictxt,level,info,prefix,head,solver) +!!$ import :: psb_desc_type, mld_d_gs_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_gs_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_gs_solver_dmp +!!$ end interface +!!$ +!!$ interface +!!$ subroutine mld_d_gs_solver_clone(sv,svout,info) +!!$ 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_base_solver_type, mld_d_gs_solver_type, psb_ipk_ +!!$ Implicit None +!!$ +!!$ ! Arguments +!!$ class(mld_d_gs_solver_type), intent(inout) :: sv +!!$ class(mld_d_base_solver_type), allocatable, intent(inout) :: svout +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine mld_d_gs_solver_clone +!!$ end interface contains @@ -326,8 +326,8 @@ contains call psb_erractionsave(err_act) select case(psb_toupper(what)) - case('SOLVER_SWEEPS') - sv%sweeps = val + case('SOLVER_SWEEPS') + sv%sweeps = val case default call sv%mld_d_base_solver_type%set(what,val,info) end select