From 6ac3e6c146f6a29b4d3ba14e0400a7c9a2f7383d Mon Sep 17 00:00:00 2001 From: Cirdans-Home Date: Tue, 28 Apr 2020 19:15:09 +0200 Subject: [PATCH 1/4] Added stop criterion on residual for BJAC as coarse solver --- mlprec/impl/smoother/Makefile | 21 ++- .../mld_c_jac_smoother_apply_vect.f90 | 140 ++++++++++------- .../impl/smoother/mld_c_jac_smoother_bld.f90 | 33 ++-- .../smoother/mld_c_jac_smoother_csetc.f90 | 85 +++++++++++ .../smoother/mld_c_jac_smoother_cseti.f90 | 71 +++++++++ .../smoother/mld_c_jac_smoother_csetr.f90 | 69 +++++++++ .../mld_d_jac_smoother_apply_vect.f90 | 140 ++++++++++------- .../impl/smoother/mld_d_jac_smoother_bld.f90 | 33 ++-- .../smoother/mld_d_jac_smoother_csetc.f90 | 85 +++++++++++ .../smoother/mld_d_jac_smoother_cseti.f90 | 71 +++++++++ .../smoother/mld_d_jac_smoother_csetr.f90 | 69 +++++++++ .../mld_s_jac_smoother_apply_vect.f90 | 140 ++++++++++------- .../impl/smoother/mld_s_jac_smoother_bld.f90 | 33 ++-- .../smoother/mld_s_jac_smoother_csetc.f90 | 85 +++++++++++ .../smoother/mld_s_jac_smoother_cseti.f90 | 71 +++++++++ .../smoother/mld_s_jac_smoother_csetr.f90 | 69 +++++++++ .../mld_z_jac_smoother_apply_vect.f90 | 140 ++++++++++------- .../impl/smoother/mld_z_jac_smoother_bld.f90 | 33 ++-- .../smoother/mld_z_jac_smoother_csetc.f90 | 85 +++++++++++ .../smoother/mld_z_jac_smoother_cseti.f90 | 71 +++++++++ .../smoother/mld_z_jac_smoother_csetr.f90 | 69 +++++++++ mlprec/mld_c_jac_smoother.f90 | 141 ++++++++++++------ mlprec/mld_d_jac_smoother.f90 | 141 ++++++++++++------ mlprec/mld_s_jac_smoother.f90 | 141 ++++++++++++------ mlprec/mld_z_jac_smoother.f90 | 141 ++++++++++++------ 25 files changed, 1724 insertions(+), 453 deletions(-) create mode 100644 mlprec/impl/smoother/mld_c_jac_smoother_csetc.f90 create mode 100644 mlprec/impl/smoother/mld_c_jac_smoother_cseti.f90 create mode 100644 mlprec/impl/smoother/mld_c_jac_smoother_csetr.f90 create mode 100644 mlprec/impl/smoother/mld_d_jac_smoother_csetc.f90 create mode 100644 mlprec/impl/smoother/mld_d_jac_smoother_cseti.f90 create mode 100644 mlprec/impl/smoother/mld_d_jac_smoother_csetr.f90 create mode 100644 mlprec/impl/smoother/mld_s_jac_smoother_csetc.f90 create mode 100644 mlprec/impl/smoother/mld_s_jac_smoother_cseti.f90 create mode 100644 mlprec/impl/smoother/mld_s_jac_smoother_csetr.f90 create mode 100644 mlprec/impl/smoother/mld_z_jac_smoother_csetc.f90 create mode 100644 mlprec/impl/smoother/mld_z_jac_smoother_cseti.f90 create mode 100644 mlprec/impl/smoother/mld_z_jac_smoother_csetr.f90 diff --git a/mlprec/impl/smoother/Makefile b/mlprec/impl/smoother/Makefile index 75fad885..f929a99f 100644 --- a/mlprec/impl/smoother/Makefile +++ b/mlprec/impl/smoother/Makefile @@ -1,7 +1,7 @@ include ../../../Make.inc LIBDIR=../../../lib INCDIR=../../../include -MODDIR=../../../modules +MODDIR=../../../modules HERE=../.. FINCLUDES=$(FMFLAG)$(HERE) $(FMFLAG)$(MODDIR) $(FMFLAG)$(INCDIR) $(PSBLAS_INCLUDES) @@ -40,6 +40,9 @@ mld_c_jac_smoother_descr.o \ mld_c_jac_smoother_dmp.o \ mld_c_jac_smoother_clone.o \ 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_d_as_smoother_apply.o \ mld_d_as_smoother_apply_vect.o \ mld_d_as_smoother_bld.o \ @@ -73,6 +76,9 @@ mld_d_jac_smoother_descr.o \ mld_d_jac_smoother_dmp.o \ mld_d_jac_smoother_clone.o \ 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_s_as_smoother_apply.o \ mld_s_as_smoother_apply_vect.o \ mld_s_as_smoother_bld.o \ @@ -106,6 +112,9 @@ mld_s_jac_smoother_descr.o \ mld_s_jac_smoother_dmp.o \ mld_s_jac_smoother_clone.o \ 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_z_as_smoother_apply.o \ mld_z_as_smoother_apply_vect.o \ mld_z_as_smoother_bld.o \ @@ -138,15 +147,18 @@ mld_z_jac_smoother_bld.o \ mld_z_jac_smoother_descr.o \ mld_z_jac_smoother_dmp.o \ mld_z_jac_smoother_clone.o \ -mld_z_jac_smoother_cnv.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 LIBNAME=libmld_prec.a -lib: $(OBJS) +lib: $(OBJS) $(AR) $(HERE)/$(LIBNAME) $(OBJS) $(RANLIB) $(HERE)/$(LIBNAME) -mpobjs: +mpobjs: (make $(MPFOBJS) FC="$(MPFC)" FCOPT="$(FCOPT)") (make $(MPCOBJS) CC="$(MPCC)" CCOPT="$(CCOPT)") @@ -155,4 +167,3 @@ veryclean: clean clean: /bin/rm -f $(OBJS) $(LOCAL_MODS) - diff --git a/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 index dadf92c8..94bc1bdc 100644 --- a/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 @@ -1,15 +1,15 @@ -! -! +! +! ! 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 -! +! +! (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: @@ -21,7 +21,7 @@ ! 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 @@ -33,14 +33,15 @@ ! 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_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& +! +! +subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& & sweeps,work,wv,info,init,initu) - + use psb_base_mod + use psb_base_krylov_conv_mod use mld_c_jac_smoother, mld_protect_name => mld_c_jac_smoother_apply_vect - implicit none + implicit none type(psb_desc_type), intent(in) :: desc_data class(mld_c_jac_smoother_type), intent(inout) :: sm type(psb_c_vect_type),intent(inout) :: x @@ -55,10 +56,11 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& type(psb_c_vect_type),intent(inout), optional :: initu ! integer(psb_ipk_) :: n_row,n_col - type(psb_c_vect_type) :: tx, ty + type(psb_c_vect_type) :: tx, ty, r complex(psb_spk_), pointer :: aux(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act character :: trans_, init_ + real(psb_dpk_) :: res, resdenum character(len=20) :: name='c_jac_smoother_apply_v' call psb_erractionsave(err_act) @@ -67,7 +69,7 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ictxt = desc_data%get_context() call psb_info(ictxt,me,np) - + if (present(init)) then init_ = psb_toupper(init) else @@ -83,7 +85,7 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& goto 9999 end select - if (.not.allocated(sm%sv)) then + if (.not.allocated(sm%sv)) then info = 1121 call psb_errpush(info,name) goto 9999 @@ -92,45 +94,51 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() - if (4*n_col <= size(work)) then + if (4*n_col <= size(work)) then aux => work(:) else allocate(aux(4*n_col),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_alloc_request_ - call psb_errpush(info,name,& + call psb_errpush(info,name,& & i_err=(/4*n_col,izero,izero,izero,izero/),& & a_err='complex(psb_spk_)') - goto 9999 + goto 9999 end if endif - - if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nd_nnz_tot==0))) then + + if(sm%checkres) then + call psb_geall(r,desc_data,info) + call psb_geasb(r,desc_data,info) + resdenum = psb_genrm2(x,desc_data,info) + end if + + if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nd_nnz_tot==0))) then ! if .not.sv%is_iterative, there's no need to pass init - call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info) - + call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,& & name,a_err='Error in sub_aply Jacobi Sweeps = 1') goto 9999 endif - + else if (sweeps >= 0) then if (associated(sm%pa)) then ! - ! This means we are dealing with a pure Jacobi smoother/solver. + ! This means we are dealing with a pure Jacobi smoother/solver. ! associate(tx => wv(1), ty => wv(2)) select case (init_) - case('Z') + case('Z') - call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') + call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') case('Y') call psb_geaxpby(cone,x,czero,tx,desc_data,info) call psb_geaxpby(cone,y,czero,ty,desc_data,info) call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') + call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case('U') if (.not.present(initu)) then @@ -141,14 +149,14 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call psb_geaxpby(cone,x,czero,tx,desc_data,info) call psb_geaxpby(cone,initu,czero,ty,desc_data,info) call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') + call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case default call psb_errpush(psb_err_internal_error_,name,& & a_err='wrong init to smoother_apply') goto 9999 end select - + do i=1, sweeps-1 ! ! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)), @@ -159,24 +167,38 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info /= psb_success_) exit - call sm%sv%apply(cone,tx,cone,ty,desc_data,trans_,aux,wv(3:),info,init='Y') + call sm%sv%apply(cone,tx,cone,ty,desc_data,trans_,aux,wv(3:),info,init='Y') if (info /= psb_success_) exit + + if ( sm%checkres.and.(mod(i,sm%checkiter) == 0) ) then + call psb_geaxpby(cone,x,czero,r,r,desc_data,info) + call psb_spmm(-cone,sm%pa,ty,cone,r,desc_data,info) + res = psb_genrm2(r,desc_data,info) + if( sm%printres ) then + call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) + end if + if (res/resdenum < sm%tol) then + if( sm%printres ) call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) + exit + end if + end if + end do - + if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_internal_error_ - call psb_errpush(info,name,& + call psb_errpush(info,name,& & a_err='subsolve with Jacobi sweeps > 1') - goto 9999 + goto 9999 end if - + end associate - + else ! ! @@ -198,15 +220,15 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! significant when sweeps=1 (a common case) ! select case (init_) - case('Z') + case('Z') - call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') + call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') case('Y') call psb_geaxpby(cone,x,czero,tx,desc_data,info) call psb_geaxpby(cone,y,czero,ty,desc_data,info) call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') + call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case('U') if (.not.present(initu)) then @@ -217,7 +239,7 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call psb_geaxpby(cone,x,czero,tx,desc_data,info) call psb_geaxpby(cone,initu,czero,ty,desc_data,info) call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') + call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case default call psb_errpush(psb_err_internal_error_,name,& @@ -236,23 +258,37 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info /= psb_success_) exit - call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') + call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') if (info /= psb_success_) exit + + if ( sm%checkres.and.(mod(i,sm%checkiter) == 0) ) then + call psb_geaxpby(cone,x,czero,r,r,desc_data,info) + call psb_spmm(-cone,sm%pa,ty,cone,r,desc_data,info) + res = psb_genrm2(r,desc_data,info) + if( sm%printres ) then + call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) + end if + if (res/resdenum < sm%tol) then + if( sm%printres ) call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) + exit + end if + end if + end do if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_internal_error_ - call psb_errpush(info,name,& + call psb_errpush(info,name,& & a_err='subsolve with Jacobi sweeps > 1') - goto 9999 + goto 9999 end if end associate end if - + else info = psb_err_iarg_neg_ @@ -262,10 +298,14 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& endif - if (.not.(4*n_col <= size(work))) then + if (.not.(4*n_col <= size(work))) then deallocate(aux) endif + if(sm%checkres) then + call psb_gefree(r,desc_data,info) + end if + call psb_erractionrestore(err_act) return diff --git a/mlprec/impl/smoother/mld_c_jac_smoother_bld.f90 b/mlprec/impl/smoother/mld_c_jac_smoother_bld.f90 index 4d32230d..f9615361 100644 --- a/mlprec/impl/smoother/mld_c_jac_smoother_bld.f90 +++ b/mlprec/impl/smoother/mld_c_jac_smoother_bld.f90 @@ -1,15 +1,15 @@ -! -! +! +! ! 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 -! +! +! (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: @@ -21,7 +21,7 @@ ! 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 @@ -33,8 +33,8 @@ ! 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_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) use psb_base_mod @@ -44,7 +44,7 @@ subroutine mld_c_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) ! Arguments type(psb_cspmat_type), intent(in), target :: a - Type(psb_desc_type), Intent(inout) :: desc_a + Type(psb_desc_type), Intent(inout) :: desc_a class(mld_c_jac_smoother_type), intent(inout) :: sm integer(psb_ipk_), intent(out) :: info class(psb_c_base_sparse_mat), intent(in), optional :: amold @@ -71,6 +71,9 @@ subroutine mld_c_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) 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() @@ -85,8 +88,8 @@ subroutine mld_c_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) else call a%csclip(sm%nd,info,& & jmin=nrow_a+1,rscale=.false.,cscale=.false.) - if (info == psb_success_) then - if (present(amold)) then + if (info == psb_success_) then + if (present(amold)) then call sm%nd%cscnv(info,& & mold=amold,dupl=psb_dupl_add_) else diff --git a/mlprec/impl/smoother/mld_c_jac_smoother_csetc.f90 b/mlprec/impl/smoother/mld_c_jac_smoother_csetc.f90 new file mode 100644 index 00000000..7a7a3051 --- /dev/null +++ b/mlprec/impl/smoother/mld_c_jac_smoother_csetc.f90 @@ -0,0 +1,85 @@ +! +! +! 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_jac_smoother_csetc(sm,what,val,info,idx) + + use psb_base_mod + use mld_c_jac_smoother, mld_protect_nam => mld_c_jac_smoother_csetc + Implicit None + ! Arguments + class(mld_c_jac_smoother_type), intent(inout) :: sm + character(len=*), intent(in) :: what + character(len=*), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idx + integer(psb_ipk_) :: err_act, ival + character(len=20) :: name='c_jac_smoother_csetc' + + info = psb_success_ + call psb_erractionsave(err_act) + + + select case(psb_toupper(what)) + case('SMOOTHER_STOP') + if((trim(val) == 'T').or.(trim(val) == 'true')) then + sm%checkres = .true. + else + sm%checkres = .false. + end if + case('SMOOTHER_TRACE') + if((trim(val) == 'T').or.(trim(val) == 'true')) then + sm%printres = .true. + else + sm%printres = .false. + end if + case default + call sm%mld_c_base_smoother_type%set(what,val,info,idx=idx) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info, name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_c_jac_smoother_csetc diff --git a/mlprec/impl/smoother/mld_c_jac_smoother_cseti.f90 b/mlprec/impl/smoother/mld_c_jac_smoother_cseti.f90 new file mode 100644 index 00000000..294abf53 --- /dev/null +++ b/mlprec/impl/smoother/mld_c_jac_smoother_cseti.f90 @@ -0,0 +1,71 @@ +! +! +! 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_jac_smoother_cseti(sm,what,val,info,idx) + + use psb_base_mod + use mld_c_jac_smoother, mld_protect_nam => mld_c_jac_smoother_cseti + Implicit None + + ! Arguments + class(mld_c_jac_smoother_type), intent(inout) :: sm + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idx + integer(psb_ipk_) :: err_act + character(len=20) :: name='c_jac_smoother_cseti' + + info = psb_success_ + call psb_erractionsave(err_act) + + select case(psb_toupper(what)) + case('SMOOTHER_RESIDUAL') + sm%checkiter = val + case('SMOOTHER_ITRACE') + sm%printiter = val + case default + call sm%mld_c_base_smoother_type%set(what,val,info,idx=idx) + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_c_jac_smoother_cseti diff --git a/mlprec/impl/smoother/mld_c_jac_smoother_csetr.f90 b/mlprec/impl/smoother/mld_c_jac_smoother_csetr.f90 new file mode 100644 index 00000000..154b2b28 --- /dev/null +++ b/mlprec/impl/smoother/mld_c_jac_smoother_csetr.f90 @@ -0,0 +1,69 @@ +! +! +! 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_jac_smoother_csetr(sm,what,val,info,idx) + + use psb_base_mod + use mld_c_jac_smoother, mld_protect_nam => mld_c_jac_smoother_csetr + Implicit None + + ! Arguments + class(mld_c_jac_smoother_type), intent(inout) :: sm + character(len=*), intent(in) :: what + real(psb_spk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idx + integer(psb_ipk_) :: err_act + character(len=20) :: name='c_jac_smoother_csetr' + + info = psb_success_ + call psb_erractionsave(err_act) + + select case(psb_toupper(what)) + case('SMOOTHER_STOPTOL') + sm%tol = val + case default + call sm%mld_c_base_smoother_type%set(what,val,info,idx=idx) + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_c_jac_smoother_csetr diff --git a/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 index 5acd1463..485ab603 100644 --- a/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 @@ -1,15 +1,15 @@ -! -! +! +! ! 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 -! +! +! (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: @@ -21,7 +21,7 @@ ! 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 @@ -33,14 +33,15 @@ ! 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_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& +! +! +subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& & sweeps,work,wv,info,init,initu) - + use psb_base_mod + use psb_base_krylov_conv_mod use mld_d_jac_smoother, mld_protect_name => mld_d_jac_smoother_apply_vect - implicit none + implicit none type(psb_desc_type), intent(in) :: desc_data class(mld_d_jac_smoother_type), intent(inout) :: sm type(psb_d_vect_type),intent(inout) :: x @@ -55,10 +56,11 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& type(psb_d_vect_type),intent(inout), optional :: initu ! integer(psb_ipk_) :: n_row,n_col - type(psb_d_vect_type) :: tx, ty + type(psb_d_vect_type) :: tx, ty, r real(psb_dpk_), pointer :: aux(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act character :: trans_, init_ + real(psb_dpk_) :: res, resdenum character(len=20) :: name='d_jac_smoother_apply_v' call psb_erractionsave(err_act) @@ -67,7 +69,7 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ictxt = desc_data%get_context() call psb_info(ictxt,me,np) - + if (present(init)) then init_ = psb_toupper(init) else @@ -83,7 +85,7 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& goto 9999 end select - if (.not.allocated(sm%sv)) then + if (.not.allocated(sm%sv)) then info = 1121 call psb_errpush(info,name) goto 9999 @@ -92,45 +94,51 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() - if (4*n_col <= size(work)) then + if (4*n_col <= size(work)) then aux => work(:) else allocate(aux(4*n_col),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_alloc_request_ - call psb_errpush(info,name,& + call psb_errpush(info,name,& & i_err=(/4*n_col,izero,izero,izero,izero/),& & a_err='real(psb_dpk_)') - goto 9999 + goto 9999 end if endif - - if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nd_nnz_tot==0))) then + + if(sm%checkres) then + call psb_geall(r,desc_data,info) + call psb_geasb(r,desc_data,info) + resdenum = psb_genrm2(x,desc_data,info) + end if + + if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nd_nnz_tot==0))) then ! if .not.sv%is_iterative, there's no need to pass init - call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info) - + call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,& & name,a_err='Error in sub_aply Jacobi Sweeps = 1') goto 9999 endif - + else if (sweeps >= 0) then if (associated(sm%pa)) then ! - ! This means we are dealing with a pure Jacobi smoother/solver. + ! This means we are dealing with a pure Jacobi smoother/solver. ! associate(tx => wv(1), ty => wv(2)) select case (init_) - case('Z') + case('Z') - call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') + call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') case('Y') call psb_geaxpby(done,x,dzero,tx,desc_data,info) call psb_geaxpby(done,y,dzero,ty,desc_data,info) call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') + call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case('U') if (.not.present(initu)) then @@ -141,14 +149,14 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call psb_geaxpby(done,x,dzero,tx,desc_data,info) call psb_geaxpby(done,initu,dzero,ty,desc_data,info) call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') + call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case default call psb_errpush(psb_err_internal_error_,name,& & a_err='wrong init to smoother_apply') goto 9999 end select - + do i=1, sweeps-1 ! ! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)), @@ -159,24 +167,38 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info /= psb_success_) exit - call sm%sv%apply(done,tx,done,ty,desc_data,trans_,aux,wv(3:),info,init='Y') + call sm%sv%apply(done,tx,done,ty,desc_data,trans_,aux,wv(3:),info,init='Y') if (info /= psb_success_) exit + + if ( sm%checkres.and.(mod(i,sm%checkiter) == 0) ) then + call psb_geaxpby(done,x,dzero,r,r,desc_data,info) + call psb_spmm(-done,sm%pa,ty,done,r,desc_data,info) + res = psb_genrm2(r,desc_data,info) + if( sm%printres ) then + call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) + end if + if (res/resdenum < sm%tol) then + if( sm%printres ) call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) + exit + end if + end if + end do - + if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_internal_error_ - call psb_errpush(info,name,& + call psb_errpush(info,name,& & a_err='subsolve with Jacobi sweeps > 1') - goto 9999 + goto 9999 end if - + end associate - + else ! ! @@ -198,15 +220,15 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! significant when sweeps=1 (a common case) ! select case (init_) - case('Z') + case('Z') - call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') + call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') case('Y') call psb_geaxpby(done,x,dzero,tx,desc_data,info) call psb_geaxpby(done,y,dzero,ty,desc_data,info) call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') + call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case('U') if (.not.present(initu)) then @@ -217,7 +239,7 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call psb_geaxpby(done,x,dzero,tx,desc_data,info) call psb_geaxpby(done,initu,dzero,ty,desc_data,info) call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') + call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case default call psb_errpush(psb_err_internal_error_,name,& @@ -236,23 +258,37 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info /= psb_success_) exit - call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') + call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') if (info /= psb_success_) exit + + if ( sm%checkres.and.(mod(i,sm%checkiter) == 0) ) then + call psb_geaxpby(done,x,dzero,r,r,desc_data,info) + call psb_spmm(-done,sm%pa,ty,done,r,desc_data,info) + res = psb_genrm2(r,desc_data,info) + if( sm%printres ) then + call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) + end if + if (res/resdenum < sm%tol) then + if( sm%printres ) call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) + exit + end if + end if + end do if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_internal_error_ - call psb_errpush(info,name,& + call psb_errpush(info,name,& & a_err='subsolve with Jacobi sweeps > 1') - goto 9999 + goto 9999 end if end associate end if - + else info = psb_err_iarg_neg_ @@ -262,10 +298,14 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& endif - if (.not.(4*n_col <= size(work))) then + if (.not.(4*n_col <= size(work))) then deallocate(aux) endif + if(sm%checkres) then + call psb_gefree(r,desc_data,info) + end if + call psb_erractionrestore(err_act) return diff --git a/mlprec/impl/smoother/mld_d_jac_smoother_bld.f90 b/mlprec/impl/smoother/mld_d_jac_smoother_bld.f90 index f847947e..dc09edb3 100644 --- a/mlprec/impl/smoother/mld_d_jac_smoother_bld.f90 +++ b/mlprec/impl/smoother/mld_d_jac_smoother_bld.f90 @@ -1,15 +1,15 @@ -! -! +! +! ! 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 -! +! +! (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: @@ -21,7 +21,7 @@ ! 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 @@ -33,8 +33,8 @@ ! 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_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) use psb_base_mod @@ -44,7 +44,7 @@ subroutine mld_d_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) ! Arguments type(psb_dspmat_type), intent(in), target :: a - Type(psb_desc_type), Intent(inout) :: desc_a + Type(psb_desc_type), Intent(inout) :: desc_a class(mld_d_jac_smoother_type), intent(inout) :: sm integer(psb_ipk_), intent(out) :: info class(psb_d_base_sparse_mat), intent(in), optional :: amold @@ -71,6 +71,9 @@ subroutine mld_d_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) 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() @@ -85,8 +88,8 @@ subroutine mld_d_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) else call a%csclip(sm%nd,info,& & jmin=nrow_a+1,rscale=.false.,cscale=.false.) - if (info == psb_success_) then - if (present(amold)) then + if (info == psb_success_) then + if (present(amold)) then call sm%nd%cscnv(info,& & mold=amold,dupl=psb_dupl_add_) else diff --git a/mlprec/impl/smoother/mld_d_jac_smoother_csetc.f90 b/mlprec/impl/smoother/mld_d_jac_smoother_csetc.f90 new file mode 100644 index 00000000..17e27ffc --- /dev/null +++ b/mlprec/impl/smoother/mld_d_jac_smoother_csetc.f90 @@ -0,0 +1,85 @@ +! +! +! 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_jac_smoother_csetc(sm,what,val,info,idx) + + use psb_base_mod + use mld_d_jac_smoother, mld_protect_nam => mld_d_jac_smoother_csetc + Implicit None + ! Arguments + class(mld_d_jac_smoother_type), intent(inout) :: sm + character(len=*), intent(in) :: what + character(len=*), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idx + integer(psb_ipk_) :: err_act, ival + character(len=20) :: name='d_jac_smoother_csetc' + + info = psb_success_ + call psb_erractionsave(err_act) + + + select case(psb_toupper(what)) + case('SMOOTHER_STOP') + if((trim(val) == 'T').or.(trim(val) == 'true')) then + sm%checkres = .true. + else + sm%checkres = .false. + end if + case('SMOOTHER_TRACE') + if((trim(val) == 'T').or.(trim(val) == 'true')) then + sm%printres = .true. + else + sm%printres = .false. + end if + case default + call sm%mld_d_base_smoother_type%set(what,val,info,idx=idx) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info, name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_d_jac_smoother_csetc diff --git a/mlprec/impl/smoother/mld_d_jac_smoother_cseti.f90 b/mlprec/impl/smoother/mld_d_jac_smoother_cseti.f90 new file mode 100644 index 00000000..43ea0cd4 --- /dev/null +++ b/mlprec/impl/smoother/mld_d_jac_smoother_cseti.f90 @@ -0,0 +1,71 @@ +! +! +! 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_jac_smoother_cseti(sm,what,val,info,idx) + + use psb_base_mod + use mld_d_jac_smoother, mld_protect_nam => mld_d_jac_smoother_cseti + Implicit None + + ! Arguments + class(mld_d_jac_smoother_type), intent(inout) :: sm + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idx + integer(psb_ipk_) :: err_act + character(len=20) :: name='d_jac_smoother_cseti' + + info = psb_success_ + call psb_erractionsave(err_act) + + select case(psb_toupper(what)) + case('SMOOTHER_RESIDUAL') + sm%checkiter = val + case('SMOOTHER_ITRACE') + sm%printiter = val + case default + call sm%mld_d_base_smoother_type%set(what,val,info,idx=idx) + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_d_jac_smoother_cseti diff --git a/mlprec/impl/smoother/mld_d_jac_smoother_csetr.f90 b/mlprec/impl/smoother/mld_d_jac_smoother_csetr.f90 new file mode 100644 index 00000000..03cba588 --- /dev/null +++ b/mlprec/impl/smoother/mld_d_jac_smoother_csetr.f90 @@ -0,0 +1,69 @@ +! +! +! 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_jac_smoother_csetr(sm,what,val,info,idx) + + use psb_base_mod + use mld_d_jac_smoother, mld_protect_nam => mld_d_jac_smoother_csetr + Implicit None + + ! Arguments + class(mld_d_jac_smoother_type), intent(inout) :: sm + character(len=*), intent(in) :: what + real(psb_dpk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idx + integer(psb_ipk_) :: err_act + character(len=20) :: name='d_jac_smoother_csetr' + + info = psb_success_ + call psb_erractionsave(err_act) + + select case(psb_toupper(what)) + case('SMOOTHER_STOPTOL') + sm%tol = val + case default + call sm%mld_d_base_smoother_type%set(what,val,info,idx=idx) + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_d_jac_smoother_csetr diff --git a/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 index bcee98e6..5fb33878 100644 --- a/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 @@ -1,15 +1,15 @@ -! -! +! +! ! 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 -! +! +! (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: @@ -21,7 +21,7 @@ ! 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 @@ -33,14 +33,15 @@ ! 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_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& +! +! +subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& & sweeps,work,wv,info,init,initu) - + use psb_base_mod + use psb_base_krylov_conv_mod use mld_s_jac_smoother, mld_protect_name => mld_s_jac_smoother_apply_vect - implicit none + implicit none type(psb_desc_type), intent(in) :: desc_data class(mld_s_jac_smoother_type), intent(inout) :: sm type(psb_s_vect_type),intent(inout) :: x @@ -55,10 +56,11 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& type(psb_s_vect_type),intent(inout), optional :: initu ! integer(psb_ipk_) :: n_row,n_col - type(psb_s_vect_type) :: tx, ty + type(psb_s_vect_type) :: tx, ty, r real(psb_spk_), pointer :: aux(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act character :: trans_, init_ + real(psb_dpk_) :: res, resdenum character(len=20) :: name='s_jac_smoother_apply_v' call psb_erractionsave(err_act) @@ -67,7 +69,7 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ictxt = desc_data%get_context() call psb_info(ictxt,me,np) - + if (present(init)) then init_ = psb_toupper(init) else @@ -83,7 +85,7 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& goto 9999 end select - if (.not.allocated(sm%sv)) then + if (.not.allocated(sm%sv)) then info = 1121 call psb_errpush(info,name) goto 9999 @@ -92,45 +94,51 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() - if (4*n_col <= size(work)) then + if (4*n_col <= size(work)) then aux => work(:) else allocate(aux(4*n_col),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_alloc_request_ - call psb_errpush(info,name,& + call psb_errpush(info,name,& & i_err=(/4*n_col,izero,izero,izero,izero/),& & a_err='real(psb_spk_)') - goto 9999 + goto 9999 end if endif - - if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nd_nnz_tot==0))) then + + if(sm%checkres) then + call psb_geall(r,desc_data,info) + call psb_geasb(r,desc_data,info) + resdenum = psb_genrm2(x,desc_data,info) + end if + + if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nd_nnz_tot==0))) then ! if .not.sv%is_iterative, there's no need to pass init - call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info) - + call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,& & name,a_err='Error in sub_aply Jacobi Sweeps = 1') goto 9999 endif - + else if (sweeps >= 0) then if (associated(sm%pa)) then ! - ! This means we are dealing with a pure Jacobi smoother/solver. + ! This means we are dealing with a pure Jacobi smoother/solver. ! associate(tx => wv(1), ty => wv(2)) select case (init_) - case('Z') + case('Z') - call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') + call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') case('Y') call psb_geaxpby(sone,x,szero,tx,desc_data,info) call psb_geaxpby(sone,y,szero,ty,desc_data,info) call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') + call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case('U') if (.not.present(initu)) then @@ -141,14 +149,14 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call psb_geaxpby(sone,x,szero,tx,desc_data,info) call psb_geaxpby(sone,initu,szero,ty,desc_data,info) call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') + call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case default call psb_errpush(psb_err_internal_error_,name,& & a_err='wrong init to smoother_apply') goto 9999 end select - + do i=1, sweeps-1 ! ! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)), @@ -159,24 +167,38 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info /= psb_success_) exit - call sm%sv%apply(sone,tx,sone,ty,desc_data,trans_,aux,wv(3:),info,init='Y') + call sm%sv%apply(sone,tx,sone,ty,desc_data,trans_,aux,wv(3:),info,init='Y') if (info /= psb_success_) exit + + if ( sm%checkres.and.(mod(i,sm%checkiter) == 0) ) then + call psb_geaxpby(sone,x,szero,r,r,desc_data,info) + call psb_spmm(-sone,sm%pa,ty,sone,r,desc_data,info) + res = psb_genrm2(r,desc_data,info) + if( sm%printres ) then + call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) + end if + if (res/resdenum < sm%tol) then + if( sm%printres ) call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) + exit + end if + end if + end do - + if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_internal_error_ - call psb_errpush(info,name,& + call psb_errpush(info,name,& & a_err='subsolve with Jacobi sweeps > 1') - goto 9999 + goto 9999 end if - + end associate - + else ! ! @@ -198,15 +220,15 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! significant when sweeps=1 (a common case) ! select case (init_) - case('Z') + case('Z') - call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') + call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') case('Y') call psb_geaxpby(sone,x,szero,tx,desc_data,info) call psb_geaxpby(sone,y,szero,ty,desc_data,info) call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') + call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case('U') if (.not.present(initu)) then @@ -217,7 +239,7 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call psb_geaxpby(sone,x,szero,tx,desc_data,info) call psb_geaxpby(sone,initu,szero,ty,desc_data,info) call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') + call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case default call psb_errpush(psb_err_internal_error_,name,& @@ -236,23 +258,37 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info /= psb_success_) exit - call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') + call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') if (info /= psb_success_) exit + + if ( sm%checkres.and.(mod(i,sm%checkiter) == 0) ) then + call psb_geaxpby(sone,x,szero,r,r,desc_data,info) + call psb_spmm(-sone,sm%pa,ty,sone,r,desc_data,info) + res = psb_genrm2(r,desc_data,info) + if( sm%printres ) then + call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) + end if + if (res/resdenum < sm%tol) then + if( sm%printres ) call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) + exit + end if + end if + end do if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_internal_error_ - call psb_errpush(info,name,& + call psb_errpush(info,name,& & a_err='subsolve with Jacobi sweeps > 1') - goto 9999 + goto 9999 end if end associate end if - + else info = psb_err_iarg_neg_ @@ -262,10 +298,14 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& endif - if (.not.(4*n_col <= size(work))) then + if (.not.(4*n_col <= size(work))) then deallocate(aux) endif + if(sm%checkres) then + call psb_gefree(r,desc_data,info) + end if + call psb_erractionrestore(err_act) return diff --git a/mlprec/impl/smoother/mld_s_jac_smoother_bld.f90 b/mlprec/impl/smoother/mld_s_jac_smoother_bld.f90 index 9af94330..958c7f28 100644 --- a/mlprec/impl/smoother/mld_s_jac_smoother_bld.f90 +++ b/mlprec/impl/smoother/mld_s_jac_smoother_bld.f90 @@ -1,15 +1,15 @@ -! -! +! +! ! 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 -! +! +! (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: @@ -21,7 +21,7 @@ ! 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 @@ -33,8 +33,8 @@ ! 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_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) use psb_base_mod @@ -44,7 +44,7 @@ subroutine mld_s_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) ! Arguments type(psb_sspmat_type), intent(in), target :: a - Type(psb_desc_type), Intent(inout) :: desc_a + Type(psb_desc_type), Intent(inout) :: desc_a class(mld_s_jac_smoother_type), intent(inout) :: sm integer(psb_ipk_), intent(out) :: info class(psb_s_base_sparse_mat), intent(in), optional :: amold @@ -71,6 +71,9 @@ subroutine mld_s_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) 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() @@ -85,8 +88,8 @@ subroutine mld_s_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) else call a%csclip(sm%nd,info,& & jmin=nrow_a+1,rscale=.false.,cscale=.false.) - if (info == psb_success_) then - if (present(amold)) then + if (info == psb_success_) then + if (present(amold)) then call sm%nd%cscnv(info,& & mold=amold,dupl=psb_dupl_add_) else diff --git a/mlprec/impl/smoother/mld_s_jac_smoother_csetc.f90 b/mlprec/impl/smoother/mld_s_jac_smoother_csetc.f90 new file mode 100644 index 00000000..03609c97 --- /dev/null +++ b/mlprec/impl/smoother/mld_s_jac_smoother_csetc.f90 @@ -0,0 +1,85 @@ +! +! +! 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_jac_smoother_csetc(sm,what,val,info,idx) + + use psb_base_mod + use mld_s_jac_smoother, mld_protect_nam => mld_s_jac_smoother_csetc + Implicit None + ! Arguments + class(mld_s_jac_smoother_type), intent(inout) :: sm + character(len=*), intent(in) :: what + character(len=*), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idx + integer(psb_ipk_) :: err_act, ival + character(len=20) :: name='s_jac_smoother_csetc' + + info = psb_success_ + call psb_erractionsave(err_act) + + + select case(psb_toupper(what)) + case('SMOOTHER_STOP') + if((trim(val) == 'T').or.(trim(val) == 'true')) then + sm%checkres = .true. + else + sm%checkres = .false. + end if + case('SMOOTHER_TRACE') + if((trim(val) == 'T').or.(trim(val) == 'true')) then + sm%printres = .true. + else + sm%printres = .false. + end if + case default + call sm%mld_s_base_smoother_type%set(what,val,info,idx=idx) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info, name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_s_jac_smoother_csetc diff --git a/mlprec/impl/smoother/mld_s_jac_smoother_cseti.f90 b/mlprec/impl/smoother/mld_s_jac_smoother_cseti.f90 new file mode 100644 index 00000000..8a60c193 --- /dev/null +++ b/mlprec/impl/smoother/mld_s_jac_smoother_cseti.f90 @@ -0,0 +1,71 @@ +! +! +! 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_jac_smoother_cseti(sm,what,val,info,idx) + + use psb_base_mod + use mld_s_jac_smoother, mld_protect_nam => mld_s_jac_smoother_cseti + Implicit None + + ! Arguments + class(mld_s_jac_smoother_type), intent(inout) :: sm + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idx + integer(psb_ipk_) :: err_act + character(len=20) :: name='s_jac_smoother_cseti' + + info = psb_success_ + call psb_erractionsave(err_act) + + select case(psb_toupper(what)) + case('SMOOTHER_RESIDUAL') + sm%checkiter = val + case('SMOOTHER_ITRACE') + sm%printiter = val + case default + call sm%mld_s_base_smoother_type%set(what,val,info,idx=idx) + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_s_jac_smoother_cseti diff --git a/mlprec/impl/smoother/mld_s_jac_smoother_csetr.f90 b/mlprec/impl/smoother/mld_s_jac_smoother_csetr.f90 new file mode 100644 index 00000000..8438b353 --- /dev/null +++ b/mlprec/impl/smoother/mld_s_jac_smoother_csetr.f90 @@ -0,0 +1,69 @@ +! +! +! 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_jac_smoother_csetr(sm,what,val,info,idx) + + use psb_base_mod + use mld_s_jac_smoother, mld_protect_nam => mld_s_jac_smoother_csetr + Implicit None + + ! Arguments + class(mld_s_jac_smoother_type), intent(inout) :: sm + character(len=*), intent(in) :: what + real(psb_spk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idx + integer(psb_ipk_) :: err_act + character(len=20) :: name='s_jac_smoother_csetr' + + info = psb_success_ + call psb_erractionsave(err_act) + + select case(psb_toupper(what)) + case('SMOOTHER_STOPTOL') + sm%tol = val + case default + call sm%mld_s_base_smoother_type%set(what,val,info,idx=idx) + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_s_jac_smoother_csetr diff --git a/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 index 13e6c144..72a13101 100644 --- a/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 @@ -1,15 +1,15 @@ -! -! +! +! ! 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 -! +! +! (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: @@ -21,7 +21,7 @@ ! 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 @@ -33,14 +33,15 @@ ! 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_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& +! +! +subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& & sweeps,work,wv,info,init,initu) - + use psb_base_mod + use psb_base_krylov_conv_mod use mld_z_jac_smoother, mld_protect_name => mld_z_jac_smoother_apply_vect - implicit none + implicit none type(psb_desc_type), intent(in) :: desc_data class(mld_z_jac_smoother_type), intent(inout) :: sm type(psb_z_vect_type),intent(inout) :: x @@ -55,10 +56,11 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& type(psb_z_vect_type),intent(inout), optional :: initu ! integer(psb_ipk_) :: n_row,n_col - type(psb_z_vect_type) :: tx, ty + type(psb_z_vect_type) :: tx, ty, r complex(psb_dpk_), pointer :: aux(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act character :: trans_, init_ + real(psb_dpk_) :: res, resdenum character(len=20) :: name='z_jac_smoother_apply_v' call psb_erractionsave(err_act) @@ -67,7 +69,7 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ictxt = desc_data%get_context() call psb_info(ictxt,me,np) - + if (present(init)) then init_ = psb_toupper(init) else @@ -83,7 +85,7 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& goto 9999 end select - if (.not.allocated(sm%sv)) then + if (.not.allocated(sm%sv)) then info = 1121 call psb_errpush(info,name) goto 9999 @@ -92,45 +94,51 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() - if (4*n_col <= size(work)) then + if (4*n_col <= size(work)) then aux => work(:) else allocate(aux(4*n_col),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_alloc_request_ - call psb_errpush(info,name,& + call psb_errpush(info,name,& & i_err=(/4*n_col,izero,izero,izero,izero/),& & a_err='complex(psb_dpk_)') - goto 9999 + goto 9999 end if endif - - if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nd_nnz_tot==0))) then + + if(sm%checkres) then + call psb_geall(r,desc_data,info) + call psb_geasb(r,desc_data,info) + resdenum = psb_genrm2(x,desc_data,info) + end if + + if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nd_nnz_tot==0))) then ! if .not.sv%is_iterative, there's no need to pass init - call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info) - + call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,& & name,a_err='Error in sub_aply Jacobi Sweeps = 1') goto 9999 endif - + else if (sweeps >= 0) then if (associated(sm%pa)) then ! - ! This means we are dealing with a pure Jacobi smoother/solver. + ! This means we are dealing with a pure Jacobi smoother/solver. ! associate(tx => wv(1), ty => wv(2)) select case (init_) - case('Z') + case('Z') - call sm%sv%apply(zone,x,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') + call sm%sv%apply(zone,x,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') case('Y') call psb_geaxpby(zone,x,zzero,tx,desc_data,info) call psb_geaxpby(zone,y,zzero,ty,desc_data,info) call psb_spmm(-zone,sm%pa,ty,zone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') + call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case('U') if (.not.present(initu)) then @@ -141,14 +149,14 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call psb_geaxpby(zone,x,zzero,tx,desc_data,info) call psb_geaxpby(zone,initu,zzero,ty,desc_data,info) call psb_spmm(-zone,sm%pa,ty,zone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') + call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case default call psb_errpush(psb_err_internal_error_,name,& & a_err='wrong init to smoother_apply') goto 9999 end select - + do i=1, sweeps-1 ! ! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)), @@ -159,24 +167,38 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info /= psb_success_) exit - call sm%sv%apply(zone,tx,zone,ty,desc_data,trans_,aux,wv(3:),info,init='Y') + call sm%sv%apply(zone,tx,zone,ty,desc_data,trans_,aux,wv(3:),info,init='Y') if (info /= psb_success_) exit + + if ( sm%checkres.and.(mod(i,sm%checkiter) == 0) ) then + call psb_geaxpby(zone,x,zzero,r,r,desc_data,info) + call psb_spmm(-zone,sm%pa,ty,zone,r,desc_data,info) + res = psb_genrm2(r,desc_data,info) + if( sm%printres ) then + call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) + end if + if (res/resdenum < sm%tol) then + if( sm%printres ) call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) + exit + end if + end if + end do - + if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_internal_error_ - call psb_errpush(info,name,& + call psb_errpush(info,name,& & a_err='subsolve with Jacobi sweeps > 1') - goto 9999 + goto 9999 end if - + end associate - + else ! ! @@ -198,15 +220,15 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! significant when sweeps=1 (a common case) ! select case (init_) - case('Z') + case('Z') - call sm%sv%apply(zone,x,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') + call sm%sv%apply(zone,x,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') case('Y') call psb_geaxpby(zone,x,zzero,tx,desc_data,info) call psb_geaxpby(zone,y,zzero,ty,desc_data,info) call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') + call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case('U') if (.not.present(initu)) then @@ -217,7 +239,7 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call psb_geaxpby(zone,x,zzero,tx,desc_data,info) call psb_geaxpby(zone,initu,zzero,ty,desc_data,info) call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') + call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case default call psb_errpush(psb_err_internal_error_,name,& @@ -236,23 +258,37 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info /= psb_success_) exit - call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') + call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') if (info /= psb_success_) exit + + if ( sm%checkres.and.(mod(i,sm%checkiter) == 0) ) then + call psb_geaxpby(zone,x,zzero,r,r,desc_data,info) + call psb_spmm(-zone,sm%pa,ty,zone,r,desc_data,info) + res = psb_genrm2(r,desc_data,info) + if( sm%printres ) then + call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) + end if + if (res/resdenum < sm%tol) then + if( sm%printres ) call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) + exit + end if + end if + end do if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_internal_error_ - call psb_errpush(info,name,& + call psb_errpush(info,name,& & a_err='subsolve with Jacobi sweeps > 1') - goto 9999 + goto 9999 end if end associate end if - + else info = psb_err_iarg_neg_ @@ -262,10 +298,14 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& endif - if (.not.(4*n_col <= size(work))) then + if (.not.(4*n_col <= size(work))) then deallocate(aux) endif + if(sm%checkres) then + call psb_gefree(r,desc_data,info) + end if + call psb_erractionrestore(err_act) return diff --git a/mlprec/impl/smoother/mld_z_jac_smoother_bld.f90 b/mlprec/impl/smoother/mld_z_jac_smoother_bld.f90 index d6049271..46d524c9 100644 --- a/mlprec/impl/smoother/mld_z_jac_smoother_bld.f90 +++ b/mlprec/impl/smoother/mld_z_jac_smoother_bld.f90 @@ -1,15 +1,15 @@ -! -! +! +! ! 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 -! +! +! (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: @@ -21,7 +21,7 @@ ! 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 @@ -33,8 +33,8 @@ ! 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_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) use psb_base_mod @@ -44,7 +44,7 @@ subroutine mld_z_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) ! Arguments type(psb_zspmat_type), intent(in), target :: a - Type(psb_desc_type), Intent(inout) :: desc_a + Type(psb_desc_type), Intent(inout) :: desc_a class(mld_z_jac_smoother_type), intent(inout) :: sm integer(psb_ipk_), intent(out) :: info class(psb_z_base_sparse_mat), intent(in), optional :: amold @@ -71,6 +71,9 @@ subroutine mld_z_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) 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() @@ -85,8 +88,8 @@ subroutine mld_z_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) else call a%csclip(sm%nd,info,& & jmin=nrow_a+1,rscale=.false.,cscale=.false.) - if (info == psb_success_) then - if (present(amold)) then + if (info == psb_success_) then + if (present(amold)) then call sm%nd%cscnv(info,& & mold=amold,dupl=psb_dupl_add_) else diff --git a/mlprec/impl/smoother/mld_z_jac_smoother_csetc.f90 b/mlprec/impl/smoother/mld_z_jac_smoother_csetc.f90 new file mode 100644 index 00000000..ed8a3d38 --- /dev/null +++ b/mlprec/impl/smoother/mld_z_jac_smoother_csetc.f90 @@ -0,0 +1,85 @@ +! +! +! 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_jac_smoother_csetc(sm,what,val,info,idx) + + use psb_base_mod + use mld_z_jac_smoother, mld_protect_nam => mld_z_jac_smoother_csetc + Implicit None + ! Arguments + class(mld_z_jac_smoother_type), intent(inout) :: sm + character(len=*), intent(in) :: what + character(len=*), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idx + integer(psb_ipk_) :: err_act, ival + character(len=20) :: name='z_jac_smoother_csetc' + + info = psb_success_ + call psb_erractionsave(err_act) + + + select case(psb_toupper(what)) + case('SMOOTHER_STOP') + if((trim(val) == 'T').or.(trim(val) == 'true')) then + sm%checkres = .true. + else + sm%checkres = .false. + end if + case('SMOOTHER_TRACE') + if((trim(val) == 'T').or.(trim(val) == 'true')) then + sm%printres = .true. + else + sm%printres = .false. + end if + case default + call sm%mld_z_base_smoother_type%set(what,val,info,idx=idx) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info, name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_z_jac_smoother_csetc diff --git a/mlprec/impl/smoother/mld_z_jac_smoother_cseti.f90 b/mlprec/impl/smoother/mld_z_jac_smoother_cseti.f90 new file mode 100644 index 00000000..c0b12e8b --- /dev/null +++ b/mlprec/impl/smoother/mld_z_jac_smoother_cseti.f90 @@ -0,0 +1,71 @@ +! +! +! 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_jac_smoother_cseti(sm,what,val,info,idx) + + use psb_base_mod + use mld_z_jac_smoother, mld_protect_nam => mld_z_jac_smoother_cseti + Implicit None + + ! Arguments + class(mld_z_jac_smoother_type), intent(inout) :: sm + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idx + integer(psb_ipk_) :: err_act + character(len=20) :: name='z_jac_smoother_cseti' + + info = psb_success_ + call psb_erractionsave(err_act) + + select case(psb_toupper(what)) + case('SMOOTHER_RESIDUAL') + sm%checkiter = val + case('SMOOTHER_ITRACE') + sm%printiter = val + case default + call sm%mld_z_base_smoother_type%set(what,val,info,idx=idx) + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_z_jac_smoother_cseti diff --git a/mlprec/impl/smoother/mld_z_jac_smoother_csetr.f90 b/mlprec/impl/smoother/mld_z_jac_smoother_csetr.f90 new file mode 100644 index 00000000..5131f61c --- /dev/null +++ b/mlprec/impl/smoother/mld_z_jac_smoother_csetr.f90 @@ -0,0 +1,69 @@ +! +! +! 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_jac_smoother_csetr(sm,what,val,info,idx) + + use psb_base_mod + use mld_z_jac_smoother, mld_protect_nam => mld_z_jac_smoother_csetr + Implicit None + + ! Arguments + class(mld_z_jac_smoother_type), intent(inout) :: sm + character(len=*), intent(in) :: what + real(psb_dpk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idx + integer(psb_ipk_) :: err_act + character(len=20) :: name='z_jac_smoother_csetr' + + info = psb_success_ + call psb_erractionsave(err_act) + + select case(psb_toupper(what)) + case('SMOOTHER_STOPTOL') + sm%tol = val + case default + call sm%mld_z_base_smoother_type%set(what,val,info,idx=idx) + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_z_jac_smoother_csetr diff --git a/mlprec/mld_c_jac_smoother.f90 b/mlprec/mld_c_jac_smoother.f90 index c579d789..d43eabf9 100644 --- a/mlprec/mld_c_jac_smoother.f90 +++ b/mlprec/mld_c_jac_smoother.f90 @@ -1,15 +1,15 @@ -! -! +! +! ! 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 -! +! +! (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: @@ -21,7 +21,7 @@ ! 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 @@ -33,34 +33,39 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! File: mld_c_jac_smoother_mod.f90 ! ! Module: mld_c_jac_smoother_mod ! -! This module defines: +! This module defines: ! the mld_c_jac_smoother_type data structure containing the ! smoother for a Jacobi/block Jacobi smoother. ! The smoother stores in ND the block off-diagonal matrix. ! One special case is treated separately, when the solver is DIAG or L1-DIAG ! then the ND is the entire off-diagonal part of the matrix (including the ! main diagonal block), so that it becomes possible to implement -! a pure Jacobi or L1-Jacobi global solver. -! +! a pure Jacobi or L1-Jacobi global solver. +! module mld_c_jac_smoother use mld_c_base_smoother_mod type, extends(mld_c_base_smoother_type) :: mld_c_jac_smoother_type ! The local solver component is inherited from the - ! parent type. + ! parent type. ! class(mld_c_base_solver_type), allocatable :: sv - ! + ! type(psb_cspmat_type), pointer :: pa => null() type(psb_cspmat_type) :: nd integer(psb_lpk_) :: nd_nnz_tot + logical :: checkres + logical :: printres + integer(psb_ipk_) :: checkiter + integer(psb_ipk_) :: printiter + real(psb_dpk_) :: tol contains procedure, pass(sm) :: dump => mld_c_jac_smoother_dmp procedure, pass(sm) :: build => mld_c_jac_smoother_bld @@ -69,6 +74,9 @@ module mld_c_jac_smoother procedure, pass(sm) :: apply_v => mld_c_jac_smoother_apply_vect procedure, pass(sm) :: apply_a => mld_c_jac_smoother_apply procedure, pass(sm) :: free => c_jac_smoother_free + procedure, pass(sm) :: cseti => mld_c_jac_smoother_cseti + procedure, pass(sm) :: csetc => mld_c_jac_smoother_csetc + procedure, pass(sm) :: csetr => mld_c_jac_smoother_csetr procedure, pass(sm) :: descr => mld_c_jac_smoother_descr procedure, pass(sm) :: sizeof => c_jac_smoother_sizeof procedure, pass(sm) :: get_nzeros => c_jac_smoother_get_nzeros @@ -84,13 +92,13 @@ module mld_c_jac_smoother & c_jac_smoother_get_wrksize - interface - subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& + interface + subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& & sweeps,work,wv,info,init,initu) import :: psb_desc_type, mld_c_jac_smoother_type, psb_c_vect_type, psb_spk_, & & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type,& & psb_ipk_ - + type(psb_desc_type), intent(in) :: desc_data class(mld_c_jac_smoother_type), intent(inout) :: sm type(psb_c_vect_type),intent(inout) :: x @@ -105,9 +113,9 @@ module mld_c_jac_smoother type(psb_c_vect_type),intent(inout), optional :: initu end subroutine mld_c_jac_smoother_apply_vect end interface - - interface - subroutine mld_c_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& + + interface + subroutine mld_c_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& & sweeps,work,info,init,initu) import :: psb_desc_type, mld_c_jac_smoother_type, psb_c_vect_type, psb_spk_, & & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, & @@ -125,14 +133,14 @@ module mld_c_jac_smoother complex(psb_spk_),intent(inout), optional :: initu(:) end subroutine mld_c_jac_smoother_apply end interface - - interface + + interface subroutine mld_c_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) import :: psb_desc_type, mld_c_jac_smoother_type, psb_c_vect_type, psb_spk_, & & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type,& & psb_ipk_, psb_i_base_vect_type type(psb_cspmat_type), intent(in), target :: a - Type(psb_desc_type), Intent(inout) :: desc_a + Type(psb_desc_type), Intent(inout) :: desc_a class(mld_c_jac_smoother_type), intent(inout) :: sm integer(psb_ipk_), intent(out) :: info class(psb_c_base_sparse_mat), intent(in), optional :: amold @@ -140,8 +148,8 @@ module mld_c_jac_smoother class(psb_i_base_vect_type), intent(in), optional :: imold end subroutine mld_c_jac_smoother_bld end interface - - interface + + interface subroutine mld_c_jac_smoother_cnv(sm,info,amold,vmold,imold) import :: mld_c_jac_smoother_type, psb_spk_, & & psb_c_base_sparse_mat, psb_c_base_vect_type,& @@ -153,13 +161,13 @@ module mld_c_jac_smoother class(psb_i_base_vect_type), intent(in), optional :: imold end subroutine mld_c_jac_smoother_cnv end interface - - interface + + interface subroutine mld_c_jac_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver) import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & & psb_spk_, mld_c_jac_smoother_type, psb_epk_, psb_desc_type, & & psb_ipk_ - implicit none + implicit none class(mld_c_jac_smoother_type), intent(in) :: sm integer(psb_ipk_), intent(in) :: ictxt integer(psb_ipk_), intent(in) :: level @@ -168,8 +176,8 @@ module mld_c_jac_smoother logical, optional, intent(in) :: smoother, solver end subroutine mld_c_jac_smoother_dmp end interface - - interface + + interface subroutine mld_c_jac_smoother_clone(sm,smout,info) import :: mld_c_jac_smoother_type, psb_spk_, & & mld_c_base_smoother_type, psb_ipk_ @@ -188,7 +196,46 @@ module mld_c_jac_smoother logical, intent(in), optional :: coarse end subroutine mld_c_jac_smoother_descr end interface - + + interface + subroutine mld_c_jac_smoother_cseti(sm,what,val,info,idx) + import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & + & psb_spk_, mld_c_jac_smoother_type, psb_epk_, psb_desc_type, psb_ipk_ + implicit none + class(mld_c_jac_smoother_type), intent(inout) :: sm + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idx + end subroutine mld_c_jac_smoother_cseti + end interface + + interface + subroutine mld_c_jac_smoother_csetc(sm,what,val,info,idx) + import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & + & psb_spk_, mld_c_jac_smoother_type, psb_epk_, psb_desc_type, psb_ipk_ + implicit none + class(mld_c_jac_smoother_type), intent(inout) :: sm + character(len=*), intent(in) :: what + character(len=*), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idx + end subroutine mld_c_jac_smoother_csetc + end interface + + interface + subroutine mld_c_jac_smoother_csetr(sm,what,val,info,idx) + import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & + & psb_spk_, mld_c_jac_smoother_type, psb_epk_, psb_desc_type, psb_ipk_ + implicit none + class(mld_c_jac_smoother_type), intent(inout) :: sm + character(len=*), intent(in) :: what + real(psb_spk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idx + end subroutine mld_c_jac_smoother_csetr + end interface + contains @@ -208,18 +255,18 @@ contains - if (allocated(sm%sv)) then + if (allocated(sm%sv)) then call sm%sv%free(info) if (info == psb_success_) deallocate(sm%sv,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) - goto 9999 + goto 9999 end if end if call sm%nd%free() sm%pa => null() - + call psb_erractionrestore(err_act) return @@ -229,13 +276,13 @@ contains function c_jac_smoother_sizeof(sm) result(val) - implicit none + implicit none ! Arguments class(mld_c_jac_smoother_type), intent(in) :: sm integer(psb_epk_) :: val integer(psb_ipk_) :: i - val = psb_sizeof_lp + val = psb_sizeof_lp if (allocated(sm%sv)) val = val + sm%sv%sizeof() val = val + sm%nd%sizeof() @@ -244,7 +291,7 @@ contains function c_jac_smoother_get_nzeros(sm) result(val) - implicit none + implicit none ! Arguments class(mld_c_jac_smoother_type), intent(in) :: sm integer(psb_epk_) :: val @@ -258,27 +305,27 @@ contains end function c_jac_smoother_get_nzeros function c_jac_smoother_get_wrksize(sm) result(val) - implicit none + implicit none class(mld_c_jac_smoother_type), intent(inout) :: sm integer(psb_ipk_) :: val val = 2 if (allocated(sm%sv)) val = val + sm%sv%get_wrksz() - + end function c_jac_smoother_get_wrksize - + function c_jac_smoother_get_fmt() result(val) - implicit none + implicit none character(len=32) :: val val = "Jacobi smoother" end function c_jac_smoother_get_fmt function c_jac_smoother_get_id() result(val) - implicit none + implicit none integer(psb_ipk_) :: val val = mld_jac_ end function c_jac_smoother_get_id - + end module mld_c_jac_smoother diff --git a/mlprec/mld_d_jac_smoother.f90 b/mlprec/mld_d_jac_smoother.f90 index 31f6ed0d..f6b53433 100644 --- a/mlprec/mld_d_jac_smoother.f90 +++ b/mlprec/mld_d_jac_smoother.f90 @@ -1,15 +1,15 @@ -! -! +! +! ! 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 -! +! +! (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: @@ -21,7 +21,7 @@ ! 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 @@ -33,34 +33,39 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! File: mld_d_jac_smoother_mod.f90 ! ! Module: mld_d_jac_smoother_mod ! -! This module defines: +! This module defines: ! the mld_d_jac_smoother_type data structure containing the ! smoother for a Jacobi/block Jacobi smoother. ! The smoother stores in ND the block off-diagonal matrix. ! One special case is treated separately, when the solver is DIAG or L1-DIAG ! then the ND is the entire off-diagonal part of the matrix (including the ! main diagonal block), so that it becomes possible to implement -! a pure Jacobi or L1-Jacobi global solver. -! +! a pure Jacobi or L1-Jacobi global solver. +! module mld_d_jac_smoother use mld_d_base_smoother_mod type, extends(mld_d_base_smoother_type) :: mld_d_jac_smoother_type ! The local solver component is inherited from the - ! parent type. + ! parent type. ! class(mld_d_base_solver_type), allocatable :: sv - ! + ! type(psb_dspmat_type), pointer :: pa => null() type(psb_dspmat_type) :: nd integer(psb_lpk_) :: nd_nnz_tot + logical :: checkres + logical :: printres + integer(psb_ipk_) :: checkiter + integer(psb_ipk_) :: printiter + real(psb_dpk_) :: tol contains procedure, pass(sm) :: dump => mld_d_jac_smoother_dmp procedure, pass(sm) :: build => mld_d_jac_smoother_bld @@ -69,6 +74,9 @@ module mld_d_jac_smoother procedure, pass(sm) :: apply_v => mld_d_jac_smoother_apply_vect procedure, pass(sm) :: apply_a => mld_d_jac_smoother_apply procedure, pass(sm) :: free => d_jac_smoother_free + procedure, pass(sm) :: cseti => mld_d_jac_smoother_cseti + procedure, pass(sm) :: csetc => mld_d_jac_smoother_csetc + procedure, pass(sm) :: csetr => mld_d_jac_smoother_csetr procedure, pass(sm) :: descr => mld_d_jac_smoother_descr procedure, pass(sm) :: sizeof => d_jac_smoother_sizeof procedure, pass(sm) :: get_nzeros => d_jac_smoother_get_nzeros @@ -84,13 +92,13 @@ module mld_d_jac_smoother & d_jac_smoother_get_wrksize - interface - subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& + interface + subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& & sweeps,work,wv,info,init,initu) import :: psb_desc_type, mld_d_jac_smoother_type, psb_d_vect_type, psb_dpk_, & & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type,& & psb_ipk_ - + type(psb_desc_type), intent(in) :: desc_data class(mld_d_jac_smoother_type), intent(inout) :: sm type(psb_d_vect_type),intent(inout) :: x @@ -105,9 +113,9 @@ module mld_d_jac_smoother type(psb_d_vect_type),intent(inout), optional :: initu end subroutine mld_d_jac_smoother_apply_vect end interface - - interface - subroutine mld_d_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& + + interface + subroutine mld_d_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& & sweeps,work,info,init,initu) import :: psb_desc_type, mld_d_jac_smoother_type, psb_d_vect_type, psb_dpk_, & & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, & @@ -125,14 +133,14 @@ module mld_d_jac_smoother real(psb_dpk_),intent(inout), optional :: initu(:) end subroutine mld_d_jac_smoother_apply end interface - - interface + + interface subroutine mld_d_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) import :: psb_desc_type, mld_d_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 + Type(psb_desc_type), Intent(inout) :: desc_a class(mld_d_jac_smoother_type), intent(inout) :: sm integer(psb_ipk_), intent(out) :: info class(psb_d_base_sparse_mat), intent(in), optional :: amold @@ -140,8 +148,8 @@ module mld_d_jac_smoother class(psb_i_base_vect_type), intent(in), optional :: imold end subroutine mld_d_jac_smoother_bld end interface - - interface + + interface subroutine mld_d_jac_smoother_cnv(sm,info,amold,vmold,imold) import :: mld_d_jac_smoother_type, psb_dpk_, & & psb_d_base_sparse_mat, psb_d_base_vect_type,& @@ -153,13 +161,13 @@ module mld_d_jac_smoother class(psb_i_base_vect_type), intent(in), optional :: imold end subroutine mld_d_jac_smoother_cnv end interface - - interface + + interface subroutine mld_d_jac_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver) import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & & psb_dpk_, mld_d_jac_smoother_type, psb_epk_, psb_desc_type, & & psb_ipk_ - implicit none + implicit none class(mld_d_jac_smoother_type), intent(in) :: sm integer(psb_ipk_), intent(in) :: ictxt integer(psb_ipk_), intent(in) :: level @@ -168,8 +176,8 @@ module mld_d_jac_smoother logical, optional, intent(in) :: smoother, solver end subroutine mld_d_jac_smoother_dmp end interface - - interface + + interface subroutine mld_d_jac_smoother_clone(sm,smout,info) import :: mld_d_jac_smoother_type, psb_dpk_, & & mld_d_base_smoother_type, psb_ipk_ @@ -188,7 +196,46 @@ module mld_d_jac_smoother logical, intent(in), optional :: coarse end subroutine mld_d_jac_smoother_descr end interface - + + interface + subroutine mld_d_jac_smoother_cseti(sm,what,val,info,idx) + import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & + & psb_dpk_, mld_d_jac_smoother_type, psb_epk_, psb_desc_type, psb_ipk_ + implicit none + class(mld_d_jac_smoother_type), intent(inout) :: sm + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idx + end subroutine mld_d_jac_smoother_cseti + end interface + + interface + subroutine mld_d_jac_smoother_csetc(sm,what,val,info,idx) + import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & + & psb_dpk_, mld_d_jac_smoother_type, psb_epk_, psb_desc_type, psb_ipk_ + implicit none + class(mld_d_jac_smoother_type), intent(inout) :: sm + character(len=*), intent(in) :: what + character(len=*), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idx + end subroutine mld_d_jac_smoother_csetc + end interface + + interface + subroutine mld_d_jac_smoother_csetr(sm,what,val,info,idx) + import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & + & psb_dpk_, mld_d_jac_smoother_type, psb_epk_, psb_desc_type, psb_ipk_ + implicit none + class(mld_d_jac_smoother_type), intent(inout) :: sm + character(len=*), intent(in) :: what + real(psb_dpk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idx + end subroutine mld_d_jac_smoother_csetr + end interface + contains @@ -208,18 +255,18 @@ contains - if (allocated(sm%sv)) then + if (allocated(sm%sv)) then call sm%sv%free(info) if (info == psb_success_) deallocate(sm%sv,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) - goto 9999 + goto 9999 end if end if call sm%nd%free() sm%pa => null() - + call psb_erractionrestore(err_act) return @@ -229,13 +276,13 @@ contains function d_jac_smoother_sizeof(sm) result(val) - implicit none + implicit none ! Arguments class(mld_d_jac_smoother_type), intent(in) :: sm integer(psb_epk_) :: val integer(psb_ipk_) :: i - val = psb_sizeof_lp + val = psb_sizeof_lp if (allocated(sm%sv)) val = val + sm%sv%sizeof() val = val + sm%nd%sizeof() @@ -244,7 +291,7 @@ contains function d_jac_smoother_get_nzeros(sm) result(val) - implicit none + implicit none ! Arguments class(mld_d_jac_smoother_type), intent(in) :: sm integer(psb_epk_) :: val @@ -258,27 +305,27 @@ contains end function d_jac_smoother_get_nzeros function d_jac_smoother_get_wrksize(sm) result(val) - implicit none + implicit none class(mld_d_jac_smoother_type), intent(inout) :: sm integer(psb_ipk_) :: val val = 2 if (allocated(sm%sv)) val = val + sm%sv%get_wrksz() - + end function d_jac_smoother_get_wrksize - + function d_jac_smoother_get_fmt() result(val) - implicit none + implicit none character(len=32) :: val val = "Jacobi smoother" end function d_jac_smoother_get_fmt function d_jac_smoother_get_id() result(val) - implicit none + implicit none integer(psb_ipk_) :: val val = mld_jac_ end function d_jac_smoother_get_id - + end module mld_d_jac_smoother diff --git a/mlprec/mld_s_jac_smoother.f90 b/mlprec/mld_s_jac_smoother.f90 index eb2eac32..53a312ad 100644 --- a/mlprec/mld_s_jac_smoother.f90 +++ b/mlprec/mld_s_jac_smoother.f90 @@ -1,15 +1,15 @@ -! -! +! +! ! 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 -! +! +! (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: @@ -21,7 +21,7 @@ ! 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 @@ -33,34 +33,39 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! File: mld_s_jac_smoother_mod.f90 ! ! Module: mld_s_jac_smoother_mod ! -! This module defines: +! This module defines: ! the mld_s_jac_smoother_type data structure containing the ! smoother for a Jacobi/block Jacobi smoother. ! The smoother stores in ND the block off-diagonal matrix. ! One special case is treated separately, when the solver is DIAG or L1-DIAG ! then the ND is the entire off-diagonal part of the matrix (including the ! main diagonal block), so that it becomes possible to implement -! a pure Jacobi or L1-Jacobi global solver. -! +! a pure Jacobi or L1-Jacobi global solver. +! module mld_s_jac_smoother use mld_s_base_smoother_mod type, extends(mld_s_base_smoother_type) :: mld_s_jac_smoother_type ! The local solver component is inherited from the - ! parent type. + ! parent type. ! class(mld_s_base_solver_type), allocatable :: sv - ! + ! type(psb_sspmat_type), pointer :: pa => null() type(psb_sspmat_type) :: nd integer(psb_lpk_) :: nd_nnz_tot + logical :: checkres + logical :: printres + integer(psb_ipk_) :: checkiter + integer(psb_ipk_) :: printiter + real(psb_dpk_) :: tol contains procedure, pass(sm) :: dump => mld_s_jac_smoother_dmp procedure, pass(sm) :: build => mld_s_jac_smoother_bld @@ -69,6 +74,9 @@ module mld_s_jac_smoother procedure, pass(sm) :: apply_v => mld_s_jac_smoother_apply_vect procedure, pass(sm) :: apply_a => mld_s_jac_smoother_apply procedure, pass(sm) :: free => s_jac_smoother_free + procedure, pass(sm) :: cseti => mld_s_jac_smoother_cseti + procedure, pass(sm) :: csetc => mld_s_jac_smoother_csetc + procedure, pass(sm) :: csetr => mld_s_jac_smoother_csetr procedure, pass(sm) :: descr => mld_s_jac_smoother_descr procedure, pass(sm) :: sizeof => s_jac_smoother_sizeof procedure, pass(sm) :: get_nzeros => s_jac_smoother_get_nzeros @@ -84,13 +92,13 @@ module mld_s_jac_smoother & s_jac_smoother_get_wrksize - interface - subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& + interface + subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& & sweeps,work,wv,info,init,initu) import :: psb_desc_type, mld_s_jac_smoother_type, psb_s_vect_type, psb_spk_, & & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type,& & psb_ipk_ - + type(psb_desc_type), intent(in) :: desc_data class(mld_s_jac_smoother_type), intent(inout) :: sm type(psb_s_vect_type),intent(inout) :: x @@ -105,9 +113,9 @@ module mld_s_jac_smoother type(psb_s_vect_type),intent(inout), optional :: initu end subroutine mld_s_jac_smoother_apply_vect end interface - - interface - subroutine mld_s_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& + + interface + subroutine mld_s_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& & sweeps,work,info,init,initu) import :: psb_desc_type, mld_s_jac_smoother_type, psb_s_vect_type, psb_spk_, & & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, & @@ -125,14 +133,14 @@ module mld_s_jac_smoother real(psb_spk_),intent(inout), optional :: initu(:) end subroutine mld_s_jac_smoother_apply end interface - - interface + + interface subroutine mld_s_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) import :: psb_desc_type, mld_s_jac_smoother_type, psb_s_vect_type, psb_spk_, & & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type,& & psb_ipk_, psb_i_base_vect_type type(psb_sspmat_type), intent(in), target :: a - Type(psb_desc_type), Intent(inout) :: desc_a + Type(psb_desc_type), Intent(inout) :: desc_a class(mld_s_jac_smoother_type), intent(inout) :: sm integer(psb_ipk_), intent(out) :: info class(psb_s_base_sparse_mat), intent(in), optional :: amold @@ -140,8 +148,8 @@ module mld_s_jac_smoother class(psb_i_base_vect_type), intent(in), optional :: imold end subroutine mld_s_jac_smoother_bld end interface - - interface + + interface subroutine mld_s_jac_smoother_cnv(sm,info,amold,vmold,imold) import :: mld_s_jac_smoother_type, psb_spk_, & & psb_s_base_sparse_mat, psb_s_base_vect_type,& @@ -153,13 +161,13 @@ module mld_s_jac_smoother class(psb_i_base_vect_type), intent(in), optional :: imold end subroutine mld_s_jac_smoother_cnv end interface - - interface + + interface subroutine mld_s_jac_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver) import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & & psb_spk_, mld_s_jac_smoother_type, psb_epk_, psb_desc_type, & & psb_ipk_ - implicit none + implicit none class(mld_s_jac_smoother_type), intent(in) :: sm integer(psb_ipk_), intent(in) :: ictxt integer(psb_ipk_), intent(in) :: level @@ -168,8 +176,8 @@ module mld_s_jac_smoother logical, optional, intent(in) :: smoother, solver end subroutine mld_s_jac_smoother_dmp end interface - - interface + + interface subroutine mld_s_jac_smoother_clone(sm,smout,info) import :: mld_s_jac_smoother_type, psb_spk_, & & mld_s_base_smoother_type, psb_ipk_ @@ -188,7 +196,46 @@ module mld_s_jac_smoother logical, intent(in), optional :: coarse end subroutine mld_s_jac_smoother_descr end interface - + + interface + subroutine mld_s_jac_smoother_cseti(sm,what,val,info,idx) + import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & + & psb_spk_, mld_s_jac_smoother_type, psb_epk_, psb_desc_type, psb_ipk_ + implicit none + class(mld_s_jac_smoother_type), intent(inout) :: sm + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idx + end subroutine mld_s_jac_smoother_cseti + end interface + + interface + subroutine mld_s_jac_smoother_csetc(sm,what,val,info,idx) + import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & + & psb_spk_, mld_s_jac_smoother_type, psb_epk_, psb_desc_type, psb_ipk_ + implicit none + class(mld_s_jac_smoother_type), intent(inout) :: sm + character(len=*), intent(in) :: what + character(len=*), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idx + end subroutine mld_s_jac_smoother_csetc + end interface + + interface + subroutine mld_s_jac_smoother_csetr(sm,what,val,info,idx) + import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & + & psb_spk_, mld_s_jac_smoother_type, psb_epk_, psb_desc_type, psb_ipk_ + implicit none + class(mld_s_jac_smoother_type), intent(inout) :: sm + character(len=*), intent(in) :: what + real(psb_spk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idx + end subroutine mld_s_jac_smoother_csetr + end interface + contains @@ -208,18 +255,18 @@ contains - if (allocated(sm%sv)) then + if (allocated(sm%sv)) then call sm%sv%free(info) if (info == psb_success_) deallocate(sm%sv,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) - goto 9999 + goto 9999 end if end if call sm%nd%free() sm%pa => null() - + call psb_erractionrestore(err_act) return @@ -229,13 +276,13 @@ contains function s_jac_smoother_sizeof(sm) result(val) - implicit none + implicit none ! Arguments class(mld_s_jac_smoother_type), intent(in) :: sm integer(psb_epk_) :: val integer(psb_ipk_) :: i - val = psb_sizeof_lp + val = psb_sizeof_lp if (allocated(sm%sv)) val = val + sm%sv%sizeof() val = val + sm%nd%sizeof() @@ -244,7 +291,7 @@ contains function s_jac_smoother_get_nzeros(sm) result(val) - implicit none + implicit none ! Arguments class(mld_s_jac_smoother_type), intent(in) :: sm integer(psb_epk_) :: val @@ -258,27 +305,27 @@ contains end function s_jac_smoother_get_nzeros function s_jac_smoother_get_wrksize(sm) result(val) - implicit none + implicit none class(mld_s_jac_smoother_type), intent(inout) :: sm integer(psb_ipk_) :: val val = 2 if (allocated(sm%sv)) val = val + sm%sv%get_wrksz() - + end function s_jac_smoother_get_wrksize - + function s_jac_smoother_get_fmt() result(val) - implicit none + implicit none character(len=32) :: val val = "Jacobi smoother" end function s_jac_smoother_get_fmt function s_jac_smoother_get_id() result(val) - implicit none + implicit none integer(psb_ipk_) :: val val = mld_jac_ end function s_jac_smoother_get_id - + end module mld_s_jac_smoother diff --git a/mlprec/mld_z_jac_smoother.f90 b/mlprec/mld_z_jac_smoother.f90 index c1326f0d..f14f88ec 100644 --- a/mlprec/mld_z_jac_smoother.f90 +++ b/mlprec/mld_z_jac_smoother.f90 @@ -1,15 +1,15 @@ -! -! +! +! ! 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 -! +! +! (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: @@ -21,7 +21,7 @@ ! 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 @@ -33,34 +33,39 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! File: mld_z_jac_smoother_mod.f90 ! ! Module: mld_z_jac_smoother_mod ! -! This module defines: +! This module defines: ! the mld_z_jac_smoother_type data structure containing the ! smoother for a Jacobi/block Jacobi smoother. ! The smoother stores in ND the block off-diagonal matrix. ! One special case is treated separately, when the solver is DIAG or L1-DIAG ! then the ND is the entire off-diagonal part of the matrix (including the ! main diagonal block), so that it becomes possible to implement -! a pure Jacobi or L1-Jacobi global solver. -! +! a pure Jacobi or L1-Jacobi global solver. +! module mld_z_jac_smoother use mld_z_base_smoother_mod type, extends(mld_z_base_smoother_type) :: mld_z_jac_smoother_type ! The local solver component is inherited from the - ! parent type. + ! parent type. ! class(mld_z_base_solver_type), allocatable :: sv - ! + ! type(psb_zspmat_type), pointer :: pa => null() type(psb_zspmat_type) :: nd integer(psb_lpk_) :: nd_nnz_tot + logical :: checkres + logical :: printres + integer(psb_ipk_) :: checkiter + integer(psb_ipk_) :: printiter + real(psb_dpk_) :: tol contains procedure, pass(sm) :: dump => mld_z_jac_smoother_dmp procedure, pass(sm) :: build => mld_z_jac_smoother_bld @@ -69,6 +74,9 @@ module mld_z_jac_smoother procedure, pass(sm) :: apply_v => mld_z_jac_smoother_apply_vect procedure, pass(sm) :: apply_a => mld_z_jac_smoother_apply procedure, pass(sm) :: free => z_jac_smoother_free + procedure, pass(sm) :: cseti => mld_z_jac_smoother_cseti + procedure, pass(sm) :: csetc => mld_z_jac_smoother_csetc + procedure, pass(sm) :: csetr => mld_z_jac_smoother_csetr procedure, pass(sm) :: descr => mld_z_jac_smoother_descr procedure, pass(sm) :: sizeof => z_jac_smoother_sizeof procedure, pass(sm) :: get_nzeros => z_jac_smoother_get_nzeros @@ -84,13 +92,13 @@ module mld_z_jac_smoother & z_jac_smoother_get_wrksize - interface - subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& + interface + subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& & sweeps,work,wv,info,init,initu) import :: psb_desc_type, mld_z_jac_smoother_type, psb_z_vect_type, psb_dpk_, & & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type,& & psb_ipk_ - + type(psb_desc_type), intent(in) :: desc_data class(mld_z_jac_smoother_type), intent(inout) :: sm type(psb_z_vect_type),intent(inout) :: x @@ -105,9 +113,9 @@ module mld_z_jac_smoother type(psb_z_vect_type),intent(inout), optional :: initu end subroutine mld_z_jac_smoother_apply_vect end interface - - interface - subroutine mld_z_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& + + interface + subroutine mld_z_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& & sweeps,work,info,init,initu) import :: psb_desc_type, mld_z_jac_smoother_type, psb_z_vect_type, psb_dpk_, & & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, & @@ -125,14 +133,14 @@ module mld_z_jac_smoother complex(psb_dpk_),intent(inout), optional :: initu(:) end subroutine mld_z_jac_smoother_apply end interface - - interface + + interface subroutine mld_z_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) import :: psb_desc_type, mld_z_jac_smoother_type, psb_z_vect_type, psb_dpk_, & & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type,& & psb_ipk_, psb_i_base_vect_type type(psb_zspmat_type), intent(in), target :: a - Type(psb_desc_type), Intent(inout) :: desc_a + Type(psb_desc_type), Intent(inout) :: desc_a class(mld_z_jac_smoother_type), intent(inout) :: sm integer(psb_ipk_), intent(out) :: info class(psb_z_base_sparse_mat), intent(in), optional :: amold @@ -140,8 +148,8 @@ module mld_z_jac_smoother class(psb_i_base_vect_type), intent(in), optional :: imold end subroutine mld_z_jac_smoother_bld end interface - - interface + + interface subroutine mld_z_jac_smoother_cnv(sm,info,amold,vmold,imold) import :: mld_z_jac_smoother_type, psb_dpk_, & & psb_z_base_sparse_mat, psb_z_base_vect_type,& @@ -153,13 +161,13 @@ module mld_z_jac_smoother class(psb_i_base_vect_type), intent(in), optional :: imold end subroutine mld_z_jac_smoother_cnv end interface - - interface + + interface subroutine mld_z_jac_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver) import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & & psb_dpk_, mld_z_jac_smoother_type, psb_epk_, psb_desc_type, & & psb_ipk_ - implicit none + implicit none class(mld_z_jac_smoother_type), intent(in) :: sm integer(psb_ipk_), intent(in) :: ictxt integer(psb_ipk_), intent(in) :: level @@ -168,8 +176,8 @@ module mld_z_jac_smoother logical, optional, intent(in) :: smoother, solver end subroutine mld_z_jac_smoother_dmp end interface - - interface + + interface subroutine mld_z_jac_smoother_clone(sm,smout,info) import :: mld_z_jac_smoother_type, psb_dpk_, & & mld_z_base_smoother_type, psb_ipk_ @@ -188,7 +196,46 @@ module mld_z_jac_smoother logical, intent(in), optional :: coarse end subroutine mld_z_jac_smoother_descr end interface - + + interface + subroutine mld_z_jac_smoother_cseti(sm,what,val,info,idx) + import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & + & psb_dpk_, mld_z_jac_smoother_type, psb_epk_, psb_desc_type, psb_ipk_ + implicit none + class(mld_z_jac_smoother_type), intent(inout) :: sm + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idx + end subroutine mld_z_jac_smoother_cseti + end interface + + interface + subroutine mld_z_jac_smoother_csetc(sm,what,val,info,idx) + import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & + & psb_dpk_, mld_z_jac_smoother_type, psb_epk_, psb_desc_type, psb_ipk_ + implicit none + class(mld_z_jac_smoother_type), intent(inout) :: sm + character(len=*), intent(in) :: what + character(len=*), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idx + end subroutine mld_z_jac_smoother_csetc + end interface + + interface + subroutine mld_z_jac_smoother_csetr(sm,what,val,info,idx) + import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & + & psb_dpk_, mld_z_jac_smoother_type, psb_epk_, psb_desc_type, psb_ipk_ + implicit none + class(mld_z_jac_smoother_type), intent(inout) :: sm + character(len=*), intent(in) :: what + real(psb_dpk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idx + end subroutine mld_z_jac_smoother_csetr + end interface + contains @@ -208,18 +255,18 @@ contains - if (allocated(sm%sv)) then + if (allocated(sm%sv)) then call sm%sv%free(info) if (info == psb_success_) deallocate(sm%sv,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) - goto 9999 + goto 9999 end if end if call sm%nd%free() sm%pa => null() - + call psb_erractionrestore(err_act) return @@ -229,13 +276,13 @@ contains function z_jac_smoother_sizeof(sm) result(val) - implicit none + implicit none ! Arguments class(mld_z_jac_smoother_type), intent(in) :: sm integer(psb_epk_) :: val integer(psb_ipk_) :: i - val = psb_sizeof_lp + val = psb_sizeof_lp if (allocated(sm%sv)) val = val + sm%sv%sizeof() val = val + sm%nd%sizeof() @@ -244,7 +291,7 @@ contains function z_jac_smoother_get_nzeros(sm) result(val) - implicit none + implicit none ! Arguments class(mld_z_jac_smoother_type), intent(in) :: sm integer(psb_epk_) :: val @@ -258,27 +305,27 @@ contains end function z_jac_smoother_get_nzeros function z_jac_smoother_get_wrksize(sm) result(val) - implicit none + implicit none class(mld_z_jac_smoother_type), intent(inout) :: sm integer(psb_ipk_) :: val val = 2 if (allocated(sm%sv)) val = val + sm%sv%get_wrksz() - + end function z_jac_smoother_get_wrksize - + function z_jac_smoother_get_fmt() result(val) - implicit none + implicit none character(len=32) :: val val = "Jacobi smoother" end function z_jac_smoother_get_fmt function z_jac_smoother_get_id() result(val) - implicit none + implicit none integer(psb_ipk_) :: val val = mld_jac_ end function z_jac_smoother_get_id - + end module mld_z_jac_smoother From 837a5b1a1da7bb08b6ab56750dc4bc17315441fb Mon Sep 17 00:00:00 2001 From: Cirdans-Home Date: Wed, 29 Apr 2020 16:57:51 +0200 Subject: [PATCH 2/4] Added default behavior and psb_toupper function in string check --- .../mld_c_jac_smoother_apply_vect.f90 | 2 +- .../impl/smoother/mld_c_jac_smoother_bld.f90 | 2 +- .../smoother/mld_c_jac_smoother_csetc.f90 | 4 ++-- .../mld_d_jac_smoother_apply_vect.f90 | 2 +- .../impl/smoother/mld_d_jac_smoother_bld.f90 | 2 +- .../smoother/mld_d_jac_smoother_csetc.f90 | 4 ++-- .../mld_s_jac_smoother_apply_vect.f90 | 2 +- .../impl/smoother/mld_s_jac_smoother_bld.f90 | 2 +- .../smoother/mld_s_jac_smoother_csetc.f90 | 4 ++-- .../mld_z_jac_smoother_apply_vect.f90 | 2 +- .../impl/smoother/mld_z_jac_smoother_bld.f90 | 2 +- .../smoother/mld_z_jac_smoother_csetc.f90 | 4 ++-- mlprec/mld_c_jac_smoother.f90 | 24 +++++++++++++++++++ mlprec/mld_d_jac_smoother.f90 | 24 +++++++++++++++++++ mlprec/mld_s_jac_smoother.f90 | 24 +++++++++++++++++++ mlprec/mld_z_jac_smoother.f90 | 24 +++++++++++++++++++ 16 files changed, 112 insertions(+), 16 deletions(-) diff --git a/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 index 94bc1bdc..37529504 100644 --- a/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 @@ -39,7 +39,7 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& & sweeps,work,wv,info,init,initu) use psb_base_mod - use psb_base_krylov_conv_mod + use psb_base_krylov_conv_mod, only : log_conv use mld_c_jac_smoother, mld_protect_name => mld_c_jac_smoother_apply_vect implicit none type(psb_desc_type), intent(in) :: desc_data diff --git a/mlprec/impl/smoother/mld_c_jac_smoother_bld.f90 b/mlprec/impl/smoother/mld_c_jac_smoother_bld.f90 index f9615361..556d7fe2 100644 --- a/mlprec/impl/smoother/mld_c_jac_smoother_bld.f90 +++ b/mlprec/impl/smoother/mld_c_jac_smoother_bld.f90 @@ -73,7 +73,7 @@ subroutine mld_c_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) 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() diff --git a/mlprec/impl/smoother/mld_c_jac_smoother_csetc.f90 b/mlprec/impl/smoother/mld_c_jac_smoother_csetc.f90 index 7a7a3051..87072c88 100644 --- a/mlprec/impl/smoother/mld_c_jac_smoother_csetc.f90 +++ b/mlprec/impl/smoother/mld_c_jac_smoother_csetc.f90 @@ -55,13 +55,13 @@ subroutine mld_c_jac_smoother_csetc(sm,what,val,info,idx) select case(psb_toupper(what)) case('SMOOTHER_STOP') - if((trim(val) == 'T').or.(trim(val) == 'true')) then + if((psb_toupper(trim(val)) == 'T').or.(psb_toupper(trim(val)) == 'TRUE')) then sm%checkres = .true. else sm%checkres = .false. end if case('SMOOTHER_TRACE') - if((trim(val) == 'T').or.(trim(val) == 'true')) then + if((psb_toupper(trim(val)) == 'T').or.(psb_toupper(trim(val)) == 'TRUE')) then sm%printres = .true. else sm%printres = .false. diff --git a/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 index 485ab603..a50ff90d 100644 --- a/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 @@ -39,7 +39,7 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& & sweeps,work,wv,info,init,initu) use psb_base_mod - use psb_base_krylov_conv_mod + use psb_base_krylov_conv_mod, only : log_conv use mld_d_jac_smoother, mld_protect_name => mld_d_jac_smoother_apply_vect implicit none type(psb_desc_type), intent(in) :: desc_data diff --git a/mlprec/impl/smoother/mld_d_jac_smoother_bld.f90 b/mlprec/impl/smoother/mld_d_jac_smoother_bld.f90 index dc09edb3..b1d44b6a 100644 --- a/mlprec/impl/smoother/mld_d_jac_smoother_bld.f90 +++ b/mlprec/impl/smoother/mld_d_jac_smoother_bld.f90 @@ -73,7 +73,7 @@ subroutine mld_d_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) 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() diff --git a/mlprec/impl/smoother/mld_d_jac_smoother_csetc.f90 b/mlprec/impl/smoother/mld_d_jac_smoother_csetc.f90 index 17e27ffc..647a80cf 100644 --- a/mlprec/impl/smoother/mld_d_jac_smoother_csetc.f90 +++ b/mlprec/impl/smoother/mld_d_jac_smoother_csetc.f90 @@ -55,13 +55,13 @@ subroutine mld_d_jac_smoother_csetc(sm,what,val,info,idx) select case(psb_toupper(what)) case('SMOOTHER_STOP') - if((trim(val) == 'T').or.(trim(val) == 'true')) then + if((psb_toupper(trim(val)) == 'T').or.(psb_toupper(trim(val)) == 'TRUE')) then sm%checkres = .true. else sm%checkres = .false. end if case('SMOOTHER_TRACE') - if((trim(val) == 'T').or.(trim(val) == 'true')) then + if((psb_toupper(trim(val)) == 'T').or.(psb_toupper(trim(val)) == 'TRUE')) then sm%printres = .true. else sm%printres = .false. diff --git a/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 index 5fb33878..3da8b8b3 100644 --- a/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 @@ -39,7 +39,7 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& & sweeps,work,wv,info,init,initu) use psb_base_mod - use psb_base_krylov_conv_mod + use psb_base_krylov_conv_mod, only : log_conv use mld_s_jac_smoother, mld_protect_name => mld_s_jac_smoother_apply_vect implicit none type(psb_desc_type), intent(in) :: desc_data diff --git a/mlprec/impl/smoother/mld_s_jac_smoother_bld.f90 b/mlprec/impl/smoother/mld_s_jac_smoother_bld.f90 index 958c7f28..c37ca90d 100644 --- a/mlprec/impl/smoother/mld_s_jac_smoother_bld.f90 +++ b/mlprec/impl/smoother/mld_s_jac_smoother_bld.f90 @@ -73,7 +73,7 @@ subroutine mld_s_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) 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() diff --git a/mlprec/impl/smoother/mld_s_jac_smoother_csetc.f90 b/mlprec/impl/smoother/mld_s_jac_smoother_csetc.f90 index 03609c97..154e4cc9 100644 --- a/mlprec/impl/smoother/mld_s_jac_smoother_csetc.f90 +++ b/mlprec/impl/smoother/mld_s_jac_smoother_csetc.f90 @@ -55,13 +55,13 @@ subroutine mld_s_jac_smoother_csetc(sm,what,val,info,idx) select case(psb_toupper(what)) case('SMOOTHER_STOP') - if((trim(val) == 'T').or.(trim(val) == 'true')) then + if((psb_toupper(trim(val)) == 'T').or.(psb_toupper(trim(val)) == 'TRUE')) then sm%checkres = .true. else sm%checkres = .false. end if case('SMOOTHER_TRACE') - if((trim(val) == 'T').or.(trim(val) == 'true')) then + if((psb_toupper(trim(val)) == 'T').or.(psb_toupper(trim(val)) == 'TRUE')) then sm%printres = .true. else sm%printres = .false. diff --git a/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 index 72a13101..68d9eb7d 100644 --- a/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 @@ -39,7 +39,7 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& & sweeps,work,wv,info,init,initu) use psb_base_mod - use psb_base_krylov_conv_mod + use psb_base_krylov_conv_mod, only : log_conv use mld_z_jac_smoother, mld_protect_name => mld_z_jac_smoother_apply_vect implicit none type(psb_desc_type), intent(in) :: desc_data diff --git a/mlprec/impl/smoother/mld_z_jac_smoother_bld.f90 b/mlprec/impl/smoother/mld_z_jac_smoother_bld.f90 index 46d524c9..b723201f 100644 --- a/mlprec/impl/smoother/mld_z_jac_smoother_bld.f90 +++ b/mlprec/impl/smoother/mld_z_jac_smoother_bld.f90 @@ -73,7 +73,7 @@ subroutine mld_z_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) 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() diff --git a/mlprec/impl/smoother/mld_z_jac_smoother_csetc.f90 b/mlprec/impl/smoother/mld_z_jac_smoother_csetc.f90 index ed8a3d38..1867df87 100644 --- a/mlprec/impl/smoother/mld_z_jac_smoother_csetc.f90 +++ b/mlprec/impl/smoother/mld_z_jac_smoother_csetc.f90 @@ -55,13 +55,13 @@ subroutine mld_z_jac_smoother_csetc(sm,what,val,info,idx) select case(psb_toupper(what)) case('SMOOTHER_STOP') - if((trim(val) == 'T').or.(trim(val) == 'true')) then + if((psb_toupper(trim(val)) == 'T').or.(psb_toupper(trim(val)) == 'TRUE')) then sm%checkres = .true. else sm%checkres = .false. end if case('SMOOTHER_TRACE') - if((trim(val) == 'T').or.(trim(val) == 'true')) then + if((psb_toupper(trim(val)) == 'T').or.(psb_toupper(trim(val)) == 'TRUE')) then sm%printres = .true. else sm%printres = .false. diff --git a/mlprec/mld_c_jac_smoother.f90 b/mlprec/mld_c_jac_smoother.f90 index d43eabf9..bf0cc250 100644 --- a/mlprec/mld_c_jac_smoother.f90 +++ b/mlprec/mld_c_jac_smoother.f90 @@ -79,6 +79,7 @@ module mld_c_jac_smoother procedure, pass(sm) :: csetr => mld_c_jac_smoother_csetr procedure, pass(sm) :: descr => mld_c_jac_smoother_descr procedure, pass(sm) :: sizeof => c_jac_smoother_sizeof + procedure, pass(sm) :: default => c_jac_smoother_default procedure, pass(sm) :: get_nzeros => c_jac_smoother_get_nzeros procedure, pass(sm) :: get_wrksz => c_jac_smoother_get_wrksize procedure, nopass :: get_fmt => c_jac_smoother_get_fmt @@ -289,6 +290,29 @@ contains return end function c_jac_smoother_sizeof + subroutine c_jac_smoother_default(sm) + + Implicit None + + ! Arguments + class(mld_c_jac_smoother_type), intent(inout) :: sm + + ! + ! Default: BJAC with no residual check + ! + sm%checkres = .false. + sm%printres = .false. + sm%checkiter = -1 + sm%printiter = -1 + sm%tol = 0 + + if (allocated(sm%sv)) then + call sm%sv%default() + end if + + return + end subroutine c_jac_smoother_default + function c_jac_smoother_get_nzeros(sm) result(val) implicit none diff --git a/mlprec/mld_d_jac_smoother.f90 b/mlprec/mld_d_jac_smoother.f90 index f6b53433..cf7f9821 100644 --- a/mlprec/mld_d_jac_smoother.f90 +++ b/mlprec/mld_d_jac_smoother.f90 @@ -79,6 +79,7 @@ module mld_d_jac_smoother procedure, pass(sm) :: csetr => mld_d_jac_smoother_csetr procedure, pass(sm) :: descr => mld_d_jac_smoother_descr procedure, pass(sm) :: sizeof => d_jac_smoother_sizeof + procedure, pass(sm) :: default => d_jac_smoother_default procedure, pass(sm) :: get_nzeros => d_jac_smoother_get_nzeros procedure, pass(sm) :: get_wrksz => d_jac_smoother_get_wrksize procedure, nopass :: get_fmt => d_jac_smoother_get_fmt @@ -289,6 +290,29 @@ contains return end function d_jac_smoother_sizeof + subroutine d_jac_smoother_default(sm) + + Implicit None + + ! Arguments + class(mld_d_jac_smoother_type), intent(inout) :: sm + + ! + ! Default: BJAC with no residual check + ! + sm%checkres = .false. + sm%printres = .false. + sm%checkiter = -1 + sm%printiter = -1 + sm%tol = 0 + + if (allocated(sm%sv)) then + call sm%sv%default() + end if + + return + end subroutine d_jac_smoother_default + function d_jac_smoother_get_nzeros(sm) result(val) implicit none diff --git a/mlprec/mld_s_jac_smoother.f90 b/mlprec/mld_s_jac_smoother.f90 index 53a312ad..98b44700 100644 --- a/mlprec/mld_s_jac_smoother.f90 +++ b/mlprec/mld_s_jac_smoother.f90 @@ -79,6 +79,7 @@ module mld_s_jac_smoother procedure, pass(sm) :: csetr => mld_s_jac_smoother_csetr procedure, pass(sm) :: descr => mld_s_jac_smoother_descr procedure, pass(sm) :: sizeof => s_jac_smoother_sizeof + procedure, pass(sm) :: default => s_jac_smoother_default procedure, pass(sm) :: get_nzeros => s_jac_smoother_get_nzeros procedure, pass(sm) :: get_wrksz => s_jac_smoother_get_wrksize procedure, nopass :: get_fmt => s_jac_smoother_get_fmt @@ -289,6 +290,29 @@ contains return end function s_jac_smoother_sizeof + subroutine s_jac_smoother_default(sm) + + Implicit None + + ! Arguments + class(mld_s_jac_smoother_type), intent(inout) :: sm + + ! + ! Default: BJAC with no residual check + ! + sm%checkres = .false. + sm%printres = .false. + sm%checkiter = -1 + sm%printiter = -1 + sm%tol = 0 + + if (allocated(sm%sv)) then + call sm%sv%default() + end if + + return + end subroutine s_jac_smoother_default + function s_jac_smoother_get_nzeros(sm) result(val) implicit none diff --git a/mlprec/mld_z_jac_smoother.f90 b/mlprec/mld_z_jac_smoother.f90 index f14f88ec..52b4fa29 100644 --- a/mlprec/mld_z_jac_smoother.f90 +++ b/mlprec/mld_z_jac_smoother.f90 @@ -79,6 +79,7 @@ module mld_z_jac_smoother procedure, pass(sm) :: csetr => mld_z_jac_smoother_csetr procedure, pass(sm) :: descr => mld_z_jac_smoother_descr procedure, pass(sm) :: sizeof => z_jac_smoother_sizeof + procedure, pass(sm) :: default => z_jac_smoother_default procedure, pass(sm) :: get_nzeros => z_jac_smoother_get_nzeros procedure, pass(sm) :: get_wrksz => z_jac_smoother_get_wrksize procedure, nopass :: get_fmt => z_jac_smoother_get_fmt @@ -289,6 +290,29 @@ contains return end function z_jac_smoother_sizeof + subroutine z_jac_smoother_default(sm) + + Implicit None + + ! Arguments + class(mld_z_jac_smoother_type), intent(inout) :: sm + + ! + ! Default: BJAC with no residual check + ! + sm%checkres = .false. + sm%printres = .false. + sm%checkiter = -1 + sm%printiter = -1 + sm%tol = 0 + + if (allocated(sm%sv)) then + call sm%sv%default() + end if + + return + end subroutine z_jac_smoother_default + function z_jac_smoother_get_nzeros(sm) result(val) implicit none From 78e7f29371962deda9a28374532c5eb152494342 Mon Sep 17 00:00:00 2001 From: Cirdans-Home Date: Thu, 30 Apr 2020 12:08:24 +0200 Subject: [PATCH 3/4] Corrected print routine to avoid double print of last residual --- mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 | 10 ++++++---- mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 | 10 ++++++---- mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 | 10 ++++++---- mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 | 10 ++++++---- 4 files changed, 24 insertions(+), 16 deletions(-) diff --git a/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 index 37529504..22bc1cc3 100644 --- a/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 @@ -178,8 +178,9 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if( sm%printres ) then call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) end if - if (res/resdenum < sm%tol) then - if( sm%printres ) call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) + if ( res < sm%tol*resdenum ) then + if( (sm%printres).and.(mod(sm%printiter,sm%checkiter)/=0) ) & + & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) exit end if end if @@ -269,8 +270,9 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if( sm%printres ) then call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) end if - if (res/resdenum < sm%tol) then - if( sm%printres ) call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) + if (res < sm%tol*resdenum ) then + if( (sm%printres).and.( mod(sm%printiter,sm%checkiter) /=0 ) ) & + & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) exit end if end if diff --git a/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 index a50ff90d..e9740f40 100644 --- a/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 @@ -178,8 +178,9 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if( sm%printres ) then call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) end if - if (res/resdenum < sm%tol) then - if( sm%printres ) call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) + if ( res < sm%tol*resdenum ) then + if( (sm%printres).and.(mod(sm%printiter,sm%checkiter)/=0) ) & + & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) exit end if end if @@ -269,8 +270,9 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if( sm%printres ) then call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) end if - if (res/resdenum < sm%tol) then - if( sm%printres ) call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) + if (res < sm%tol*resdenum ) then + if( (sm%printres).and.( mod(sm%printiter,sm%checkiter) /=0 ) ) & + & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) exit end if end if diff --git a/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 index 3da8b8b3..3d864606 100644 --- a/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 @@ -178,8 +178,9 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if( sm%printres ) then call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) end if - if (res/resdenum < sm%tol) then - if( sm%printres ) call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) + if ( res < sm%tol*resdenum ) then + if( (sm%printres).and.(mod(sm%printiter,sm%checkiter)/=0) ) & + & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) exit end if end if @@ -269,8 +270,9 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if( sm%printres ) then call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) end if - if (res/resdenum < sm%tol) then - if( sm%printres ) call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) + if (res < sm%tol*resdenum ) then + if( (sm%printres).and.( mod(sm%printiter,sm%checkiter) /=0 ) ) & + & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) exit end if end if diff --git a/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 index 68d9eb7d..cd957f41 100644 --- a/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 @@ -178,8 +178,9 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if( sm%printres ) then call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) end if - if (res/resdenum < sm%tol) then - if( sm%printres ) call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) + if ( res < sm%tol*resdenum ) then + if( (sm%printres).and.(mod(sm%printiter,sm%checkiter)/=0) ) & + & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) exit end if end if @@ -269,8 +270,9 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if( sm%printres ) then call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) end if - if (res/resdenum < sm%tol) then - if( sm%printres ) call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) + if (res < sm%tol*resdenum ) then + if( (sm%printres).and.( mod(sm%printiter,sm%checkiter) /=0 ) ) & + & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) exit end if end if From e0491f1f178b6eec52b9ff4f20ff880cbfebf180 Mon Sep 17 00:00:00 2001 From: Cirdans-Home Date: Thu, 30 Apr 2020 19:10:01 +0200 Subject: [PATCH 4/4] Changed selection criterion between Jacobi/BJAC application --- mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 | 8 +++++--- mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 | 8 +++++--- mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 | 8 +++++--- mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 | 8 +++++--- 4 files changed, 20 insertions(+), 12 deletions(-) diff --git a/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 index 22bc1cc3..2b55f98d 100644 --- a/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 @@ -39,6 +39,7 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& & sweeps,work,wv,info,init,initu) use psb_base_mod + use mld_c_diag_solver use psb_base_krylov_conv_mod, only : log_conv use mld_c_jac_smoother, mld_protect_name => mld_c_jac_smoother_apply_vect implicit none @@ -124,7 +125,8 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& endif else if (sweeps >= 0) then - if (associated(sm%pa)) then + select type (smsv => sm%sv) + class is (mld_c_diag_solver_type) ! ! This means we are dealing with a pure Jacobi smoother/solver. ! @@ -200,7 +202,7 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& end associate - else + class default ! ! ! Apply multiple sweeps of a block-Jacobi solver @@ -289,7 +291,7 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& end if end associate - end if + end select else diff --git a/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 index e9740f40..2e95454d 100644 --- a/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 @@ -39,6 +39,7 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& & sweeps,work,wv,info,init,initu) use psb_base_mod + use mld_d_diag_solver use psb_base_krylov_conv_mod, only : log_conv use mld_d_jac_smoother, mld_protect_name => mld_d_jac_smoother_apply_vect implicit none @@ -124,7 +125,8 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& endif else if (sweeps >= 0) then - if (associated(sm%pa)) then + select type (smsv => sm%sv) + class is (mld_d_diag_solver_type) ! ! This means we are dealing with a pure Jacobi smoother/solver. ! @@ -200,7 +202,7 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& end associate - else + class default ! ! ! Apply multiple sweeps of a block-Jacobi solver @@ -289,7 +291,7 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& end if end associate - end if + end select else diff --git a/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 index 3d864606..5ed28511 100644 --- a/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 @@ -39,6 +39,7 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& & sweeps,work,wv,info,init,initu) use psb_base_mod + use mld_s_diag_solver use psb_base_krylov_conv_mod, only : log_conv use mld_s_jac_smoother, mld_protect_name => mld_s_jac_smoother_apply_vect implicit none @@ -124,7 +125,8 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& endif else if (sweeps >= 0) then - if (associated(sm%pa)) then + select type (smsv => sm%sv) + class is (mld_s_diag_solver_type) ! ! This means we are dealing with a pure Jacobi smoother/solver. ! @@ -200,7 +202,7 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& end associate - else + class default ! ! ! Apply multiple sweeps of a block-Jacobi solver @@ -289,7 +291,7 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& end if end associate - end if + end select else diff --git a/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 index cd957f41..2da1aa53 100644 --- a/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 @@ -39,6 +39,7 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& & sweeps,work,wv,info,init,initu) use psb_base_mod + use mld_z_diag_solver use psb_base_krylov_conv_mod, only : log_conv use mld_z_jac_smoother, mld_protect_name => mld_z_jac_smoother_apply_vect implicit none @@ -124,7 +125,8 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& endif else if (sweeps >= 0) then - if (associated(sm%pa)) then + select type (smsv => sm%sv) + class is (mld_z_diag_solver_type) ! ! This means we are dealing with a pure Jacobi smoother/solver. ! @@ -200,7 +202,7 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& end associate - else + class default ! ! ! Apply multiple sweeps of a block-Jacobi solver @@ -289,7 +291,7 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& end if end associate - end if + end select else