diff --git a/amgprec/Makefile b/amgprec/Makefile index 64da5e8a..81e6ce8c 100644 --- a/amgprec/Makefile +++ b/amgprec/Makefile @@ -11,7 +11,7 @@ DMODOBJS=amg_d_prec_type.o \ amg_d_inner_mod.o amg_d_ilu_solver.o amg_d_diag_solver.o amg_d_jac_smoother.o amg_d_as_smoother.o \ amg_d_umf_solver.o amg_d_slu_solver.o amg_d_sludist_solver.o amg_d_id_solver.o\ amg_d_base_solver_mod.o amg_d_base_smoother_mod.o amg_d_onelev_mod.o \ - amg_d_gs_solver.o amg_d_mumps_solver.o \ + amg_d_gs_solver.o amg_d_mumps_solver.o amg_d_jac_solver.o \ amg_d_base_aggregator_mod.o \ amg_d_dec_aggregator_mod.o amg_d_symdec_aggregator_mod.o \ amg_d_ainv_solver.o amg_d_base_ainv_mod.o \ @@ -22,7 +22,7 @@ SMODOBJS=amg_s_prec_type.o amg_s_ilu_fact_mod.o \ amg_s_inner_mod.o amg_s_ilu_solver.o amg_s_diag_solver.o amg_s_jac_smoother.o amg_s_as_smoother.o \ amg_s_slu_solver.o amg_s_id_solver.o\ amg_s_base_solver_mod.o amg_s_base_smoother_mod.o amg_s_onelev_mod.o \ - amg_s_gs_solver.o amg_s_mumps_solver.o \ + amg_s_gs_solver.o amg_s_mumps_solver.o amg_s_jac_solver.o \ amg_s_base_aggregator_mod.o \ amg_s_dec_aggregator_mod.o amg_s_symdec_aggregator_mod.o \ amg_s_ainv_solver.o amg_s_base_ainv_mod.o \ @@ -33,7 +33,7 @@ ZMODOBJS=amg_z_prec_type.o amg_z_ilu_fact_mod.o \ amg_z_inner_mod.o amg_z_ilu_solver.o amg_z_diag_solver.o amg_z_jac_smoother.o amg_z_as_smoother.o \ amg_z_umf_solver.o amg_z_slu_solver.o amg_z_sludist_solver.o amg_z_id_solver.o\ amg_z_base_solver_mod.o amg_z_base_smoother_mod.o amg_z_onelev_mod.o \ - amg_z_gs_solver.o amg_z_mumps_solver.o \ + amg_z_gs_solver.o amg_z_mumps_solver.o amg_z_jac_solver.o \ amg_z_base_aggregator_mod.o \ amg_z_dec_aggregator_mod.o amg_z_symdec_aggregator_mod.o \ amg_z_ainv_solver.o amg_z_base_ainv_mod.o \ @@ -43,7 +43,7 @@ CMODOBJS=amg_c_prec_type.o amg_c_ilu_fact_mod.o \ amg_c_inner_mod.o amg_c_ilu_solver.o amg_c_diag_solver.o amg_c_jac_smoother.o amg_c_as_smoother.o \ amg_c_slu_solver.o amg_c_id_solver.o\ amg_c_base_solver_mod.o amg_c_base_smoother_mod.o amg_c_onelev_mod.o \ - amg_c_gs_solver.o amg_c_mumps_solver.o \ + amg_c_gs_solver.o amg_c_mumps_solver.o amg_c_jac_solver.o \ amg_c_base_aggregator_mod.o \ amg_c_dec_aggregator_mod.o amg_c_symdec_aggregator_mod.o \ amg_c_ainv_solver.o amg_c_base_ainv_mod.o \ @@ -155,7 +155,7 @@ amg_z_base_ainv_mod.o: amg_z_base_solver_mod.o amg_base_ainv_mod.o amg_s_base_solver_mod.o amg_d_base_solver_mod.o amg_c_base_solver_mod.o amg_z_base_solver_mod.o: amg_base_prec_type.o amg_d_mumps_solver.o amg_d_gs_solver.o amg_d_id_solver.o amg_d_sludist_solver.o amg_d_slu_solver.o \ -amg_d_umf_solver.o amg_d_diag_solver.o amg_d_ilu_solver.o: amg_d_base_solver_mod.o amg_d_prec_type.o +amg_d_umf_solver.o amg_d_diag_solver.o amg_d_ilu_solver.o amg_d_jac_solver.o: amg_d_base_solver_mod.o amg_d_prec_type.o #amg_d_ilu_fact_mod.o: amg_base_prec_type.o amg_d_base_solver_mod.o #amg_d_ilu_solver.o amg_d_iluk_fact.o: amg_d_ilu_fact_mod.o @@ -166,7 +166,7 @@ amg_dprecinit.o amg_dprecset.o: amg_d_diag_solver.o amg_d_ilu_solver.o \ amg_d_id_solver.o amg_d_slu_solver.o amg_d_sludist_solver.o amg_s_mumps_solver.o amg_s_gs_solver.o amg_s_id_solver.o amg_s_slu_solver.o \ -amg_s_diag_solver.o amg_s_ilu_solver.o: amg_s_base_solver_mod.o amg_s_prec_type.o +amg_s_diag_solver.o amg_s_ilu_solver.o amg_s_jac_solver.o: amg_s_base_solver_mod.o amg_s_prec_type.o amg_s_ilu_fact_mod.o: amg_base_prec_type.o amg_s_base_solver_mod.o amg_s_ilu_solver.o amg_s_iluk_fact.o: amg_s_ilu_fact_mod.o amg_s_as_smoother.o amg_s_jac_smoother.o: amg_s_base_smoother_mod.o @@ -176,7 +176,7 @@ amg_sprecinit.o amg_sprecset.o: amg_s_diag_solver.o amg_s_ilu_solver.o \ amg_s_id_solver.o amg_s_slu_solver.o amg_z_mumps_solver.o amg_z_gs_solver.o amg_z_id_solver.o amg_z_sludist_solver.o amg_z_slu_solver.o \ -amg_z_umf_solver.o amg_z_diag_solver.o amg_z_ilu_solver.o: amg_z_base_solver_mod.o amg_z_prec_type.o +amg_z_umf_solver.o amg_z_diag_solver.o amg_z_ilu_solver.o amg_z_jac_solver.o: amg_z_base_solver_mod.o amg_z_prec_type.o amg_z_ilu_fact_mod.o: amg_base_prec_type.o amg_z_base_solver_mod.o amg_z_ilu_solver.o amg_z_iluk_fact.o: amg_z_ilu_fact_mod.o amg_z_as_smoother.o amg_z_jac_smoother.o: amg_z_base_smoother_mod.o @@ -186,7 +186,7 @@ amg_zprecinit.o amg_zprecset.o: amg_z_diag_solver.o amg_z_ilu_solver.o \ amg_z_id_solver.o amg_z_slu_solver.o amg_z_sludist_solver.o amg_c_mumps_solver.o amg_c_gs_solver.o amg_c_id_solver.o amg_c_sludist_solver.o amg_c_slu_solver.o \ -amg_c_diag_solver.o amg_c_ilu_solver.o: amg_c_base_solver_mod.o amg_c_prec_type.o +amg_c_diag_solver.o amg_c_ilu_solver.o amg_c_jac_solver.o: amg_c_base_solver_mod.o amg_c_prec_type.o amg_c_ilu_fact_mod.o: amg_base_prec_type.o amg_c_base_solver_mod.o amg_c_ilu_solver.o amg_c_iluk_fact.o: amg_c_ilu_fact_mod.o amg_c_as_smoother.o amg_c_jac_smoother.o: amg_c_base_smoother_mod.o diff --git a/amgprec/amg_c_jac_solver.f90 b/amgprec/amg_c_jac_solver.f90 new file mode 100644 index 00000000..55335f1b --- /dev/null +++ b/amgprec/amg_c_jac_solver.f90 @@ -0,0 +1,582 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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. +! +! +! +! +! File: amg_c_jac_solver_mod.f90 +! +! Module: amg_c_jac_solver_mod +! +! This module defines: +! - the amg_c_jac_solver_type data structure containing the ingredients +! for a local Jacobi iteration. The iterations are local to a process +! (they operate on the block diagonal). +! +! +module amg_c_jac_solver + + use amg_c_base_solver_mod + + type, extends(amg_c_base_solver_type) :: amg_c_jac_solver_type + type(psb_cspmat_type) :: a + type(psb_c_vect_type), allocatable :: dv + complex(psb_spk_), allocatable :: d(:) + integer(psb_ipk_) :: sweeps + real(psb_spk_) :: eps + contains + procedure, pass(sv) :: dump => amg_c_jac_solver_dmp + procedure, pass(sv) :: check => c_jac_solver_check + procedure, pass(sv) :: clone => amg_c_jac_solver_clone + procedure, pass(sv) :: clone_settings => amg_c_jac_solver_clone_settings + procedure, pass(sv) :: clear_data => amg_c_jac_solver_clear_data + procedure, pass(sv) :: build => amg_c_jac_solver_bld + procedure, pass(sv) :: cnv => amg_c_jac_solver_cnv + procedure, pass(sv) :: apply_v => amg_c_jac_solver_apply_vect + procedure, pass(sv) :: apply_a => amg_c_jac_solver_apply + procedure, pass(sv) :: free => c_jac_solver_free + procedure, pass(sv) :: cseti => c_jac_solver_cseti + procedure, pass(sv) :: csetc => c_jac_solver_csetc + procedure, pass(sv) :: csetr => c_jac_solver_csetr + procedure, pass(sv) :: descr => c_jac_solver_descr + procedure, pass(sv) :: default => c_jac_solver_default + procedure, pass(sv) :: sizeof => c_jac_solver_sizeof + procedure, pass(sv) :: get_nzeros => c_jac_solver_get_nzeros + procedure, nopass :: get_wrksz => c_jac_solver_get_wrksize + procedure, nopass :: get_fmt => c_jac_solver_get_fmt + procedure, nopass :: get_id => c_jac_solver_get_id + procedure, nopass :: is_iterative => c_jac_solver_is_iterative + end type amg_c_jac_solver_type + + type, extends(amg_c_jac_solver_type) :: amg_c_l1_jac_solver_type + contains + procedure, pass(sv) :: build => amg_c_l1_jac_solver_bld + procedure, pass(sv) :: descr => c_l1_jac_solver_descr + procedure, nopass :: get_fmt => c_l1_jac_solver_get_fmt + procedure, nopass :: get_id => c_l1_jac_solver_get_id + end type amg_c_l1_jac_solver_type + + + private :: c_jac_solver_bld, c_jac_solver_apply, & + & c_jac_solver_free, & + & c_jac_solver_descr, c_jac_solver_sizeof, & + & c_jac_solver_default, c_jac_solver_dmp, & + & c_jac_solver_apply_vect, c_jac_solver_get_nzeros, & + & c_jac_solver_get_fmt, c_jac_solver_check,& + & c_jac_solver_is_iterative, & + & c_jac_solver_get_id, c_jac_solver_get_wrksize + + interface + subroutine amg_c_jac_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,wv,info,init,initu) + import :: psb_desc_type, amg_c_jac_solver_type, psb_c_vect_type, psb_spk_, & + & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_ + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(amg_c_jac_solver_type), intent(inout) :: sv + type(psb_c_vect_type),intent(inout) :: x + type(psb_c_vect_type),intent(inout) :: y + complex(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + complex(psb_spk_),target, intent(inout) :: work(:) + type(psb_c_vect_type),intent(inout) :: wv(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_c_vect_type),intent(inout), optional :: initu + end subroutine amg_c_jac_solver_apply_vect + end interface + + interface + subroutine amg_c_jac_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info,init,initu) + import :: psb_desc_type, amg_c_jac_solver_type, psb_c_vect_type, psb_spk_, & + & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_ + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(amg_c_jac_solver_type), intent(inout) :: sv + complex(psb_spk_),intent(inout) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + complex(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + complex(psb_spk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_spk_),intent(inout), optional :: initu(:) + end subroutine amg_c_jac_solver_apply + end interface + + interface + subroutine amg_c_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) + import :: psb_desc_type, amg_c_jac_solver_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 + implicit none + type(psb_cspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(amg_c_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + type(psb_cspmat_type), intent(in), target, optional :: b + class(psb_c_base_sparse_mat), intent(in), optional :: amold + class(psb_c_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + end subroutine amg_c_jac_solver_bld + end interface + + interface + subroutine amg_c_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) + import :: psb_desc_type, amg_c_l1_jac_solver_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 + implicit none + type(psb_cspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(amg_c_l1_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + type(psb_cspmat_type), intent(in), target, optional :: b + class(psb_c_base_sparse_mat), intent(in), optional :: amold + class(psb_c_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + end subroutine amg_c_l1_jac_solver_bld + end interface + + interface + subroutine amg_c_jac_solver_cnv(sv,info,amold,vmold,imold) + import :: amg_c_jac_solver_type, psb_spk_, & + & psb_c_base_sparse_mat, psb_c_base_vect_type,& + & psb_ipk_, psb_i_base_vect_type + implicit none + class(amg_c_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_sparse_mat), intent(in), optional :: amold + class(psb_c_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + end subroutine amg_c_jac_solver_cnv + end interface + + interface + subroutine amg_c_jac_solver_dmp(sv,desc,level,info,prefix,head,solver,global_num) + import :: psb_desc_type, amg_c_jac_solver_type, psb_c_vect_type, psb_spk_, & + & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, & + & psb_ipk_ + implicit none + class(amg_c_jac_solver_type), intent(in) :: sv + type(psb_desc_type), intent(in) :: desc + integer(psb_ipk_), intent(in) :: level + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: solver, global_num + end subroutine amg_c_jac_solver_dmp + end interface + + interface + subroutine amg_c_jac_solver_clone(sv,svout,info) + import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, & + & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, & + & amg_c_base_solver_type, amg_c_jac_solver_type, psb_ipk_ + Implicit None + + ! Arguments + class(amg_c_jac_solver_type), intent(inout) :: sv + class(amg_c_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info + end subroutine amg_c_jac_solver_clone + end interface + +!!$ interface +!!$ subroutine amg_c_l1_jac_solver_clone(sv,svout,info) +!!$ import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, & +!!$ & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, & +!!$ & amg_c_base_solver_type, amg_c_l1_jac_solver_type, psb_ipk_ +!!$ Implicit None +!!$ +!!$ ! Arguments +!!$ class(amg_c_l1_jac_solver_type), intent(inout) :: sv +!!$ class(amg_c_base_solver_type), allocatable, intent(inout) :: svout +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine amg_c_l1_jac_solver_clone +!!$ end interface + + interface + subroutine amg_c_jac_solver_clone_settings(sv,svout,info) + import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, & + & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, & + & amg_c_base_solver_type, amg_c_jac_solver_type, psb_ipk_ + Implicit None + + ! Arguments + class(amg_c_jac_solver_type), intent(inout) :: sv + class(amg_c_base_solver_type), intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info + end subroutine amg_c_jac_solver_clone_settings + end interface + + interface + subroutine amg_c_jac_solver_clear_data(sv,info) + import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, & + & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, & + & amg_c_jac_solver_type, psb_ipk_ + Implicit None + + ! Arguments + class(amg_c_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + end subroutine amg_c_jac_solver_clear_data + end interface + +contains + + subroutine c_jac_solver_default(sv) + + Implicit None + + ! Arguments + class(amg_c_jac_solver_type), intent(inout) :: sv + + sv%sweeps = ione + sv%eps = dzero + + return + end subroutine c_jac_solver_default + + subroutine c_jac_solver_check(sv,info) + + Implicit None + + ! Arguments + class(amg_c_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='c_jac_solver_check' + + call psb_erractionsave(err_act) + info = psb_success_ + + call amg_check_def(sv%sweeps,& + & 'Jacobi sweeps',ione,is_int_positive) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine c_jac_solver_check + + subroutine c_jac_solver_cseti(sv,what,val,info,idx) + + Implicit None + + ! Arguments + class(amg_c_jac_solver_type), intent(inout) :: sv + 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_solver_cseti' + + info = psb_success_ + call psb_erractionsave(err_act) + + select case(psb_toupper(what)) + case('SOLVER_SWEEPS') + sv%sweeps = val + case default + call sv%amg_c_base_solver_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 c_jac_solver_cseti + + subroutine c_jac_solver_csetc(sv,what,val,info,idx) + + Implicit None + + ! Arguments + class(amg_c_jac_solver_type), intent(inout) :: sv + 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_solver_csetc' + + info = psb_success_ + call psb_erractionsave(err_act) + + + call sv%amg_c_base_solver_type%set(what,val,info,idx=idx) + + 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 c_jac_solver_csetc + + subroutine c_jac_solver_csetr(sv,what,val,info,idx) + + Implicit None + + ! Arguments + class(amg_c_jac_solver_type), intent(inout) :: sv + 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_solver_csetr' + + call psb_erractionsave(err_act) + info = psb_success_ + + select case(psb_toupper(what)) + case('SOLVER_EPS') + sv%eps = val + case default + call sv%amg_c_base_solver_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 c_jac_solver_csetr + + subroutine c_jac_solver_free(sv,info) + + Implicit None + + ! Arguments + class(amg_c_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='c_jac_solver_free' + + call psb_erractionsave(err_act) + info = psb_success_ + + call sv%a%free() + call sv%dv%free(info) + if (allocated(sv%d)) deallocate(sv%d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + end subroutine c_jac_solver_free + + subroutine c_jac_solver_descr(sv,info,iout,coarse,prefix) + + Implicit None + + ! Arguments + class(amg_c_jac_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + logical, intent(in), optional :: coarse + character(len=*), intent(in), optional :: prefix + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='amg_c_jac_solver_descr' + integer(psb_ipk_) :: iout_ + character(1024) :: prefix_ + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(iout)) then + iout_ = iout + else + iout_ = psb_out_unit + endif + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + if (sv%eps<=dzero) then + write(iout_,*) trim(prefix_), ' Jacobi iterative solver with ',& + & sv%sweeps,' sweeps' + else + write(iout_,*) trim(prefix_), ' Jacobi iterative solver with tolerance',& + & sv%eps,' and maxit', sv%sweeps + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + end subroutine c_jac_solver_descr + + function c_jac_solver_get_nzeros(sv) result(val) + + implicit none + ! Arguments + class(amg_c_jac_solver_type), intent(in) :: sv + integer(psb_epk_) :: val + integer(psb_ipk_) :: i + + val = 0 + val = val + sv%a%get_nzeros() + val = val + sv%dv%get_nrows() + + return + end function c_jac_solver_get_nzeros + + function c_jac_solver_sizeof(sv) result(val) + + implicit none + ! Arguments + class(amg_c_jac_solver_type), intent(in) :: sv + integer(psb_epk_) :: val + integer(psb_ipk_) :: i + + val = psb_sizeof_ip + val = val + sv%a%sizeof() + val = val + sv%dv%sizeof() + + return + end function c_jac_solver_sizeof + + function c_jac_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Jacobi solver" + end function c_jac_solver_get_fmt + + function c_jac_solver_get_id() result(val) + implicit none + integer(psb_ipk_) :: val + + val = amg_jac_ + end function c_jac_solver_get_id + + ! + ! If this is true, then the solver needs a starting + ! guess. Currently only handled in JAC smoother. + ! + function c_jac_solver_is_iterative() result(val) + implicit none + logical :: val + + val = .true. + end function c_jac_solver_is_iterative + + function c_jac_solver_get_wrksize() result(val) + implicit none + integer(psb_ipk_) :: val + + val = 2 + end function c_jac_solver_get_wrksize + + subroutine c_l1_jac_solver_descr(sv,info,iout,coarse,prefix) + + Implicit None + + ! Arguments + class(amg_c_l1_jac_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + logical, intent(in), optional :: coarse + character(len=*), intent(in), optional :: prefix + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='amg_c_l1_jac_solver_descr' + integer(psb_ipk_) :: iout_ + character(1024) :: prefix_ + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(iout)) then + iout_ = iout + else + iout_ = psb_out_unit + endif + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + if (sv%eps<=dzero) then + write(iout_,*) trim(prefix_), ' L1-Jacobi iterative solver with ',& + & sv%sweeps,' sweeps' + else + write(iout_,*) trim(prefix_), ' L1-Jacobi iterative solver with tolerance',& + & sv%eps,' and maxit', sv%sweeps + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + end subroutine c_l1_jac_solver_descr + + function c_l1_jac_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "L1-Jacobi solver" + end function c_l1_jac_solver_get_fmt + + function c_l1_jac_solver_get_id() result(val) + implicit none + integer(psb_ipk_) :: val + + val = amg_l1_jac_ + end function c_l1_jac_solver_get_id + +end module amg_c_jac_solver diff --git a/amgprec/amg_d_jac_solver.f90 b/amgprec/amg_d_jac_solver.f90 new file mode 100644 index 00000000..25bb1375 --- /dev/null +++ b/amgprec/amg_d_jac_solver.f90 @@ -0,0 +1,582 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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. +! +! +! +! +! File: amg_d_jac_solver_mod.f90 +! +! Module: amg_d_jac_solver_mod +! +! This module defines: +! - the amg_d_jac_solver_type data structure containing the ingredients +! for a local Jacobi iteration. The iterations are local to a process +! (they operate on the block diagonal). +! +! +module amg_d_jac_solver + + use amg_d_base_solver_mod + + type, extends(amg_d_base_solver_type) :: amg_d_jac_solver_type + type(psb_dspmat_type) :: a + type(psb_d_vect_type), allocatable :: dv + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_) :: sweeps + real(psb_dpk_) :: eps + contains + procedure, pass(sv) :: dump => amg_d_jac_solver_dmp + procedure, pass(sv) :: check => d_jac_solver_check + procedure, pass(sv) :: clone => amg_d_jac_solver_clone + procedure, pass(sv) :: clone_settings => amg_d_jac_solver_clone_settings + procedure, pass(sv) :: clear_data => amg_d_jac_solver_clear_data + procedure, pass(sv) :: build => amg_d_jac_solver_bld + procedure, pass(sv) :: cnv => amg_d_jac_solver_cnv + procedure, pass(sv) :: apply_v => amg_d_jac_solver_apply_vect + procedure, pass(sv) :: apply_a => amg_d_jac_solver_apply + procedure, pass(sv) :: free => d_jac_solver_free + procedure, pass(sv) :: cseti => d_jac_solver_cseti + procedure, pass(sv) :: csetc => d_jac_solver_csetc + procedure, pass(sv) :: csetr => d_jac_solver_csetr + procedure, pass(sv) :: descr => d_jac_solver_descr + procedure, pass(sv) :: default => d_jac_solver_default + procedure, pass(sv) :: sizeof => d_jac_solver_sizeof + procedure, pass(sv) :: get_nzeros => d_jac_solver_get_nzeros + procedure, nopass :: get_wrksz => d_jac_solver_get_wrksize + procedure, nopass :: get_fmt => d_jac_solver_get_fmt + procedure, nopass :: get_id => d_jac_solver_get_id + procedure, nopass :: is_iterative => d_jac_solver_is_iterative + end type amg_d_jac_solver_type + + type, extends(amg_d_jac_solver_type) :: amg_d_l1_jac_solver_type + contains + procedure, pass(sv) :: build => amg_d_l1_jac_solver_bld + procedure, pass(sv) :: descr => d_l1_jac_solver_descr + procedure, nopass :: get_fmt => d_l1_jac_solver_get_fmt + procedure, nopass :: get_id => d_l1_jac_solver_get_id + end type amg_d_l1_jac_solver_type + + + private :: d_jac_solver_bld, d_jac_solver_apply, & + & d_jac_solver_free, & + & d_jac_solver_descr, d_jac_solver_sizeof, & + & d_jac_solver_default, d_jac_solver_dmp, & + & d_jac_solver_apply_vect, d_jac_solver_get_nzeros, & + & d_jac_solver_get_fmt, d_jac_solver_check,& + & d_jac_solver_is_iterative, & + & d_jac_solver_get_id, d_jac_solver_get_wrksize + + interface + subroutine amg_d_jac_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,wv,info,init,initu) + import :: psb_desc_type, amg_d_jac_solver_type, psb_d_vect_type, psb_dpk_, & + & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_ipk_ + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(amg_d_jac_solver_type), intent(inout) :: sv + type(psb_d_vect_type),intent(inout) :: x + type(psb_d_vect_type),intent(inout) :: y + real(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_dpk_),target, intent(inout) :: work(:) + type(psb_d_vect_type),intent(inout) :: wv(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_d_vect_type),intent(inout), optional :: initu + end subroutine amg_d_jac_solver_apply_vect + end interface + + interface + subroutine amg_d_jac_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info,init,initu) + import :: psb_desc_type, amg_d_jac_solver_type, psb_d_vect_type, psb_dpk_, & + & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_ipk_ + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(amg_d_jac_solver_type), intent(inout) :: sv + real(psb_dpk_),intent(inout) :: x(:) + real(psb_dpk_),intent(inout) :: y(:) + real(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_dpk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_dpk_),intent(inout), optional :: initu(:) + end subroutine amg_d_jac_solver_apply + end interface + + interface + subroutine amg_d_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) + import :: psb_desc_type, amg_d_jac_solver_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 + implicit none + type(psb_dspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(amg_d_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + type(psb_dspmat_type), intent(in), target, optional :: b + class(psb_d_base_sparse_mat), intent(in), optional :: amold + class(psb_d_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + end subroutine amg_d_jac_solver_bld + end interface + + interface + subroutine amg_d_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) + import :: psb_desc_type, amg_d_l1_jac_solver_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 + implicit none + type(psb_dspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(amg_d_l1_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + type(psb_dspmat_type), intent(in), target, optional :: b + class(psb_d_base_sparse_mat), intent(in), optional :: amold + class(psb_d_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + end subroutine amg_d_l1_jac_solver_bld + end interface + + interface + subroutine amg_d_jac_solver_cnv(sv,info,amold,vmold,imold) + import :: amg_d_jac_solver_type, psb_dpk_, & + & psb_d_base_sparse_mat, psb_d_base_vect_type,& + & psb_ipk_, psb_i_base_vect_type + implicit none + class(amg_d_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_sparse_mat), intent(in), optional :: amold + class(psb_d_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + end subroutine amg_d_jac_solver_cnv + end interface + + interface + subroutine amg_d_jac_solver_dmp(sv,desc,level,info,prefix,head,solver,global_num) + import :: psb_desc_type, amg_d_jac_solver_type, psb_d_vect_type, psb_dpk_, & + & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, & + & psb_ipk_ + implicit none + class(amg_d_jac_solver_type), intent(in) :: sv + type(psb_desc_type), intent(in) :: desc + integer(psb_ipk_), intent(in) :: level + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: solver, global_num + end subroutine amg_d_jac_solver_dmp + end interface + + interface + subroutine amg_d_jac_solver_clone(sv,svout,info) + import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, & + & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, & + & amg_d_base_solver_type, amg_d_jac_solver_type, psb_ipk_ + Implicit None + + ! Arguments + class(amg_d_jac_solver_type), intent(inout) :: sv + class(amg_d_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info + end subroutine amg_d_jac_solver_clone + end interface + +!!$ interface +!!$ subroutine amg_d_l1_jac_solver_clone(sv,svout,info) +!!$ import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, & +!!$ & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, & +!!$ & amg_d_base_solver_type, amg_d_l1_jac_solver_type, psb_ipk_ +!!$ Implicit None +!!$ +!!$ ! Arguments +!!$ class(amg_d_l1_jac_solver_type), intent(inout) :: sv +!!$ class(amg_d_base_solver_type), allocatable, intent(inout) :: svout +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine amg_d_l1_jac_solver_clone +!!$ end interface + + interface + subroutine amg_d_jac_solver_clone_settings(sv,svout,info) + import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, & + & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, & + & amg_d_base_solver_type, amg_d_jac_solver_type, psb_ipk_ + Implicit None + + ! Arguments + class(amg_d_jac_solver_type), intent(inout) :: sv + class(amg_d_base_solver_type), intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info + end subroutine amg_d_jac_solver_clone_settings + end interface + + interface + subroutine amg_d_jac_solver_clear_data(sv,info) + import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, & + & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, & + & amg_d_jac_solver_type, psb_ipk_ + Implicit None + + ! Arguments + class(amg_d_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + end subroutine amg_d_jac_solver_clear_data + end interface + +contains + + subroutine d_jac_solver_default(sv) + + Implicit None + + ! Arguments + class(amg_d_jac_solver_type), intent(inout) :: sv + + sv%sweeps = ione + sv%eps = dzero + + return + end subroutine d_jac_solver_default + + subroutine d_jac_solver_check(sv,info) + + Implicit None + + ! Arguments + class(amg_d_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='d_jac_solver_check' + + call psb_erractionsave(err_act) + info = psb_success_ + + call amg_check_def(sv%sweeps,& + & 'Jacobi sweeps',ione,is_int_positive) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine d_jac_solver_check + + subroutine d_jac_solver_cseti(sv,what,val,info,idx) + + Implicit None + + ! Arguments + class(amg_d_jac_solver_type), intent(inout) :: sv + 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_solver_cseti' + + info = psb_success_ + call psb_erractionsave(err_act) + + select case(psb_toupper(what)) + case('SOLVER_SWEEPS') + sv%sweeps = val + case default + call sv%amg_d_base_solver_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 d_jac_solver_cseti + + subroutine d_jac_solver_csetc(sv,what,val,info,idx) + + Implicit None + + ! Arguments + class(amg_d_jac_solver_type), intent(inout) :: sv + 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_solver_csetc' + + info = psb_success_ + call psb_erractionsave(err_act) + + + call sv%amg_d_base_solver_type%set(what,val,info,idx=idx) + + 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 d_jac_solver_csetc + + subroutine d_jac_solver_csetr(sv,what,val,info,idx) + + Implicit None + + ! Arguments + class(amg_d_jac_solver_type), intent(inout) :: sv + 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_solver_csetr' + + call psb_erractionsave(err_act) + info = psb_success_ + + select case(psb_toupper(what)) + case('SOLVER_EPS') + sv%eps = val + case default + call sv%amg_d_base_solver_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 d_jac_solver_csetr + + subroutine d_jac_solver_free(sv,info) + + Implicit None + + ! Arguments + class(amg_d_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='d_jac_solver_free' + + call psb_erractionsave(err_act) + info = psb_success_ + + call sv%a%free() + call sv%dv%free(info) + if (allocated(sv%d)) deallocate(sv%d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + end subroutine d_jac_solver_free + + subroutine d_jac_solver_descr(sv,info,iout,coarse,prefix) + + Implicit None + + ! Arguments + class(amg_d_jac_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + logical, intent(in), optional :: coarse + character(len=*), intent(in), optional :: prefix + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='amg_d_jac_solver_descr' + integer(psb_ipk_) :: iout_ + character(1024) :: prefix_ + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(iout)) then + iout_ = iout + else + iout_ = psb_out_unit + endif + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + if (sv%eps<=dzero) then + write(iout_,*) trim(prefix_), ' Jacobi iterative solver with ',& + & sv%sweeps,' sweeps' + else + write(iout_,*) trim(prefix_), ' Jacobi iterative solver with tolerance',& + & sv%eps,' and maxit', sv%sweeps + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + end subroutine d_jac_solver_descr + + function d_jac_solver_get_nzeros(sv) result(val) + + implicit none + ! Arguments + class(amg_d_jac_solver_type), intent(in) :: sv + integer(psb_epk_) :: val + integer(psb_ipk_) :: i + + val = 0 + val = val + sv%a%get_nzeros() + val = val + sv%dv%get_nrows() + + return + end function d_jac_solver_get_nzeros + + function d_jac_solver_sizeof(sv) result(val) + + implicit none + ! Arguments + class(amg_d_jac_solver_type), intent(in) :: sv + integer(psb_epk_) :: val + integer(psb_ipk_) :: i + + val = psb_sizeof_ip + val = val + sv%a%sizeof() + val = val + sv%dv%sizeof() + + return + end function d_jac_solver_sizeof + + function d_jac_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Jacobi solver" + end function d_jac_solver_get_fmt + + function d_jac_solver_get_id() result(val) + implicit none + integer(psb_ipk_) :: val + + val = amg_jac_ + end function d_jac_solver_get_id + + ! + ! If this is true, then the solver needs a starting + ! guess. Currently only handled in JAC smoother. + ! + function d_jac_solver_is_iterative() result(val) + implicit none + logical :: val + + val = .true. + end function d_jac_solver_is_iterative + + function d_jac_solver_get_wrksize() result(val) + implicit none + integer(psb_ipk_) :: val + + val = 2 + end function d_jac_solver_get_wrksize + + subroutine d_l1_jac_solver_descr(sv,info,iout,coarse,prefix) + + Implicit None + + ! Arguments + class(amg_d_l1_jac_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + logical, intent(in), optional :: coarse + character(len=*), intent(in), optional :: prefix + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='amg_d_l1_jac_solver_descr' + integer(psb_ipk_) :: iout_ + character(1024) :: prefix_ + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(iout)) then + iout_ = iout + else + iout_ = psb_out_unit + endif + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + if (sv%eps<=dzero) then + write(iout_,*) trim(prefix_), ' L1-Jacobi iterative solver with ',& + & sv%sweeps,' sweeps' + else + write(iout_,*) trim(prefix_), ' L1-Jacobi iterative solver with tolerance',& + & sv%eps,' and maxit', sv%sweeps + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + end subroutine d_l1_jac_solver_descr + + function d_l1_jac_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "L1-Jacobi solver" + end function d_l1_jac_solver_get_fmt + + function d_l1_jac_solver_get_id() result(val) + implicit none + integer(psb_ipk_) :: val + + val = amg_l1_jac_ + end function d_l1_jac_solver_get_id + +end module amg_d_jac_solver diff --git a/amgprec/amg_s_jac_solver.f90 b/amgprec/amg_s_jac_solver.f90 new file mode 100644 index 00000000..8cc66bbc --- /dev/null +++ b/amgprec/amg_s_jac_solver.f90 @@ -0,0 +1,582 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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. +! +! +! +! +! File: amg_s_jac_solver_mod.f90 +! +! Module: amg_s_jac_solver_mod +! +! This module defines: +! - the amg_s_jac_solver_type data structure containing the ingredients +! for a local Jacobi iteration. The iterations are local to a process +! (they operate on the block diagonal). +! +! +module amg_s_jac_solver + + use amg_s_base_solver_mod + + type, extends(amg_s_base_solver_type) :: amg_s_jac_solver_type + type(psb_sspmat_type) :: a + type(psb_s_vect_type), allocatable :: dv + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_) :: sweeps + real(psb_spk_) :: eps + contains + procedure, pass(sv) :: dump => amg_s_jac_solver_dmp + procedure, pass(sv) :: check => s_jac_solver_check + procedure, pass(sv) :: clone => amg_s_jac_solver_clone + procedure, pass(sv) :: clone_settings => amg_s_jac_solver_clone_settings + procedure, pass(sv) :: clear_data => amg_s_jac_solver_clear_data + procedure, pass(sv) :: build => amg_s_jac_solver_bld + procedure, pass(sv) :: cnv => amg_s_jac_solver_cnv + procedure, pass(sv) :: apply_v => amg_s_jac_solver_apply_vect + procedure, pass(sv) :: apply_a => amg_s_jac_solver_apply + procedure, pass(sv) :: free => s_jac_solver_free + procedure, pass(sv) :: cseti => s_jac_solver_cseti + procedure, pass(sv) :: csetc => s_jac_solver_csetc + procedure, pass(sv) :: csetr => s_jac_solver_csetr + procedure, pass(sv) :: descr => s_jac_solver_descr + procedure, pass(sv) :: default => s_jac_solver_default + procedure, pass(sv) :: sizeof => s_jac_solver_sizeof + procedure, pass(sv) :: get_nzeros => s_jac_solver_get_nzeros + procedure, nopass :: get_wrksz => s_jac_solver_get_wrksize + procedure, nopass :: get_fmt => s_jac_solver_get_fmt + procedure, nopass :: get_id => s_jac_solver_get_id + procedure, nopass :: is_iterative => s_jac_solver_is_iterative + end type amg_s_jac_solver_type + + type, extends(amg_s_jac_solver_type) :: amg_s_l1_jac_solver_type + contains + procedure, pass(sv) :: build => amg_s_l1_jac_solver_bld + procedure, pass(sv) :: descr => s_l1_jac_solver_descr + procedure, nopass :: get_fmt => s_l1_jac_solver_get_fmt + procedure, nopass :: get_id => s_l1_jac_solver_get_id + end type amg_s_l1_jac_solver_type + + + private :: s_jac_solver_bld, s_jac_solver_apply, & + & s_jac_solver_free, & + & s_jac_solver_descr, s_jac_solver_sizeof, & + & s_jac_solver_default, s_jac_solver_dmp, & + & s_jac_solver_apply_vect, s_jac_solver_get_nzeros, & + & s_jac_solver_get_fmt, s_jac_solver_check,& + & s_jac_solver_is_iterative, & + & s_jac_solver_get_id, s_jac_solver_get_wrksize + + interface + subroutine amg_s_jac_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,wv,info,init,initu) + import :: psb_desc_type, amg_s_jac_solver_type, psb_s_vect_type, psb_spk_, & + & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_ + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(amg_s_jac_solver_type), intent(inout) :: sv + type(psb_s_vect_type),intent(inout) :: x + type(psb_s_vect_type),intent(inout) :: y + real(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_spk_),target, intent(inout) :: work(:) + type(psb_s_vect_type),intent(inout) :: wv(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_s_vect_type),intent(inout), optional :: initu + end subroutine amg_s_jac_solver_apply_vect + end interface + + interface + subroutine amg_s_jac_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info,init,initu) + import :: psb_desc_type, amg_s_jac_solver_type, psb_s_vect_type, psb_spk_, & + & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_ + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(amg_s_jac_solver_type), intent(inout) :: sv + real(psb_spk_),intent(inout) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + real(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_spk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_spk_),intent(inout), optional :: initu(:) + end subroutine amg_s_jac_solver_apply + end interface + + interface + subroutine amg_s_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) + import :: psb_desc_type, amg_s_jac_solver_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 + implicit none + type(psb_sspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(amg_s_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + type(psb_sspmat_type), intent(in), target, optional :: b + class(psb_s_base_sparse_mat), intent(in), optional :: amold + class(psb_s_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + end subroutine amg_s_jac_solver_bld + end interface + + interface + subroutine amg_s_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) + import :: psb_desc_type, amg_s_l1_jac_solver_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 + implicit none + type(psb_sspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(amg_s_l1_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + type(psb_sspmat_type), intent(in), target, optional :: b + class(psb_s_base_sparse_mat), intent(in), optional :: amold + class(psb_s_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + end subroutine amg_s_l1_jac_solver_bld + end interface + + interface + subroutine amg_s_jac_solver_cnv(sv,info,amold,vmold,imold) + import :: amg_s_jac_solver_type, psb_spk_, & + & psb_s_base_sparse_mat, psb_s_base_vect_type,& + & psb_ipk_, psb_i_base_vect_type + implicit none + class(amg_s_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_sparse_mat), intent(in), optional :: amold + class(psb_s_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + end subroutine amg_s_jac_solver_cnv + end interface + + interface + subroutine amg_s_jac_solver_dmp(sv,desc,level,info,prefix,head,solver,global_num) + import :: psb_desc_type, amg_s_jac_solver_type, psb_s_vect_type, psb_spk_, & + & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, & + & psb_ipk_ + implicit none + class(amg_s_jac_solver_type), intent(in) :: sv + type(psb_desc_type), intent(in) :: desc + integer(psb_ipk_), intent(in) :: level + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: solver, global_num + end subroutine amg_s_jac_solver_dmp + end interface + + interface + subroutine amg_s_jac_solver_clone(sv,svout,info) + import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, & + & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, & + & amg_s_base_solver_type, amg_s_jac_solver_type, psb_ipk_ + Implicit None + + ! Arguments + class(amg_s_jac_solver_type), intent(inout) :: sv + class(amg_s_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info + end subroutine amg_s_jac_solver_clone + end interface + +!!$ interface +!!$ subroutine amg_s_l1_jac_solver_clone(sv,svout,info) +!!$ import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, & +!!$ & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, & +!!$ & amg_s_base_solver_type, amg_s_l1_jac_solver_type, psb_ipk_ +!!$ Implicit None +!!$ +!!$ ! Arguments +!!$ class(amg_s_l1_jac_solver_type), intent(inout) :: sv +!!$ class(amg_s_base_solver_type), allocatable, intent(inout) :: svout +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine amg_s_l1_jac_solver_clone +!!$ end interface + + interface + subroutine amg_s_jac_solver_clone_settings(sv,svout,info) + import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, & + & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, & + & amg_s_base_solver_type, amg_s_jac_solver_type, psb_ipk_ + Implicit None + + ! Arguments + class(amg_s_jac_solver_type), intent(inout) :: sv + class(amg_s_base_solver_type), intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info + end subroutine amg_s_jac_solver_clone_settings + end interface + + interface + subroutine amg_s_jac_solver_clear_data(sv,info) + import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, & + & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, & + & amg_s_jac_solver_type, psb_ipk_ + Implicit None + + ! Arguments + class(amg_s_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + end subroutine amg_s_jac_solver_clear_data + end interface + +contains + + subroutine s_jac_solver_default(sv) + + Implicit None + + ! Arguments + class(amg_s_jac_solver_type), intent(inout) :: sv + + sv%sweeps = ione + sv%eps = dzero + + return + end subroutine s_jac_solver_default + + subroutine s_jac_solver_check(sv,info) + + Implicit None + + ! Arguments + class(amg_s_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='s_jac_solver_check' + + call psb_erractionsave(err_act) + info = psb_success_ + + call amg_check_def(sv%sweeps,& + & 'Jacobi sweeps',ione,is_int_positive) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine s_jac_solver_check + + subroutine s_jac_solver_cseti(sv,what,val,info,idx) + + Implicit None + + ! Arguments + class(amg_s_jac_solver_type), intent(inout) :: sv + 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_solver_cseti' + + info = psb_success_ + call psb_erractionsave(err_act) + + select case(psb_toupper(what)) + case('SOLVER_SWEEPS') + sv%sweeps = val + case default + call sv%amg_s_base_solver_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 s_jac_solver_cseti + + subroutine s_jac_solver_csetc(sv,what,val,info,idx) + + Implicit None + + ! Arguments + class(amg_s_jac_solver_type), intent(inout) :: sv + 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_solver_csetc' + + info = psb_success_ + call psb_erractionsave(err_act) + + + call sv%amg_s_base_solver_type%set(what,val,info,idx=idx) + + 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 s_jac_solver_csetc + + subroutine s_jac_solver_csetr(sv,what,val,info,idx) + + Implicit None + + ! Arguments + class(amg_s_jac_solver_type), intent(inout) :: sv + 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_solver_csetr' + + call psb_erractionsave(err_act) + info = psb_success_ + + select case(psb_toupper(what)) + case('SOLVER_EPS') + sv%eps = val + case default + call sv%amg_s_base_solver_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 s_jac_solver_csetr + + subroutine s_jac_solver_free(sv,info) + + Implicit None + + ! Arguments + class(amg_s_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='s_jac_solver_free' + + call psb_erractionsave(err_act) + info = psb_success_ + + call sv%a%free() + call sv%dv%free(info) + if (allocated(sv%d)) deallocate(sv%d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + end subroutine s_jac_solver_free + + subroutine s_jac_solver_descr(sv,info,iout,coarse,prefix) + + Implicit None + + ! Arguments + class(amg_s_jac_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + logical, intent(in), optional :: coarse + character(len=*), intent(in), optional :: prefix + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='amg_s_jac_solver_descr' + integer(psb_ipk_) :: iout_ + character(1024) :: prefix_ + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(iout)) then + iout_ = iout + else + iout_ = psb_out_unit + endif + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + if (sv%eps<=dzero) then + write(iout_,*) trim(prefix_), ' Jacobi iterative solver with ',& + & sv%sweeps,' sweeps' + else + write(iout_,*) trim(prefix_), ' Jacobi iterative solver with tolerance',& + & sv%eps,' and maxit', sv%sweeps + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + end subroutine s_jac_solver_descr + + function s_jac_solver_get_nzeros(sv) result(val) + + implicit none + ! Arguments + class(amg_s_jac_solver_type), intent(in) :: sv + integer(psb_epk_) :: val + integer(psb_ipk_) :: i + + val = 0 + val = val + sv%a%get_nzeros() + val = val + sv%dv%get_nrows() + + return + end function s_jac_solver_get_nzeros + + function s_jac_solver_sizeof(sv) result(val) + + implicit none + ! Arguments + class(amg_s_jac_solver_type), intent(in) :: sv + integer(psb_epk_) :: val + integer(psb_ipk_) :: i + + val = psb_sizeof_ip + val = val + sv%a%sizeof() + val = val + sv%dv%sizeof() + + return + end function s_jac_solver_sizeof + + function s_jac_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Jacobi solver" + end function s_jac_solver_get_fmt + + function s_jac_solver_get_id() result(val) + implicit none + integer(psb_ipk_) :: val + + val = amg_jac_ + end function s_jac_solver_get_id + + ! + ! If this is true, then the solver needs a starting + ! guess. Currently only handled in JAC smoother. + ! + function s_jac_solver_is_iterative() result(val) + implicit none + logical :: val + + val = .true. + end function s_jac_solver_is_iterative + + function s_jac_solver_get_wrksize() result(val) + implicit none + integer(psb_ipk_) :: val + + val = 2 + end function s_jac_solver_get_wrksize + + subroutine s_l1_jac_solver_descr(sv,info,iout,coarse,prefix) + + Implicit None + + ! Arguments + class(amg_s_l1_jac_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + logical, intent(in), optional :: coarse + character(len=*), intent(in), optional :: prefix + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='amg_s_l1_jac_solver_descr' + integer(psb_ipk_) :: iout_ + character(1024) :: prefix_ + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(iout)) then + iout_ = iout + else + iout_ = psb_out_unit + endif + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + if (sv%eps<=dzero) then + write(iout_,*) trim(prefix_), ' L1-Jacobi iterative solver with ',& + & sv%sweeps,' sweeps' + else + write(iout_,*) trim(prefix_), ' L1-Jacobi iterative solver with tolerance',& + & sv%eps,' and maxit', sv%sweeps + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + end subroutine s_l1_jac_solver_descr + + function s_l1_jac_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "L1-Jacobi solver" + end function s_l1_jac_solver_get_fmt + + function s_l1_jac_solver_get_id() result(val) + implicit none + integer(psb_ipk_) :: val + + val = amg_l1_jac_ + end function s_l1_jac_solver_get_id + +end module amg_s_jac_solver diff --git a/amgprec/amg_z_jac_solver.f90 b/amgprec/amg_z_jac_solver.f90 new file mode 100644 index 00000000..28f1199e --- /dev/null +++ b/amgprec/amg_z_jac_solver.f90 @@ -0,0 +1,582 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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. +! +! +! +! +! File: amg_z_jac_solver_mod.f90 +! +! Module: amg_z_jac_solver_mod +! +! This module defines: +! - the amg_z_jac_solver_type data structure containing the ingredients +! for a local Jacobi iteration. The iterations are local to a process +! (they operate on the block diagonal). +! +! +module amg_z_jac_solver + + use amg_z_base_solver_mod + + type, extends(amg_z_base_solver_type) :: amg_z_jac_solver_type + type(psb_zspmat_type) :: a + type(psb_z_vect_type), allocatable :: dv + complex(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_) :: sweeps + real(psb_dpk_) :: eps + contains + procedure, pass(sv) :: dump => amg_z_jac_solver_dmp + procedure, pass(sv) :: check => z_jac_solver_check + procedure, pass(sv) :: clone => amg_z_jac_solver_clone + procedure, pass(sv) :: clone_settings => amg_z_jac_solver_clone_settings + procedure, pass(sv) :: clear_data => amg_z_jac_solver_clear_data + procedure, pass(sv) :: build => amg_z_jac_solver_bld + procedure, pass(sv) :: cnv => amg_z_jac_solver_cnv + procedure, pass(sv) :: apply_v => amg_z_jac_solver_apply_vect + procedure, pass(sv) :: apply_a => amg_z_jac_solver_apply + procedure, pass(sv) :: free => z_jac_solver_free + procedure, pass(sv) :: cseti => z_jac_solver_cseti + procedure, pass(sv) :: csetc => z_jac_solver_csetc + procedure, pass(sv) :: csetr => z_jac_solver_csetr + procedure, pass(sv) :: descr => z_jac_solver_descr + procedure, pass(sv) :: default => z_jac_solver_default + procedure, pass(sv) :: sizeof => z_jac_solver_sizeof + procedure, pass(sv) :: get_nzeros => z_jac_solver_get_nzeros + procedure, nopass :: get_wrksz => z_jac_solver_get_wrksize + procedure, nopass :: get_fmt => z_jac_solver_get_fmt + procedure, nopass :: get_id => z_jac_solver_get_id + procedure, nopass :: is_iterative => z_jac_solver_is_iterative + end type amg_z_jac_solver_type + + type, extends(amg_z_jac_solver_type) :: amg_z_l1_jac_solver_type + contains + procedure, pass(sv) :: build => amg_z_l1_jac_solver_bld + procedure, pass(sv) :: descr => z_l1_jac_solver_descr + procedure, nopass :: get_fmt => z_l1_jac_solver_get_fmt + procedure, nopass :: get_id => z_l1_jac_solver_get_id + end type amg_z_l1_jac_solver_type + + + private :: z_jac_solver_bld, z_jac_solver_apply, & + & z_jac_solver_free, & + & z_jac_solver_descr, z_jac_solver_sizeof, & + & z_jac_solver_default, z_jac_solver_dmp, & + & z_jac_solver_apply_vect, z_jac_solver_get_nzeros, & + & z_jac_solver_get_fmt, z_jac_solver_check,& + & z_jac_solver_is_iterative, & + & z_jac_solver_get_id, z_jac_solver_get_wrksize + + interface + subroutine amg_z_jac_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,wv,info,init,initu) + import :: psb_desc_type, amg_z_jac_solver_type, psb_z_vect_type, psb_dpk_, & + & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_ + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(amg_z_jac_solver_type), intent(inout) :: sv + type(psb_z_vect_type),intent(inout) :: x + type(psb_z_vect_type),intent(inout) :: y + complex(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + complex(psb_dpk_),target, intent(inout) :: work(:) + type(psb_z_vect_type),intent(inout) :: wv(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_z_vect_type),intent(inout), optional :: initu + end subroutine amg_z_jac_solver_apply_vect + end interface + + interface + subroutine amg_z_jac_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info,init,initu) + import :: psb_desc_type, amg_z_jac_solver_type, psb_z_vect_type, psb_dpk_, & + & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_ + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(amg_z_jac_solver_type), intent(inout) :: sv + complex(psb_dpk_),intent(inout) :: x(:) + complex(psb_dpk_),intent(inout) :: y(:) + complex(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + complex(psb_dpk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_dpk_),intent(inout), optional :: initu(:) + end subroutine amg_z_jac_solver_apply + end interface + + interface + subroutine amg_z_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) + import :: psb_desc_type, amg_z_jac_solver_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 + implicit none + type(psb_zspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(amg_z_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + type(psb_zspmat_type), intent(in), target, optional :: b + class(psb_z_base_sparse_mat), intent(in), optional :: amold + class(psb_z_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + end subroutine amg_z_jac_solver_bld + end interface + + interface + subroutine amg_z_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) + import :: psb_desc_type, amg_z_l1_jac_solver_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 + implicit none + type(psb_zspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(amg_z_l1_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + type(psb_zspmat_type), intent(in), target, optional :: b + class(psb_z_base_sparse_mat), intent(in), optional :: amold + class(psb_z_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + end subroutine amg_z_l1_jac_solver_bld + end interface + + interface + subroutine amg_z_jac_solver_cnv(sv,info,amold,vmold,imold) + import :: amg_z_jac_solver_type, psb_dpk_, & + & psb_z_base_sparse_mat, psb_z_base_vect_type,& + & psb_ipk_, psb_i_base_vect_type + implicit none + class(amg_z_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_sparse_mat), intent(in), optional :: amold + class(psb_z_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + end subroutine amg_z_jac_solver_cnv + end interface + + interface + subroutine amg_z_jac_solver_dmp(sv,desc,level,info,prefix,head,solver,global_num) + import :: psb_desc_type, amg_z_jac_solver_type, psb_z_vect_type, psb_dpk_, & + & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, & + & psb_ipk_ + implicit none + class(amg_z_jac_solver_type), intent(in) :: sv + type(psb_desc_type), intent(in) :: desc + integer(psb_ipk_), intent(in) :: level + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: solver, global_num + end subroutine amg_z_jac_solver_dmp + end interface + + interface + subroutine amg_z_jac_solver_clone(sv,svout,info) + import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, & + & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, & + & amg_z_base_solver_type, amg_z_jac_solver_type, psb_ipk_ + Implicit None + + ! Arguments + class(amg_z_jac_solver_type), intent(inout) :: sv + class(amg_z_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info + end subroutine amg_z_jac_solver_clone + end interface + +!!$ interface +!!$ subroutine amg_z_l1_jac_solver_clone(sv,svout,info) +!!$ import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, & +!!$ & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, & +!!$ & amg_z_base_solver_type, amg_z_l1_jac_solver_type, psb_ipk_ +!!$ Implicit None +!!$ +!!$ ! Arguments +!!$ class(amg_z_l1_jac_solver_type), intent(inout) :: sv +!!$ class(amg_z_base_solver_type), allocatable, intent(inout) :: svout +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine amg_z_l1_jac_solver_clone +!!$ end interface + + interface + subroutine amg_z_jac_solver_clone_settings(sv,svout,info) + import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, & + & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, & + & amg_z_base_solver_type, amg_z_jac_solver_type, psb_ipk_ + Implicit None + + ! Arguments + class(amg_z_jac_solver_type), intent(inout) :: sv + class(amg_z_base_solver_type), intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info + end subroutine amg_z_jac_solver_clone_settings + end interface + + interface + subroutine amg_z_jac_solver_clear_data(sv,info) + import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, & + & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, & + & amg_z_jac_solver_type, psb_ipk_ + Implicit None + + ! Arguments + class(amg_z_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + end subroutine amg_z_jac_solver_clear_data + end interface + +contains + + subroutine z_jac_solver_default(sv) + + Implicit None + + ! Arguments + class(amg_z_jac_solver_type), intent(inout) :: sv + + sv%sweeps = ione + sv%eps = dzero + + return + end subroutine z_jac_solver_default + + subroutine z_jac_solver_check(sv,info) + + Implicit None + + ! Arguments + class(amg_z_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='z_jac_solver_check' + + call psb_erractionsave(err_act) + info = psb_success_ + + call amg_check_def(sv%sweeps,& + & 'Jacobi sweeps',ione,is_int_positive) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine z_jac_solver_check + + subroutine z_jac_solver_cseti(sv,what,val,info,idx) + + Implicit None + + ! Arguments + class(amg_z_jac_solver_type), intent(inout) :: sv + 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_solver_cseti' + + info = psb_success_ + call psb_erractionsave(err_act) + + select case(psb_toupper(what)) + case('SOLVER_SWEEPS') + sv%sweeps = val + case default + call sv%amg_z_base_solver_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 z_jac_solver_cseti + + subroutine z_jac_solver_csetc(sv,what,val,info,idx) + + Implicit None + + ! Arguments + class(amg_z_jac_solver_type), intent(inout) :: sv + 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_solver_csetc' + + info = psb_success_ + call psb_erractionsave(err_act) + + + call sv%amg_z_base_solver_type%set(what,val,info,idx=idx) + + 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 z_jac_solver_csetc + + subroutine z_jac_solver_csetr(sv,what,val,info,idx) + + Implicit None + + ! Arguments + class(amg_z_jac_solver_type), intent(inout) :: sv + 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_solver_csetr' + + call psb_erractionsave(err_act) + info = psb_success_ + + select case(psb_toupper(what)) + case('SOLVER_EPS') + sv%eps = val + case default + call sv%amg_z_base_solver_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 z_jac_solver_csetr + + subroutine z_jac_solver_free(sv,info) + + Implicit None + + ! Arguments + class(amg_z_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='z_jac_solver_free' + + call psb_erractionsave(err_act) + info = psb_success_ + + call sv%a%free() + call sv%dv%free(info) + if (allocated(sv%d)) deallocate(sv%d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + end subroutine z_jac_solver_free + + subroutine z_jac_solver_descr(sv,info,iout,coarse,prefix) + + Implicit None + + ! Arguments + class(amg_z_jac_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + logical, intent(in), optional :: coarse + character(len=*), intent(in), optional :: prefix + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='amg_z_jac_solver_descr' + integer(psb_ipk_) :: iout_ + character(1024) :: prefix_ + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(iout)) then + iout_ = iout + else + iout_ = psb_out_unit + endif + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + if (sv%eps<=dzero) then + write(iout_,*) trim(prefix_), ' Jacobi iterative solver with ',& + & sv%sweeps,' sweeps' + else + write(iout_,*) trim(prefix_), ' Jacobi iterative solver with tolerance',& + & sv%eps,' and maxit', sv%sweeps + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + end subroutine z_jac_solver_descr + + function z_jac_solver_get_nzeros(sv) result(val) + + implicit none + ! Arguments + class(amg_z_jac_solver_type), intent(in) :: sv + integer(psb_epk_) :: val + integer(psb_ipk_) :: i + + val = 0 + val = val + sv%a%get_nzeros() + val = val + sv%dv%get_nrows() + + return + end function z_jac_solver_get_nzeros + + function z_jac_solver_sizeof(sv) result(val) + + implicit none + ! Arguments + class(amg_z_jac_solver_type), intent(in) :: sv + integer(psb_epk_) :: val + integer(psb_ipk_) :: i + + val = psb_sizeof_ip + val = val + sv%a%sizeof() + val = val + sv%dv%sizeof() + + return + end function z_jac_solver_sizeof + + function z_jac_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Jacobi solver" + end function z_jac_solver_get_fmt + + function z_jac_solver_get_id() result(val) + implicit none + integer(psb_ipk_) :: val + + val = amg_jac_ + end function z_jac_solver_get_id + + ! + ! If this is true, then the solver needs a starting + ! guess. Currently only handled in JAC smoother. + ! + function z_jac_solver_is_iterative() result(val) + implicit none + logical :: val + + val = .true. + end function z_jac_solver_is_iterative + + function z_jac_solver_get_wrksize() result(val) + implicit none + integer(psb_ipk_) :: val + + val = 2 + end function z_jac_solver_get_wrksize + + subroutine z_l1_jac_solver_descr(sv,info,iout,coarse,prefix) + + Implicit None + + ! Arguments + class(amg_z_l1_jac_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + logical, intent(in), optional :: coarse + character(len=*), intent(in), optional :: prefix + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='amg_z_l1_jac_solver_descr' + integer(psb_ipk_) :: iout_ + character(1024) :: prefix_ + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(iout)) then + iout_ = iout + else + iout_ = psb_out_unit + endif + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + if (sv%eps<=dzero) then + write(iout_,*) trim(prefix_), ' L1-Jacobi iterative solver with ',& + & sv%sweeps,' sweeps' + else + write(iout_,*) trim(prefix_), ' L1-Jacobi iterative solver with tolerance',& + & sv%eps,' and maxit', sv%sweeps + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + end subroutine z_l1_jac_solver_descr + + function z_l1_jac_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "L1-Jacobi solver" + end function z_l1_jac_solver_get_fmt + + function z_l1_jac_solver_get_id() result(val) + implicit none + integer(psb_ipk_) :: val + + val = amg_l1_jac_ + end function z_l1_jac_solver_get_id + +end module amg_z_jac_solver diff --git a/amgprec/impl/amg_ccprecset.F90 b/amgprec/impl/amg_ccprecset.F90 index a9077054..70dc3013 100644 --- a/amgprec/impl/amg_ccprecset.F90 +++ b/amgprec/impl/amg_ccprecset.F90 @@ -84,6 +84,7 @@ subroutine amg_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx) use amg_c_diag_solver use amg_c_l1_diag_solver use amg_c_ilu_solver + use amg_c_jac_solver use amg_c_id_solver use amg_c_gs_solver use amg_c_ainv_solver @@ -308,6 +309,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx) use amg_c_diag_solver use amg_c_l1_diag_solver use amg_c_ilu_solver + use amg_c_jac_solver use amg_c_id_solver use amg_c_gs_solver use amg_c_ainv_solver diff --git a/amgprec/impl/amg_dcprecset.F90 b/amgprec/impl/amg_dcprecset.F90 index a08488a7..deaced0d 100644 --- a/amgprec/impl/amg_dcprecset.F90 +++ b/amgprec/impl/amg_dcprecset.F90 @@ -84,6 +84,7 @@ subroutine amg_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx) use amg_d_diag_solver use amg_d_l1_diag_solver use amg_d_ilu_solver + use amg_d_jac_solver use amg_d_id_solver use amg_d_gs_solver use amg_d_ainv_solver @@ -314,6 +315,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx) use amg_d_diag_solver use amg_d_l1_diag_solver use amg_d_ilu_solver + use amg_d_jac_solver use amg_d_id_solver use amg_d_gs_solver use amg_d_ainv_solver diff --git a/amgprec/impl/amg_scprecset.F90 b/amgprec/impl/amg_scprecset.F90 index f116613b..754725ad 100644 --- a/amgprec/impl/amg_scprecset.F90 +++ b/amgprec/impl/amg_scprecset.F90 @@ -84,6 +84,7 @@ subroutine amg_scprecseti(p,what,val,info,ilev,ilmax,pos,idx) use amg_s_diag_solver use amg_s_l1_diag_solver use amg_s_ilu_solver + use amg_s_jac_solver use amg_s_id_solver use amg_s_gs_solver use amg_s_ainv_solver @@ -308,6 +309,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx) use amg_s_diag_solver use amg_s_l1_diag_solver use amg_s_ilu_solver + use amg_s_jac_solver use amg_s_id_solver use amg_s_gs_solver use amg_s_ainv_solver diff --git a/amgprec/impl/amg_zcprecset.F90 b/amgprec/impl/amg_zcprecset.F90 index 07d80fd4..5317ca6c 100644 --- a/amgprec/impl/amg_zcprecset.F90 +++ b/amgprec/impl/amg_zcprecset.F90 @@ -84,6 +84,7 @@ subroutine amg_zcprecseti(p,what,val,info,ilev,ilmax,pos,idx) use amg_z_diag_solver use amg_z_l1_diag_solver use amg_z_ilu_solver + use amg_z_jac_solver use amg_z_id_solver use amg_z_gs_solver use amg_z_ainv_solver @@ -314,6 +315,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx) use amg_z_diag_solver use amg_z_l1_diag_solver use amg_z_ilu_solver + use amg_z_jac_solver use amg_z_id_solver use amg_z_gs_solver use amg_z_ainv_solver diff --git a/amgprec/impl/level/amg_c_base_onelev_csetc.F90 b/amgprec/impl/level/amg_c_base_onelev_csetc.F90 index 18b76472..a372d972 100644 --- a/amgprec/impl/level/amg_c_base_onelev_csetc.F90 +++ b/amgprec/impl/level/amg_c_base_onelev_csetc.F90 @@ -46,6 +46,7 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx) use amg_c_as_smoother use amg_c_diag_solver use amg_c_l1_diag_solver + use amg_c_jac_solver use amg_c_ilu_solver use amg_c_id_solver use amg_c_gs_solver @@ -78,6 +79,8 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx) type(amg_c_as_smoother_type) :: amg_c_as_smoother_mold type(amg_c_diag_solver_type) :: amg_c_diag_solver_mold type(amg_c_l1_diag_solver_type) :: amg_c_l1_diag_solver_mold + type(amg_c_jac_solver_type) :: amg_c_jac_solver_mold + type(amg_c_l1_jac_solver_type) :: amg_c_l1_jac_solver_mold type(amg_c_ilu_solver_type) :: amg_c_ilu_solver_mold type(amg_c_id_solver_type) :: amg_c_id_solver_mold type(amg_c_gs_solver_type) :: amg_c_gs_solver_mold @@ -185,11 +188,16 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx) case ('NONE','NOPREC','FACT_NONE') call lv%set(amg_c_id_solver_mold,info,pos=pos) - case ('DIAG','JACOBI') + case ('DIAG') call lv%set(amg_c_diag_solver_mold,info,pos=pos) - case ('L1-DIAG','L1-JACOBI') + case ('JACOBI') + call lv%set(amg_c_jac_solver_mold,info,pos=pos) + + case ('L1-DIAG') call lv%set(amg_c_l1_diag_solver_mold,info,pos=pos) + case ('L1-JACOBI') + call lv%set(amg_c_l1_jac_solver_mold,info,pos=pos) case ('GS','FGS','FWGS') call lv%set(amg_c_gs_solver_mold,info,pos=pos) diff --git a/amgprec/impl/level/amg_d_base_onelev_csetc.F90 b/amgprec/impl/level/amg_d_base_onelev_csetc.F90 index 6f317e8f..94f45276 100644 --- a/amgprec/impl/level/amg_d_base_onelev_csetc.F90 +++ b/amgprec/impl/level/amg_d_base_onelev_csetc.F90 @@ -47,6 +47,7 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx) use amg_d_as_smoother use amg_d_diag_solver use amg_d_l1_diag_solver + use amg_d_jac_solver use amg_d_ilu_solver use amg_d_id_solver use amg_d_gs_solver @@ -85,6 +86,8 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx) type(amg_d_as_smoother_type) :: amg_d_as_smoother_mold type(amg_d_diag_solver_type) :: amg_d_diag_solver_mold type(amg_d_l1_diag_solver_type) :: amg_d_l1_diag_solver_mold + type(amg_d_jac_solver_type) :: amg_d_jac_solver_mold + type(amg_d_l1_jac_solver_type) :: amg_d_l1_jac_solver_mold type(amg_d_ilu_solver_type) :: amg_d_ilu_solver_mold type(amg_d_id_solver_type) :: amg_d_id_solver_mold type(amg_d_gs_solver_type) :: amg_d_gs_solver_mold @@ -198,11 +201,16 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx) case ('NONE','NOPREC','FACT_NONE') call lv%set(amg_d_id_solver_mold,info,pos=pos) - case ('DIAG','JACOBI') + case ('DIAG') call lv%set(amg_d_diag_solver_mold,info,pos=pos) - case ('L1-DIAG','L1-JACOBI') + case ('JACOBI') + call lv%set(amg_d_jac_solver_mold,info,pos=pos) + + case ('L1-DIAG') call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos) + case ('L1-JACOBI') + call lv%set(amg_d_l1_jac_solver_mold,info,pos=pos) case ('GS','FGS','FWGS') call lv%set(amg_d_gs_solver_mold,info,pos=pos) diff --git a/amgprec/impl/level/amg_s_base_onelev_csetc.F90 b/amgprec/impl/level/amg_s_base_onelev_csetc.F90 index 456e7609..60329291 100644 --- a/amgprec/impl/level/amg_s_base_onelev_csetc.F90 +++ b/amgprec/impl/level/amg_s_base_onelev_csetc.F90 @@ -47,6 +47,7 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx) use amg_s_as_smoother use amg_s_diag_solver use amg_s_l1_diag_solver + use amg_s_jac_solver use amg_s_ilu_solver use amg_s_id_solver use amg_s_gs_solver @@ -79,6 +80,8 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx) type(amg_s_as_smoother_type) :: amg_s_as_smoother_mold type(amg_s_diag_solver_type) :: amg_s_diag_solver_mold type(amg_s_l1_diag_solver_type) :: amg_s_l1_diag_solver_mold + type(amg_s_jac_solver_type) :: amg_s_jac_solver_mold + type(amg_s_l1_jac_solver_type) :: amg_s_l1_jac_solver_mold type(amg_s_ilu_solver_type) :: amg_s_ilu_solver_mold type(amg_s_id_solver_type) :: amg_s_id_solver_mold type(amg_s_gs_solver_type) :: amg_s_gs_solver_mold @@ -186,11 +189,16 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx) case ('NONE','NOPREC','FACT_NONE') call lv%set(amg_s_id_solver_mold,info,pos=pos) - case ('DIAG','JACOBI') + case ('DIAG') call lv%set(amg_s_diag_solver_mold,info,pos=pos) - case ('L1-DIAG','L1-JACOBI') + case ('JACOBI') + call lv%set(amg_s_jac_solver_mold,info,pos=pos) + + case ('L1-DIAG') call lv%set(amg_s_l1_diag_solver_mold,info,pos=pos) + case ('L1-JACOBI') + call lv%set(amg_s_l1_jac_solver_mold,info,pos=pos) case ('GS','FGS','FWGS') call lv%set(amg_s_gs_solver_mold,info,pos=pos) diff --git a/amgprec/impl/level/amg_z_base_onelev_csetc.F90 b/amgprec/impl/level/amg_z_base_onelev_csetc.F90 index 630770ca..5ca4233c 100644 --- a/amgprec/impl/level/amg_z_base_onelev_csetc.F90 +++ b/amgprec/impl/level/amg_z_base_onelev_csetc.F90 @@ -46,6 +46,7 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx) use amg_z_as_smoother use amg_z_diag_solver use amg_z_l1_diag_solver + use amg_z_jac_solver use amg_z_ilu_solver use amg_z_id_solver use amg_z_gs_solver @@ -84,6 +85,8 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx) type(amg_z_as_smoother_type) :: amg_z_as_smoother_mold type(amg_z_diag_solver_type) :: amg_z_diag_solver_mold type(amg_z_l1_diag_solver_type) :: amg_z_l1_diag_solver_mold + type(amg_z_jac_solver_type) :: amg_z_jac_solver_mold + type(amg_z_l1_jac_solver_type) :: amg_z_l1_jac_solver_mold type(amg_z_ilu_solver_type) :: amg_z_ilu_solver_mold type(amg_z_id_solver_type) :: amg_z_id_solver_mold type(amg_z_gs_solver_type) :: amg_z_gs_solver_mold @@ -197,11 +200,16 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx) case ('NONE','NOPREC','FACT_NONE') call lv%set(amg_z_id_solver_mold,info,pos=pos) - case ('DIAG','JACOBI') + case ('DIAG') call lv%set(amg_z_diag_solver_mold,info,pos=pos) - case ('L1-DIAG','L1-JACOBI') + case ('JACOBI') + call lv%set(amg_z_jac_solver_mold,info,pos=pos) + + case ('L1-DIAG') call lv%set(amg_z_l1_diag_solver_mold,info,pos=pos) + case ('L1-JACOBI') + call lv%set(amg_z_l1_jac_solver_mold,info,pos=pos) case ('GS','FGS','FWGS') call lv%set(amg_z_gs_solver_mold,info,pos=pos) diff --git a/amgprec/impl/solver/Makefile b/amgprec/impl/solver/Makefile index 0623ed16..56942182 100644 --- a/amgprec/impl/solver/Makefile +++ b/amgprec/impl/solver/Makefile @@ -302,7 +302,43 @@ amg_z_invk_solver_clone.o \ amg_z_invk_solver_clone_settings.o \ amg_z_invk_solver_cseti.o \ amg_z_invk_solver_descr.o \ -amg_z_krm_solver_impl.o +amg_z_krm_solver_impl.o \ +amg_c_jac_solver_clone_settings.o \ +amg_c_jac_solver_clear_data.o \ +amg_c_jac_solver_cnv.o \ +amg_c_jac_solver_clone.o \ +amg_c_jac_solver_dmp.o \ +amg_c_jac_solver_apply_vect.o \ +amg_c_jac_solver_apply.o \ +amg_c_jac_solver_bld.o \ +amg_c_l1_jac_solver_bld.o \ +amg_z_jac_solver_clone_settings.o \ +amg_z_jac_solver_clear_data.o \ +amg_z_jac_solver_cnv.o \ +amg_z_jac_solver_clone.o \ +amg_z_jac_solver_dmp.o \ +amg_z_jac_solver_apply_vect.o \ +amg_z_jac_solver_apply.o \ +amg_z_jac_solver_bld.o \ +amg_z_l1_jac_solver_bld.o \ +amg_s_jac_solver_clone_settings.o \ +amg_s_jac_solver_clear_data.o \ +amg_s_jac_solver_cnv.o \ +amg_s_jac_solver_clone.o \ +amg_s_jac_solver_dmp.o \ +amg_s_jac_solver_apply_vect.o \ +amg_s_jac_solver_apply.o \ +amg_s_jac_solver_bld.o \ +amg_s_l1_jac_solver_bld.o \ +amg_d_jac_solver_clone_settings.o \ +amg_d_jac_solver_clear_data.o \ +amg_d_jac_solver_cnv.o \ +amg_d_jac_solver_clone.o \ +amg_d_jac_solver_dmp.o \ +amg_d_jac_solver_apply_vect.o \ +amg_d_jac_solver_apply.o \ +amg_d_jac_solver_bld.o \ +amg_d_l1_jac_solver_bld.o LIBNAME=libamg_prec.a diff --git a/amgprec/impl/solver/amg_c_base_ainv_solver_cnv.f90 b/amgprec/impl/solver/amg_c_base_ainv_solver_cnv.f90 index 4a3c5bd0..8b25d169 100644 --- a/amgprec/impl/solver/amg_c_base_ainv_solver_cnv.f90 +++ b/amgprec/impl/solver/amg_c_base_ainv_solver_cnv.f90 @@ -47,7 +47,6 @@ subroutine amg_c_base_ainv_solver_cnv(sv,info,amold,vmold,imold) class(psb_i_base_vect_type), intent(in), optional :: imold !local - integer(psb_ipk_) :: i, j, il1, iln, lname, lev integer(psb_ipk_) :: iam, np type(psb_ctxt_type) :: ctxt character(len=80) :: prefix_ diff --git a/amgprec/impl/solver/amg_c_diag_solver_bld.f90 b/amgprec/impl/solver/amg_c_diag_solver_bld.f90 index 8a08f3ab..fa16a66f 100644 --- a/amgprec/impl/solver/amg_c_diag_solver_bld.f90 +++ b/amgprec/impl/solver/amg_c_diag_solver_bld.f90 @@ -132,8 +132,7 @@ subroutine amg_c_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) class(psb_i_base_vect_type), intent(in), optional :: imold ! Local variables integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota - complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) - complex(psb_spk_), allocatable :: tdb(:) + complex(psb_spk_), allocatable :: tdb(:), tx(:), ty(:) type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np, me, i, err_act, debug_unit, debug_level character(len=20) :: name='c_l1_diag_solver_bld', ch_err @@ -151,12 +150,15 @@ subroutine amg_c_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) n_row = desc_a%get_local_rows() nrow_a = a%get_nrows() + tx = a%get_diag(info) sv%d = a%arwsum(info) + sv%d(:) = sv%d(:) - abs(tx(:)) + tx(:) if (info == psb_success_) call psb_realloc(n_row,sv%d,info) if (present(b)) then tdb=b%arwsum(info) + ty =b%get_diag(info) if (size(tdb)+nrow_a > n_row) call psb_realloc(nrow_a+size(tdb),sv%d,info) - if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) + if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) - abs(ty(:)) + ty(:) end if if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='arwsum') diff --git a/amgprec/impl/solver/amg_c_jac_solver_apply.f90 b/amgprec/impl/solver/amg_c_jac_solver_apply.f90 new file mode 100644 index 00000000..6eec4e5e --- /dev/null +++ b/amgprec/impl/solver/amg_c_jac_solver_apply.f90 @@ -0,0 +1,352 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_c_jac_solver_apply(alpha,sv,x,beta,y,desc_data,trans,& + & work,info,init,initu) + + use psb_base_mod + use amg_c_diag_solver + use psb_base_krylov_conv_mod, only : log_conv + use amg_c_jac_solver, amg_protect_name => amg_c_jac_solver_apply + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(amg_c_jac_solver_type), intent(inout) :: sv + complex(psb_spk_),intent(inout) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + complex(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + complex(psb_spk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_spk_),intent(inout), optional :: initu(:) + ! + integer(psb_ipk_) :: n_row,n_col, sweeps + complex(psb_spk_), pointer :: aux(:) + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, i, err_act + character :: trans_, init_ + real(psb_dpk_) :: res, resdenum + character(len=20) :: name='c_jac_solver_apply_v' + + call psb_erractionsave(err_act) + + info = psb_success_ + ctxt = desc_data%get_context() + call psb_info(ctxt,me,np) + + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T','C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + sweeps = sv%sweeps + if (4*n_col <= size(work)) then + aux => work(:) + else + allocate(aux(4*n_col),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/4*n_col,izero,izero,izero,izero/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + endif + + if (sweeps >= 0) then + ! + ! This means we are dealing with a pure Jacobi smoother/solver. + ! + associate(tx => aux(1:n_col), ty => aux(n_col+1:2*n_col)) + select case (init_) + case('Z') + + call inner_mlt(n_row,cone,sv%dv%v%v,x,czero,ty,trans=trans_) + + 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,sv%a,ty,cone,tx,desc_data,info,& + & work=aux,trans=trans_, doswap=.false.) + call inner_mlt(n_row,cone,sv%dv%v%v,tx,czero,ty,trans=trans_) + + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(cone,x,czero,tx,desc_data,info) + call psb_geaxpby(cone,initu,czero,ty,desc_data,info) + call psb_spmm(-cone,sv%a,ty,cone,tx,desc_data,info,& + & work=aux,trans=trans_, doswap=.false.) + call inner_mlt(n_row,cone,sv%dv%v%v,tx,czero,ty,trans=trans_) + + 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)), + ! where is the diagonal and A the matrix. + ! + call psb_geaxpby(cone,x,czero,tx,desc_data,info) + call psb_spmm(-cone,sv%a,ty,cone,tx,desc_data,info,& + & work=aux,trans=trans_, doswap=.false.) + if (info /= psb_success_) exit + call inner_mlt(n_row,cone,sv%dv%v%v,tx,cone,ty,trans=trans_) + if (info /= psb_success_) exit + end do + + if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) + + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='subsolve with Jacobi sweeps > 1') + goto 9999 + end if + + + end associate + + + else + + info = psb_err_iarg_neg_ + call psb_errpush(info,name,& + & i_err=(/itwo,sweeps,izero,izero,izero/)) + goto 9999 + + end if + + if (.not.(4*n_col <= size(work))) then + deallocate(aux) + endif + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +contains + subroutine inner_mlt(n_row,alpha,d,x,beta,y,trans) + implicit none + integer(psb_ipk_),intent(in) :: n_row + complex(psb_spk_), intent(inout) :: d(:) + complex(psb_spk_),intent(inout) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + complex(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + + integer(psb_ipk_) :: i + + if (trans_ == 'C') then + if (beta == czero) then + + if (alpha == czero) then + y(1:n_row) = czero + else if (alpha == cone) then + do i=1, n_row + y(i) = conjg(d(i)) * x(i) + end do + else if (alpha == -cone) then + do i=1, n_row + y(i) = -conjg(d(i)) * x(i) + end do + else + do i=1, n_row + y(i) = alpha * conjg(d(i)) * x(i) + end do + end if + + else if (beta == cone) then + + if (alpha == czero) then + !y(1:n_row) = czero + else if (alpha == cone) then + do i=1, n_row + y(i) = conjg(d(i)) * x(i) + y(i) + end do + else if (alpha == -cone) then + do i=1, n_row + y(i) = -conjg(d(i)) * x(i) + y(i) + end do + else + do i=1, n_row + y(i) = alpha * conjg(d(i)) * x(i) + y(i) + end do + end if + + else if (beta == -cone) then + + if (alpha == czero) then + y(1:n_row) = -y(1:n_row) + else if (alpha == cone) then + do i=1, n_row + y(i) = conjg(d(i)) * x(i) - y(i) + end do + else if (alpha == -cone) then + do i=1, n_row + y(i) = -conjg(d(i)) * x(i) - y(i) + end do + else + do i=1, n_row + y(i) = alpha * conjg(d(i)) * x(i) - y(i) + end do + end if + + else + + if (alpha == czero) then + y(1:n_row) = beta *y(1:n_row) + else if (alpha == cone) then + do i=1, n_row + y(i) = conjg(d(i)) * x(i) + beta*y(i) + end do + else if (alpha == -cone) then + do i=1, n_row + y(i) = -conjg(d(i)) * x(i) + beta*y(i) + end do + else + do i=1, n_row + y(i) = alpha * conjg(d(i)) * x(i) + beta*y(i) + end do + end if + + end if + + else if (trans_ /= 'C') then + + if (beta == czero) then + + if (alpha == czero) then + y(1:n_row) = czero + else if (alpha == cone) then + do i=1, n_row + y(i) = d(i) * x(i) + end do + else if (alpha == -cone) then + do i=1, n_row + y(i) = -d(i) * x(i) + end do + else + do i=1, n_row + y(i) = alpha * d(i) * x(i) + end do + end if + + else if (beta == cone) then + + if (alpha == czero) then + !y(1:n_row) = czero + else if (alpha == cone) then + do i=1, n_row + y(i) = d(i) * x(i) + y(i) + end do + else if (alpha == -cone) then + do i=1, n_row + y(i) = -d(i) * x(i) + y(i) + end do + else + do i=1, n_row + y(i) = alpha * d(i) * x(i) + y(i) + end do + end if + + else if (beta == -cone) then + + if (alpha == czero) then + y(1:n_row) = -y(1:n_row) + else if (alpha == cone) then + do i=1, n_row + y(i) = d(i) * x(i) - y(i) + end do + else if (alpha == -cone) then + do i=1, n_row + y(i) = -d(i) * x(i) - y(i) + end do + else + do i=1, n_row + y(i) = alpha * d(i) * x(i) - y(i) + end do + end if + + else + + if (alpha == czero) then + y(1:n_row) = beta *y(1:n_row) + else if (alpha == cone) then + do i=1, n_row + y(i) = d(i) * x(i) + beta*y(i) + end do + else if (alpha == -cone) then + do i=1, n_row + y(i) = -d(i) * x(i) + beta*y(i) + end do + else + do i=1, n_row + y(i) = alpha * d(i) * x(i) + beta*y(i) + end do + end if + + end if + + end if + + end subroutine inner_mlt +end subroutine amg_c_jac_solver_apply diff --git a/amgprec/impl/solver/amg_c_jac_solver_apply_vect.f90 b/amgprec/impl/solver/amg_c_jac_solver_apply_vect.f90 new file mode 100644 index 00000000..7d48442e --- /dev/null +++ b/amgprec/impl/solver/amg_c_jac_solver_apply_vect.f90 @@ -0,0 +1,190 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_c_jac_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,& + & work,wv,info,init,initu) + + use psb_base_mod + use amg_c_diag_solver + use psb_base_krylov_conv_mod, only : log_conv + use amg_c_jac_solver, amg_protect_name => amg_c_jac_solver_apply_vect + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(amg_c_jac_solver_type), intent(inout) :: sv + type(psb_c_vect_type),intent(inout) :: x + type(psb_c_vect_type),intent(inout) :: y + complex(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + complex(psb_spk_),target, intent(inout) :: work(:) + type(psb_c_vect_type),intent(inout) :: wv(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_c_vect_type),intent(inout), optional :: initu + ! + integer(psb_ipk_) :: n_row,n_col, sweeps + type(psb_c_vect_type) :: tx, ty, r + complex(psb_spk_), pointer :: aux(:) + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, i, err_act + character :: trans_, init_ + real(psb_dpk_) :: res, resdenum + character(len=20) :: name='c_jac_solver_apply_v' + + call psb_erractionsave(err_act) + + info = psb_success_ + ctxt = desc_data%get_context() + call psb_info(ctxt,me,np) + + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T','C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + sweeps = sv%sweeps + if (4*n_col <= size(work)) then + aux => work(:) + else + allocate(aux(4*n_col),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/4*n_col,izero,izero,izero,izero/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + endif + + if (sweeps >= 0) then + ! + ! This means we are dealing with a pure Jacobi smoother/solver. + ! + associate(tx => wv(1), ty => wv(2)) + select case (init_) + case('Z') + + call ty%mlt(cone,sv%dv,x,czero,info,conjgx=trans_) + + 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,sv%a,ty,cone,tx,desc_data,info,& + & work=aux,trans=trans_, doswap=.false.) + call ty%mlt(cone,sv%dv,tx,czero,info,conjgx=trans_) + + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(cone,x,czero,tx,desc_data,info) + call psb_geaxpby(cone,initu,czero,ty,desc_data,info) + call psb_spmm(-cone,sv%a,ty,cone,tx,desc_data,info,& + & work=aux,trans=trans_, doswap=.false.) + call ty%mlt(cone,sv%dv,tx,czero,info,conjgx=trans_) + + 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)), + ! where is the diagonal and A the matrix. + ! + call psb_geaxpby(cone,x,czero,tx,desc_data,info) + call psb_spmm(-cone,sv%a,ty,cone,tx,desc_data,info,& + & work=aux,trans=trans_, doswap=.false.) + if (info /= psb_success_) exit + call ty%mlt(cone,sv%dv,tx,cone,info,conjgx=trans_) + if (info /= psb_success_) exit + end do + + + if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) + + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='subsolve with Jacobi sweeps > 1') + goto 9999 + end if + + + end associate + + + else + + info = psb_err_iarg_neg_ + call psb_errpush(info,name,& + & i_err=(/itwo,sweeps,izero,izero,izero/)) + goto 9999 + + end if + + if (.not.(4*n_col <= size(work))) then + deallocate(aux) + endif + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine amg_c_jac_solver_apply_vect diff --git a/amgprec/impl/solver/amg_c_jac_solver_bld.f90 b/amgprec/impl/solver/amg_c_jac_solver_bld.f90 new file mode 100644 index 00000000..c896de1d --- /dev/null +++ b/amgprec/impl/solver/amg_c_jac_solver_bld.f90 @@ -0,0 +1,125 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_c_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) + + use psb_base_mod + use amg_c_jac_solver, amg_protect_name => amg_c_jac_solver_bld + + Implicit None + + ! Arguments + type(psb_cspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(amg_c_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + type(psb_cspmat_type), intent(in), target, optional :: b + class(psb_c_base_sparse_mat), intent(in), optional :: amold + class(psb_c_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + ! Local variables + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota + complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + complex(psb_spk_), allocatable :: tdb(:) + type(psb_c_csr_sparse_mat) :: tcsr + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, i, err_act, debug_unit, debug_level + character(len=20) :: name='c_jac_solver_bld', ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + n_row = desc_a%get_local_rows() + nrow_a = a%get_nrows() + if (present(b)) then + info=psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end if + call a%cp_to(tcsr) + call sv%a%mv_from(tcsr) + if (present(amold)) call sv%a%cscnv(info,mold=amold) + + sv%d = a%get_diag(info) + if (info == psb_success_) call psb_realloc(n_row,sv%d,info) + if (present(b)) then + tdb=b%get_diag(info) + if (size(tdb)+nrow_a > n_row) call psb_realloc(nrow_a+size(tdb),sv%d,info) + if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) + end if + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='get_diag') + goto 9999 + end if + + do i=1,n_row + if (sv%d(i) == czero) then + sv%d(i) = cone + else + sv%d(i) = cone/sv%d(i) + end if + end do + allocate(sv%dv,stat=info) + if (info == psb_success_) then + call sv%dv%bld(sv%d) + if (present(vmold)) call sv%dv%cnv(vmold) + call sv%dv%sync() + else + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='Allocate sv%dv') + goto 9999 + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine amg_c_jac_solver_bld + + diff --git a/amgprec/impl/solver/amg_c_jac_solver_clear_data.f90 b/amgprec/impl/solver/amg_c_jac_solver_clear_data.f90 new file mode 100644 index 00000000..f0469082 --- /dev/null +++ b/amgprec/impl/solver/amg_c_jac_solver_clear_data.f90 @@ -0,0 +1,65 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_c_jac_solver_clear_data(sv,info) + + use psb_base_mod + use amg_c_jac_solver, amg_protect_name => amg_c_jac_solver_clear_data + + Implicit None + + ! Arguments + class(amg_c_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + ! Local variables + integer(psb_ipk_) :: err_act + + info=psb_success_ + call psb_erractionsave(err_act) + + call sv%a%free() + call sv%dv%free(info) + if ((info==0).and.allocated(sv%d)) deallocate(sv%d,stat=info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine amg_c_jac_solver_clear_data diff --git a/amgprec/impl/solver/amg_c_jac_solver_clone.f90 b/amgprec/impl/solver/amg_c_jac_solver_clone.f90 new file mode 100644 index 00000000..fa690052 --- /dev/null +++ b/amgprec/impl/solver/amg_c_jac_solver_clone.f90 @@ -0,0 +1,88 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_c_jac_solver_clone(sv,svout,info) + + use psb_base_mod + use amg_c_jac_solver, amg_protect_name => amg_c_jac_solver_clone + + Implicit None + + ! Arguments + class(amg_c_jac_solver_type), intent(inout) :: sv + class(amg_c_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info + ! Local variables + integer(psb_ipk_) :: err_act + + + info=psb_success_ + call psb_erractionsave(err_act) + if (allocated(svout)) then + call svout%free(info) + if (info == psb_success_) deallocate(svout, stat=info) + end if + if (info == psb_success_) & + & allocate(svout, mold=sv, stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + + select type(svo => svout) + class is (amg_c_jac_solver_type) + svo%sweeps = sv%sweeps + svo%eps = sv%eps + if (info == psb_success_) & + & call sv%a%clone(svo%a,info) + if (info == psb_success_) & + & call sv%dv%clone(svo%dv,info) + svo%d = sv%d + + class default + info = psb_err_internal_error_ + end select + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine amg_c_jac_solver_clone diff --git a/amgprec/impl/solver/amg_c_jac_solver_clone_settings.f90 b/amgprec/impl/solver/amg_c_jac_solver_clone_settings.f90 new file mode 100644 index 00000000..2159e34f --- /dev/null +++ b/amgprec/impl/solver/amg_c_jac_solver_clone_settings.f90 @@ -0,0 +1,69 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_c_jac_solver_clone_settings(sv,svout,info) + + use psb_base_mod + use amg_c_jac_solver, amg_protect_name => amg_c_jac_solver_clone_settings + Implicit None + ! Arguments + class(amg_c_jac_solver_type), intent(inout) :: sv + class(amg_c_base_solver_type), intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='c_jac_solver_clone_settings' + + call psb_erractionsave(err_act) + + select type(svout) + class is(amg_c_jac_solver_type) + svout%sweeps = sv%sweeps + svout%eps = sv%eps + + class default + info = psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine amg_c_jac_solver_clone_settings diff --git a/amgprec/impl/solver/amg_c_jac_solver_cnv.f90 b/amgprec/impl/solver/amg_c_jac_solver_cnv.f90 new file mode 100644 index 00000000..f68dfa00 --- /dev/null +++ b/amgprec/impl/solver/amg_c_jac_solver_cnv.f90 @@ -0,0 +1,72 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_c_jac_solver_cnv(sv,info,amold,vmold,imold) + + use psb_base_mod + use amg_c_jac_solver, amg_protect_name => amg_c_jac_solver_cnv + + Implicit None + + ! Arguments + class(amg_c_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_sparse_mat), intent(in), optional :: amold + class(psb_c_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + ! Local variables + integer(psb_ipk_) :: err_act, debug_unit, debug_level + character(len=20) :: name='c_jac_solver_cnv', ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (present(amold)) call sv%a%cscnv(info,mold=amold) + if ((info==0).and.present(vmold)) call sv%dv%cnv(mold=vmold) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine amg_c_jac_solver_cnv diff --git a/amgprec/impl/solver/amg_c_jac_solver_dmp.f90 b/amgprec/impl/solver/amg_c_jac_solver_dmp.f90 new file mode 100644 index 00000000..2dfbc729 --- /dev/null +++ b/amgprec/impl/solver/amg_c_jac_solver_dmp.f90 @@ -0,0 +1,107 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_c_jac_solver_dmp(sv,desc,level,info,prefix,head,solver,global_num) + + use psb_base_mod + use amg_c_jac_solver, amg_protect_name => amg_c_jac_solver_dmp + implicit none + class(amg_c_jac_solver_type), intent(in) :: sv + type(psb_desc_type), intent(in) :: desc + integer(psb_ipk_), intent(in) :: level + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: solver, global_num + integer(psb_ipk_) :: i, j, il1, iln, lname, lev + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np + character(len=80) :: prefix_ + character(len=120) :: fname ! len should be at least 20 more than + logical :: solver_, global_num_ + integer(psb_lpk_), allocatable :: iv(:) + ! len of prefix_ + + info = 0 + + ctxt = desc%get_context() + call psb_info(ctxt,iam,np) + + if (present(solver)) then + solver_ = solver + else + solver_ = .false. + end if + if (present(global_num)) then + global_num_ = global_num + else + global_num_ = .false. + end if + + + if (solver_) then + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_slv_c" + end if + lname = len_trim(prefix_) + fname = trim(prefix_) + write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam + lname = lname + 5 + + if (global_num_) then + iv = desc%get_global_indices(owned=.false.) + + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx' + if (sv%a%is_asb()) & + & call sv%a%print(fname,head=head,iv=iv) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_diag.mtx' + if (allocated(sv%dv)) & + & call psb_geprt(fname,sv%dv%v%v,head=head) + + else + + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx' + if (sv%a%is_asb()) & + & call sv%a%print(fname,head=head) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_diag.mtx' + if (allocated(sv%dv)) & + & call psb_geprt(fname,sv%dv%v%v,head=head) + end if + end if + +end subroutine amg_c_jac_solver_dmp diff --git a/amgprec/impl/solver/amg_c_l1_jac_solver_bld.f90 b/amgprec/impl/solver/amg_c_l1_jac_solver_bld.f90 new file mode 100644 index 00000000..12bb2b3b --- /dev/null +++ b/amgprec/impl/solver/amg_c_l1_jac_solver_bld.f90 @@ -0,0 +1,128 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_c_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) + + use psb_base_mod + use amg_c_jac_solver, amg_protect_name => amg_c_l1_jac_solver_bld + + Implicit None + + ! Arguments + type(psb_cspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(amg_c_l1_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + type(psb_cspmat_type), intent(in), target, optional :: b + class(psb_c_base_sparse_mat), intent(in), optional :: amold + class(psb_c_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + ! Local variables + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota + complex(psb_spk_), allocatable :: tdb(:), tx(:),ty(:) + type(psb_c_csr_sparse_mat) :: tcsr + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, i, err_act, debug_unit, debug_level + character(len=20) :: name='c_l1_jac_solver_bld', ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + n_row = desc_a%get_local_rows() + nrow_a = a%get_nrows() + if (present(b)) then + info=psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end if + + call a%cp_to(tcsr) + call sv%a%mv_from(tcsr) + if (present(amold)) call sv%a%cscnv(info,mold=amold) + + tx = a%get_diag(info) + sv%d = a%arwsum(info) + sv%d(:) = sv%d(:) - abs(tx(:)) + tx(:) + if (info == psb_success_) call psb_realloc(n_row,sv%d,info) + if (present(b)) then + tdb=b%arwsum(info) + ty =b%get_diag(info) + if (size(tdb)+nrow_a > n_row) call psb_realloc(nrow_a+size(tdb),sv%d,info) + if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) - abs(ty(:)) + ty(:) + end if + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='get_diag') + goto 9999 + end if + + do i=1,n_row + if (sv%d(i) == czero) then + sv%d(i) = cone + else + sv%d(i) = cone/sv%d(i) + end if + end do + allocate(sv%dv,stat=info) + if (info == psb_success_) then + call sv%dv%bld(sv%d) + if (present(vmold)) call sv%dv%cnv(vmold) + call sv%dv%sync() + else + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='Allocate sv%dv') + goto 9999 + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine amg_c_l1_jac_solver_bld + + diff --git a/amgprec/impl/solver/amg_d_base_ainv_solver_cnv.f90 b/amgprec/impl/solver/amg_d_base_ainv_solver_cnv.f90 index a308a7ec..f42c1504 100644 --- a/amgprec/impl/solver/amg_d_base_ainv_solver_cnv.f90 +++ b/amgprec/impl/solver/amg_d_base_ainv_solver_cnv.f90 @@ -47,7 +47,6 @@ subroutine amg_d_base_ainv_solver_cnv(sv,info,amold,vmold,imold) class(psb_i_base_vect_type), intent(in), optional :: imold !local - integer(psb_ipk_) :: i, j, il1, iln, lname, lev integer(psb_ipk_) :: iam, np type(psb_ctxt_type) :: ctxt character(len=80) :: prefix_ diff --git a/amgprec/impl/solver/amg_d_diag_solver_bld.f90 b/amgprec/impl/solver/amg_d_diag_solver_bld.f90 index 8a8d0392..e9fda7a9 100644 --- a/amgprec/impl/solver/amg_d_diag_solver_bld.f90 +++ b/amgprec/impl/solver/amg_d_diag_solver_bld.f90 @@ -132,8 +132,7 @@ subroutine amg_d_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) class(psb_i_base_vect_type), intent(in), optional :: imold ! Local variables integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota - real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) - real(psb_dpk_), allocatable :: tdb(:) + real(psb_dpk_), allocatable :: tdb(:), tx(:), ty(:) type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np, me, i, err_act, debug_unit, debug_level character(len=20) :: name='d_l1_diag_solver_bld', ch_err @@ -151,12 +150,15 @@ subroutine amg_d_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) n_row = desc_a%get_local_rows() nrow_a = a%get_nrows() + tx = a%get_diag(info) sv%d = a%arwsum(info) + sv%d(:) = sv%d(:) - abs(tx(:)) + tx(:) if (info == psb_success_) call psb_realloc(n_row,sv%d,info) if (present(b)) then tdb=b%arwsum(info) + ty =b%get_diag(info) if (size(tdb)+nrow_a > n_row) call psb_realloc(nrow_a+size(tdb),sv%d,info) - if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) + if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) - abs(ty(:)) + ty(:) end if if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='arwsum') diff --git a/amgprec/impl/solver/amg_d_jac_solver_apply.f90 b/amgprec/impl/solver/amg_d_jac_solver_apply.f90 new file mode 100644 index 00000000..4e5b9421 --- /dev/null +++ b/amgprec/impl/solver/amg_d_jac_solver_apply.f90 @@ -0,0 +1,352 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_d_jac_solver_apply(alpha,sv,x,beta,y,desc_data,trans,& + & work,info,init,initu) + + use psb_base_mod + use amg_d_diag_solver + use psb_base_krylov_conv_mod, only : log_conv + use amg_d_jac_solver, amg_protect_name => amg_d_jac_solver_apply + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(amg_d_jac_solver_type), intent(inout) :: sv + real(psb_dpk_),intent(inout) :: x(:) + real(psb_dpk_),intent(inout) :: y(:) + real(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_dpk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_dpk_),intent(inout), optional :: initu(:) + ! + integer(psb_ipk_) :: n_row,n_col, sweeps + real(psb_dpk_), pointer :: aux(:) + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, i, err_act + character :: trans_, init_ + real(psb_dpk_) :: res, resdenum + character(len=20) :: name='d_jac_solver_apply_v' + + call psb_erractionsave(err_act) + + info = psb_success_ + ctxt = desc_data%get_context() + call psb_info(ctxt,me,np) + + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T','C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + sweeps = sv%sweeps + if (4*n_col <= size(work)) then + aux => work(:) + else + allocate(aux(4*n_col),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/4*n_col,izero,izero,izero,izero/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + endif + + if (sweeps >= 0) then + ! + ! This means we are dealing with a pure Jacobi smoother/solver. + ! + associate(tx => aux(1:n_col), ty => aux(n_col+1:2*n_col)) + select case (init_) + case('Z') + + call inner_mlt(n_row,done,sv%dv%v%v,x,dzero,ty,trans=trans_) + + 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,sv%a,ty,done,tx,desc_data,info,& + & work=aux,trans=trans_, doswap=.false.) + call inner_mlt(n_row,done,sv%dv%v%v,tx,dzero,ty,trans=trans_) + + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(done,x,dzero,tx,desc_data,info) + call psb_geaxpby(done,initu,dzero,ty,desc_data,info) + call psb_spmm(-done,sv%a,ty,done,tx,desc_data,info,& + & work=aux,trans=trans_, doswap=.false.) + call inner_mlt(n_row,done,sv%dv%v%v,tx,dzero,ty,trans=trans_) + + 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)), + ! where is the diagonal and A the matrix. + ! + call psb_geaxpby(done,x,dzero,tx,desc_data,info) + call psb_spmm(-done,sv%a,ty,done,tx,desc_data,info,& + & work=aux,trans=trans_, doswap=.false.) + if (info /= psb_success_) exit + call inner_mlt(n_row,done,sv%dv%v%v,tx,done,ty,trans=trans_) + if (info /= psb_success_) exit + end do + + if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) + + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='subsolve with Jacobi sweeps > 1') + goto 9999 + end if + + + end associate + + + else + + info = psb_err_iarg_neg_ + call psb_errpush(info,name,& + & i_err=(/itwo,sweeps,izero,izero,izero/)) + goto 9999 + + end if + + if (.not.(4*n_col <= size(work))) then + deallocate(aux) + endif + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +contains + subroutine inner_mlt(n_row,alpha,d,x,beta,y,trans) + implicit none + integer(psb_ipk_),intent(in) :: n_row + real(psb_dpk_), intent(inout) :: d(:) + real(psb_dpk_),intent(inout) :: x(:) + real(psb_dpk_),intent(inout) :: y(:) + real(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + + integer(psb_ipk_) :: i + + if (trans_ == 'C') then + if (beta == dzero) then + + if (alpha == dzero) then + y(1:n_row) = dzero + else if (alpha == done) then + do i=1, n_row + y(i) = (d(i)) * x(i) + end do + else if (alpha == -done) then + do i=1, n_row + y(i) = -(d(i)) * x(i) + end do + else + do i=1, n_row + y(i) = alpha * (d(i)) * x(i) + end do + end if + + else if (beta == done) then + + if (alpha == dzero) then + !y(1:n_row) = dzero + else if (alpha == done) then + do i=1, n_row + y(i) = (d(i)) * x(i) + y(i) + end do + else if (alpha == -done) then + do i=1, n_row + y(i) = -(d(i)) * x(i) + y(i) + end do + else + do i=1, n_row + y(i) = alpha * (d(i)) * x(i) + y(i) + end do + end if + + else if (beta == -done) then + + if (alpha == dzero) then + y(1:n_row) = -y(1:n_row) + else if (alpha == done) then + do i=1, n_row + y(i) = (d(i)) * x(i) - y(i) + end do + else if (alpha == -done) then + do i=1, n_row + y(i) = -(d(i)) * x(i) - y(i) + end do + else + do i=1, n_row + y(i) = alpha * (d(i)) * x(i) - y(i) + end do + end if + + else + + if (alpha == dzero) then + y(1:n_row) = beta *y(1:n_row) + else if (alpha == done) then + do i=1, n_row + y(i) = (d(i)) * x(i) + beta*y(i) + end do + else if (alpha == -done) then + do i=1, n_row + y(i) = -(d(i)) * x(i) + beta*y(i) + end do + else + do i=1, n_row + y(i) = alpha * (d(i)) * x(i) + beta*y(i) + end do + end if + + end if + + else if (trans_ /= 'C') then + + if (beta == dzero) then + + if (alpha == dzero) then + y(1:n_row) = dzero + else if (alpha == done) then + do i=1, n_row + y(i) = d(i) * x(i) + end do + else if (alpha == -done) then + do i=1, n_row + y(i) = -d(i) * x(i) + end do + else + do i=1, n_row + y(i) = alpha * d(i) * x(i) + end do + end if + + else if (beta == done) then + + if (alpha == dzero) then + !y(1:n_row) = dzero + else if (alpha == done) then + do i=1, n_row + y(i) = d(i) * x(i) + y(i) + end do + else if (alpha == -done) then + do i=1, n_row + y(i) = -d(i) * x(i) + y(i) + end do + else + do i=1, n_row + y(i) = alpha * d(i) * x(i) + y(i) + end do + end if + + else if (beta == -done) then + + if (alpha == dzero) then + y(1:n_row) = -y(1:n_row) + else if (alpha == done) then + do i=1, n_row + y(i) = d(i) * x(i) - y(i) + end do + else if (alpha == -done) then + do i=1, n_row + y(i) = -d(i) * x(i) - y(i) + end do + else + do i=1, n_row + y(i) = alpha * d(i) * x(i) - y(i) + end do + end if + + else + + if (alpha == dzero) then + y(1:n_row) = beta *y(1:n_row) + else if (alpha == done) then + do i=1, n_row + y(i) = d(i) * x(i) + beta*y(i) + end do + else if (alpha == -done) then + do i=1, n_row + y(i) = -d(i) * x(i) + beta*y(i) + end do + else + do i=1, n_row + y(i) = alpha * d(i) * x(i) + beta*y(i) + end do + end if + + end if + + end if + + end subroutine inner_mlt +end subroutine amg_d_jac_solver_apply diff --git a/amgprec/impl/solver/amg_d_jac_solver_apply_vect.f90 b/amgprec/impl/solver/amg_d_jac_solver_apply_vect.f90 new file mode 100644 index 00000000..bc35f7ea --- /dev/null +++ b/amgprec/impl/solver/amg_d_jac_solver_apply_vect.f90 @@ -0,0 +1,190 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_d_jac_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,& + & work,wv,info,init,initu) + + use psb_base_mod + use amg_d_diag_solver + use psb_base_krylov_conv_mod, only : log_conv + use amg_d_jac_solver, amg_protect_name => amg_d_jac_solver_apply_vect + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(amg_d_jac_solver_type), intent(inout) :: sv + type(psb_d_vect_type),intent(inout) :: x + type(psb_d_vect_type),intent(inout) :: y + real(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_dpk_),target, intent(inout) :: work(:) + type(psb_d_vect_type),intent(inout) :: wv(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_d_vect_type),intent(inout), optional :: initu + ! + integer(psb_ipk_) :: n_row,n_col, sweeps + type(psb_d_vect_type) :: tx, ty, r + real(psb_dpk_), pointer :: aux(:) + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, i, err_act + character :: trans_, init_ + real(psb_dpk_) :: res, resdenum + character(len=20) :: name='d_jac_solver_apply_v' + + call psb_erractionsave(err_act) + + info = psb_success_ + ctxt = desc_data%get_context() + call psb_info(ctxt,me,np) + + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T','C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + sweeps = sv%sweeps + if (4*n_col <= size(work)) then + aux => work(:) + else + allocate(aux(4*n_col),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/4*n_col,izero,izero,izero,izero/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + endif + + if (sweeps >= 0) then + ! + ! This means we are dealing with a pure Jacobi smoother/solver. + ! + associate(tx => wv(1), ty => wv(2)) + select case (init_) + case('Z') + + call ty%mlt(done,sv%dv,x,dzero,info,conjgx=trans_) + + 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,sv%a,ty,done,tx,desc_data,info,& + & work=aux,trans=trans_, doswap=.false.) + call ty%mlt(done,sv%dv,tx,dzero,info,conjgx=trans_) + + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(done,x,dzero,tx,desc_data,info) + call psb_geaxpby(done,initu,dzero,ty,desc_data,info) + call psb_spmm(-done,sv%a,ty,done,tx,desc_data,info,& + & work=aux,trans=trans_, doswap=.false.) + call ty%mlt(done,sv%dv,tx,dzero,info,conjgx=trans_) + + 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)), + ! where is the diagonal and A the matrix. + ! + call psb_geaxpby(done,x,dzero,tx,desc_data,info) + call psb_spmm(-done,sv%a,ty,done,tx,desc_data,info,& + & work=aux,trans=trans_, doswap=.false.) + if (info /= psb_success_) exit + call ty%mlt(done,sv%dv,tx,done,info,conjgx=trans_) + if (info /= psb_success_) exit + end do + + + if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) + + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='subsolve with Jacobi sweeps > 1') + goto 9999 + end if + + + end associate + + + else + + info = psb_err_iarg_neg_ + call psb_errpush(info,name,& + & i_err=(/itwo,sweeps,izero,izero,izero/)) + goto 9999 + + end if + + if (.not.(4*n_col <= size(work))) then + deallocate(aux) + endif + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine amg_d_jac_solver_apply_vect diff --git a/amgprec/impl/solver/amg_d_jac_solver_bld.f90 b/amgprec/impl/solver/amg_d_jac_solver_bld.f90 new file mode 100644 index 00000000..4effcca5 --- /dev/null +++ b/amgprec/impl/solver/amg_d_jac_solver_bld.f90 @@ -0,0 +1,125 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_d_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) + + use psb_base_mod + use amg_d_jac_solver, amg_protect_name => amg_d_jac_solver_bld + + Implicit None + + ! Arguments + type(psb_dspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(amg_d_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + type(psb_dspmat_type), intent(in), target, optional :: b + class(psb_d_base_sparse_mat), intent(in), optional :: amold + class(psb_d_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + ! Local variables + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota + real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) + real(psb_dpk_), allocatable :: tdb(:) + type(psb_d_csr_sparse_mat) :: tcsr + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, i, err_act, debug_unit, debug_level + character(len=20) :: name='d_jac_solver_bld', ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + n_row = desc_a%get_local_rows() + nrow_a = a%get_nrows() + if (present(b)) then + info=psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end if + call a%cp_to(tcsr) + call sv%a%mv_from(tcsr) + if (present(amold)) call sv%a%cscnv(info,mold=amold) + + sv%d = a%get_diag(info) + if (info == psb_success_) call psb_realloc(n_row,sv%d,info) + if (present(b)) then + tdb=b%get_diag(info) + if (size(tdb)+nrow_a > n_row) call psb_realloc(nrow_a+size(tdb),sv%d,info) + if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) + end if + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='get_diag') + goto 9999 + end if + + do i=1,n_row + if (sv%d(i) == dzero) then + sv%d(i) = done + else + sv%d(i) = done/sv%d(i) + end if + end do + allocate(sv%dv,stat=info) + if (info == psb_success_) then + call sv%dv%bld(sv%d) + if (present(vmold)) call sv%dv%cnv(vmold) + call sv%dv%sync() + else + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='Allocate sv%dv') + goto 9999 + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine amg_d_jac_solver_bld + + diff --git a/amgprec/impl/solver/amg_d_jac_solver_clear_data.f90 b/amgprec/impl/solver/amg_d_jac_solver_clear_data.f90 new file mode 100644 index 00000000..63073ffd --- /dev/null +++ b/amgprec/impl/solver/amg_d_jac_solver_clear_data.f90 @@ -0,0 +1,65 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_d_jac_solver_clear_data(sv,info) + + use psb_base_mod + use amg_d_jac_solver, amg_protect_name => amg_d_jac_solver_clear_data + + Implicit None + + ! Arguments + class(amg_d_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + ! Local variables + integer(psb_ipk_) :: err_act + + info=psb_success_ + call psb_erractionsave(err_act) + + call sv%a%free() + call sv%dv%free(info) + if ((info==0).and.allocated(sv%d)) deallocate(sv%d,stat=info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine amg_d_jac_solver_clear_data diff --git a/amgprec/impl/solver/amg_d_jac_solver_clone.f90 b/amgprec/impl/solver/amg_d_jac_solver_clone.f90 new file mode 100644 index 00000000..5213e007 --- /dev/null +++ b/amgprec/impl/solver/amg_d_jac_solver_clone.f90 @@ -0,0 +1,88 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_d_jac_solver_clone(sv,svout,info) + + use psb_base_mod + use amg_d_jac_solver, amg_protect_name => amg_d_jac_solver_clone + + Implicit None + + ! Arguments + class(amg_d_jac_solver_type), intent(inout) :: sv + class(amg_d_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info + ! Local variables + integer(psb_ipk_) :: err_act + + + info=psb_success_ + call psb_erractionsave(err_act) + if (allocated(svout)) then + call svout%free(info) + if (info == psb_success_) deallocate(svout, stat=info) + end if + if (info == psb_success_) & + & allocate(svout, mold=sv, stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + + select type(svo => svout) + class is (amg_d_jac_solver_type) + svo%sweeps = sv%sweeps + svo%eps = sv%eps + if (info == psb_success_) & + & call sv%a%clone(svo%a,info) + if (info == psb_success_) & + & call sv%dv%clone(svo%dv,info) + svo%d = sv%d + + class default + info = psb_err_internal_error_ + end select + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine amg_d_jac_solver_clone diff --git a/amgprec/impl/solver/amg_d_jac_solver_clone_settings.f90 b/amgprec/impl/solver/amg_d_jac_solver_clone_settings.f90 new file mode 100644 index 00000000..d041ce32 --- /dev/null +++ b/amgprec/impl/solver/amg_d_jac_solver_clone_settings.f90 @@ -0,0 +1,69 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_d_jac_solver_clone_settings(sv,svout,info) + + use psb_base_mod + use amg_d_jac_solver, amg_protect_name => amg_d_jac_solver_clone_settings + Implicit None + ! Arguments + class(amg_d_jac_solver_type), intent(inout) :: sv + class(amg_d_base_solver_type), intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='d_jac_solver_clone_settings' + + call psb_erractionsave(err_act) + + select type(svout) + class is(amg_d_jac_solver_type) + svout%sweeps = sv%sweeps + svout%eps = sv%eps + + class default + info = psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine amg_d_jac_solver_clone_settings diff --git a/amgprec/impl/solver/amg_d_jac_solver_cnv.f90 b/amgprec/impl/solver/amg_d_jac_solver_cnv.f90 new file mode 100644 index 00000000..4d8283fe --- /dev/null +++ b/amgprec/impl/solver/amg_d_jac_solver_cnv.f90 @@ -0,0 +1,72 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_d_jac_solver_cnv(sv,info,amold,vmold,imold) + + use psb_base_mod + use amg_d_jac_solver, amg_protect_name => amg_d_jac_solver_cnv + + Implicit None + + ! Arguments + class(amg_d_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_sparse_mat), intent(in), optional :: amold + class(psb_d_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + ! Local variables + integer(psb_ipk_) :: err_act, debug_unit, debug_level + character(len=20) :: name='d_jac_solver_cnv', ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (present(amold)) call sv%a%cscnv(info,mold=amold) + if ((info==0).and.present(vmold)) call sv%dv%cnv(mold=vmold) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine amg_d_jac_solver_cnv diff --git a/amgprec/impl/solver/amg_d_jac_solver_dmp.f90 b/amgprec/impl/solver/amg_d_jac_solver_dmp.f90 new file mode 100644 index 00000000..014b1c1c --- /dev/null +++ b/amgprec/impl/solver/amg_d_jac_solver_dmp.f90 @@ -0,0 +1,107 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_d_jac_solver_dmp(sv,desc,level,info,prefix,head,solver,global_num) + + use psb_base_mod + use amg_d_jac_solver, amg_protect_name => amg_d_jac_solver_dmp + implicit none + class(amg_d_jac_solver_type), intent(in) :: sv + type(psb_desc_type), intent(in) :: desc + integer(psb_ipk_), intent(in) :: level + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: solver, global_num + integer(psb_ipk_) :: i, j, il1, iln, lname, lev + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np + character(len=80) :: prefix_ + character(len=120) :: fname ! len should be at least 20 more than + logical :: solver_, global_num_ + integer(psb_lpk_), allocatable :: iv(:) + ! len of prefix_ + + info = 0 + + ctxt = desc%get_context() + call psb_info(ctxt,iam,np) + + if (present(solver)) then + solver_ = solver + else + solver_ = .false. + end if + if (present(global_num)) then + global_num_ = global_num + else + global_num_ = .false. + end if + + + if (solver_) then + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_slv_d" + end if + lname = len_trim(prefix_) + fname = trim(prefix_) + write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam + lname = lname + 5 + + if (global_num_) then + iv = desc%get_global_indices(owned=.false.) + + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx' + if (sv%a%is_asb()) & + & call sv%a%print(fname,head=head,iv=iv) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_diag.mtx' + if (allocated(sv%dv)) & + & call psb_geprt(fname,sv%dv%v%v,head=head) + + else + + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx' + if (sv%a%is_asb()) & + & call sv%a%print(fname,head=head) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_diag.mtx' + if (allocated(sv%dv)) & + & call psb_geprt(fname,sv%dv%v%v,head=head) + end if + end if + +end subroutine amg_d_jac_solver_dmp diff --git a/amgprec/impl/solver/amg_d_l1_jac_solver_bld.f90 b/amgprec/impl/solver/amg_d_l1_jac_solver_bld.f90 new file mode 100644 index 00000000..c5979ccd --- /dev/null +++ b/amgprec/impl/solver/amg_d_l1_jac_solver_bld.f90 @@ -0,0 +1,128 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_d_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) + + use psb_base_mod + use amg_d_jac_solver, amg_protect_name => amg_d_l1_jac_solver_bld + + Implicit None + + ! Arguments + type(psb_dspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(amg_d_l1_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + type(psb_dspmat_type), intent(in), target, optional :: b + class(psb_d_base_sparse_mat), intent(in), optional :: amold + class(psb_d_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + ! Local variables + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota + real(psb_dpk_), allocatable :: tdb(:), tx(:),ty(:) + type(psb_d_csr_sparse_mat) :: tcsr + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, i, err_act, debug_unit, debug_level + character(len=20) :: name='d_l1_jac_solver_bld', ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + n_row = desc_a%get_local_rows() + nrow_a = a%get_nrows() + if (present(b)) then + info=psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end if + + call a%cp_to(tcsr) + call sv%a%mv_from(tcsr) + if (present(amold)) call sv%a%cscnv(info,mold=amold) + + tx = a%get_diag(info) + sv%d = a%arwsum(info) + sv%d(:) = sv%d(:) - abs(tx(:)) + tx(:) + if (info == psb_success_) call psb_realloc(n_row,sv%d,info) + if (present(b)) then + tdb=b%arwsum(info) + ty =b%get_diag(info) + if (size(tdb)+nrow_a > n_row) call psb_realloc(nrow_a+size(tdb),sv%d,info) + if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) - abs(ty(:)) + ty(:) + end if + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='get_diag') + goto 9999 + end if + + do i=1,n_row + if (sv%d(i) == dzero) then + sv%d(i) = done + else + sv%d(i) = done/sv%d(i) + end if + end do + allocate(sv%dv,stat=info) + if (info == psb_success_) then + call sv%dv%bld(sv%d) + if (present(vmold)) call sv%dv%cnv(vmold) + call sv%dv%sync() + else + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='Allocate sv%dv') + goto 9999 + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine amg_d_l1_jac_solver_bld + + diff --git a/amgprec/impl/solver/amg_s_base_ainv_solver_cnv.f90 b/amgprec/impl/solver/amg_s_base_ainv_solver_cnv.f90 index 3a32298f..cb1771dc 100644 --- a/amgprec/impl/solver/amg_s_base_ainv_solver_cnv.f90 +++ b/amgprec/impl/solver/amg_s_base_ainv_solver_cnv.f90 @@ -47,7 +47,6 @@ subroutine amg_s_base_ainv_solver_cnv(sv,info,amold,vmold,imold) class(psb_i_base_vect_type), intent(in), optional :: imold !local - integer(psb_ipk_) :: i, j, il1, iln, lname, lev integer(psb_ipk_) :: iam, np type(psb_ctxt_type) :: ctxt character(len=80) :: prefix_ diff --git a/amgprec/impl/solver/amg_s_diag_solver_bld.f90 b/amgprec/impl/solver/amg_s_diag_solver_bld.f90 index 6d4e33df..54ec6bc4 100644 --- a/amgprec/impl/solver/amg_s_diag_solver_bld.f90 +++ b/amgprec/impl/solver/amg_s_diag_solver_bld.f90 @@ -132,8 +132,7 @@ subroutine amg_s_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) class(psb_i_base_vect_type), intent(in), optional :: imold ! Local variables integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota - real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) - real(psb_spk_), allocatable :: tdb(:) + real(psb_spk_), allocatable :: tdb(:), tx(:), ty(:) type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np, me, i, err_act, debug_unit, debug_level character(len=20) :: name='s_l1_diag_solver_bld', ch_err @@ -151,12 +150,15 @@ subroutine amg_s_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) n_row = desc_a%get_local_rows() nrow_a = a%get_nrows() + tx = a%get_diag(info) sv%d = a%arwsum(info) + sv%d(:) = sv%d(:) - abs(tx(:)) + tx(:) if (info == psb_success_) call psb_realloc(n_row,sv%d,info) if (present(b)) then tdb=b%arwsum(info) + ty =b%get_diag(info) if (size(tdb)+nrow_a > n_row) call psb_realloc(nrow_a+size(tdb),sv%d,info) - if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) + if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) - abs(ty(:)) + ty(:) end if if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='arwsum') diff --git a/amgprec/impl/solver/amg_s_jac_solver_apply.f90 b/amgprec/impl/solver/amg_s_jac_solver_apply.f90 new file mode 100644 index 00000000..500391c8 --- /dev/null +++ b/amgprec/impl/solver/amg_s_jac_solver_apply.f90 @@ -0,0 +1,352 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_s_jac_solver_apply(alpha,sv,x,beta,y,desc_data,trans,& + & work,info,init,initu) + + use psb_base_mod + use amg_s_diag_solver + use psb_base_krylov_conv_mod, only : log_conv + use amg_s_jac_solver, amg_protect_name => amg_s_jac_solver_apply + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(amg_s_jac_solver_type), intent(inout) :: sv + real(psb_spk_),intent(inout) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + real(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_spk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_spk_),intent(inout), optional :: initu(:) + ! + integer(psb_ipk_) :: n_row,n_col, sweeps + real(psb_spk_), pointer :: aux(:) + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, i, err_act + character :: trans_, init_ + real(psb_dpk_) :: res, resdenum + character(len=20) :: name='s_jac_solver_apply_v' + + call psb_erractionsave(err_act) + + info = psb_success_ + ctxt = desc_data%get_context() + call psb_info(ctxt,me,np) + + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T','C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + sweeps = sv%sweeps + if (4*n_col <= size(work)) then + aux => work(:) + else + allocate(aux(4*n_col),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/4*n_col,izero,izero,izero,izero/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + endif + + if (sweeps >= 0) then + ! + ! This means we are dealing with a pure Jacobi smoother/solver. + ! + associate(tx => aux(1:n_col), ty => aux(n_col+1:2*n_col)) + select case (init_) + case('Z') + + call inner_mlt(n_row,sone,sv%dv%v%v,x,szero,ty,trans=trans_) + + 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,sv%a,ty,sone,tx,desc_data,info,& + & work=aux,trans=trans_, doswap=.false.) + call inner_mlt(n_row,sone,sv%dv%v%v,tx,szero,ty,trans=trans_) + + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(sone,x,szero,tx,desc_data,info) + call psb_geaxpby(sone,initu,szero,ty,desc_data,info) + call psb_spmm(-sone,sv%a,ty,sone,tx,desc_data,info,& + & work=aux,trans=trans_, doswap=.false.) + call inner_mlt(n_row,sone,sv%dv%v%v,tx,szero,ty,trans=trans_) + + 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)), + ! where is the diagonal and A the matrix. + ! + call psb_geaxpby(sone,x,szero,tx,desc_data,info) + call psb_spmm(-sone,sv%a,ty,sone,tx,desc_data,info,& + & work=aux,trans=trans_, doswap=.false.) + if (info /= psb_success_) exit + call inner_mlt(n_row,sone,sv%dv%v%v,tx,sone,ty,trans=trans_) + if (info /= psb_success_) exit + end do + + if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) + + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='subsolve with Jacobi sweeps > 1') + goto 9999 + end if + + + end associate + + + else + + info = psb_err_iarg_neg_ + call psb_errpush(info,name,& + & i_err=(/itwo,sweeps,izero,izero,izero/)) + goto 9999 + + end if + + if (.not.(4*n_col <= size(work))) then + deallocate(aux) + endif + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +contains + subroutine inner_mlt(n_row,alpha,d,x,beta,y,trans) + implicit none + integer(psb_ipk_),intent(in) :: n_row + real(psb_spk_), intent(inout) :: d(:) + real(psb_spk_),intent(inout) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + real(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + + integer(psb_ipk_) :: i + + if (trans_ == 'C') then + if (beta == szero) then + + if (alpha == szero) then + y(1:n_row) = szero + else if (alpha == sone) then + do i=1, n_row + y(i) = (d(i)) * x(i) + end do + else if (alpha == -sone) then + do i=1, n_row + y(i) = -(d(i)) * x(i) + end do + else + do i=1, n_row + y(i) = alpha * (d(i)) * x(i) + end do + end if + + else if (beta == sone) then + + if (alpha == szero) then + !y(1:n_row) = szero + else if (alpha == sone) then + do i=1, n_row + y(i) = (d(i)) * x(i) + y(i) + end do + else if (alpha == -sone) then + do i=1, n_row + y(i) = -(d(i)) * x(i) + y(i) + end do + else + do i=1, n_row + y(i) = alpha * (d(i)) * x(i) + y(i) + end do + end if + + else if (beta == -sone) then + + if (alpha == szero) then + y(1:n_row) = -y(1:n_row) + else if (alpha == sone) then + do i=1, n_row + y(i) = (d(i)) * x(i) - y(i) + end do + else if (alpha == -sone) then + do i=1, n_row + y(i) = -(d(i)) * x(i) - y(i) + end do + else + do i=1, n_row + y(i) = alpha * (d(i)) * x(i) - y(i) + end do + end if + + else + + if (alpha == szero) then + y(1:n_row) = beta *y(1:n_row) + else if (alpha == sone) then + do i=1, n_row + y(i) = (d(i)) * x(i) + beta*y(i) + end do + else if (alpha == -sone) then + do i=1, n_row + y(i) = -(d(i)) * x(i) + beta*y(i) + end do + else + do i=1, n_row + y(i) = alpha * (d(i)) * x(i) + beta*y(i) + end do + end if + + end if + + else if (trans_ /= 'C') then + + if (beta == szero) then + + if (alpha == szero) then + y(1:n_row) = szero + else if (alpha == sone) then + do i=1, n_row + y(i) = d(i) * x(i) + end do + else if (alpha == -sone) then + do i=1, n_row + y(i) = -d(i) * x(i) + end do + else + do i=1, n_row + y(i) = alpha * d(i) * x(i) + end do + end if + + else if (beta == sone) then + + if (alpha == szero) then + !y(1:n_row) = szero + else if (alpha == sone) then + do i=1, n_row + y(i) = d(i) * x(i) + y(i) + end do + else if (alpha == -sone) then + do i=1, n_row + y(i) = -d(i) * x(i) + y(i) + end do + else + do i=1, n_row + y(i) = alpha * d(i) * x(i) + y(i) + end do + end if + + else if (beta == -sone) then + + if (alpha == szero) then + y(1:n_row) = -y(1:n_row) + else if (alpha == sone) then + do i=1, n_row + y(i) = d(i) * x(i) - y(i) + end do + else if (alpha == -sone) then + do i=1, n_row + y(i) = -d(i) * x(i) - y(i) + end do + else + do i=1, n_row + y(i) = alpha * d(i) * x(i) - y(i) + end do + end if + + else + + if (alpha == szero) then + y(1:n_row) = beta *y(1:n_row) + else if (alpha == sone) then + do i=1, n_row + y(i) = d(i) * x(i) + beta*y(i) + end do + else if (alpha == -sone) then + do i=1, n_row + y(i) = -d(i) * x(i) + beta*y(i) + end do + else + do i=1, n_row + y(i) = alpha * d(i) * x(i) + beta*y(i) + end do + end if + + end if + + end if + + end subroutine inner_mlt +end subroutine amg_s_jac_solver_apply diff --git a/amgprec/impl/solver/amg_s_jac_solver_apply_vect.f90 b/amgprec/impl/solver/amg_s_jac_solver_apply_vect.f90 new file mode 100644 index 00000000..da84ffea --- /dev/null +++ b/amgprec/impl/solver/amg_s_jac_solver_apply_vect.f90 @@ -0,0 +1,190 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_s_jac_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,& + & work,wv,info,init,initu) + + use psb_base_mod + use amg_s_diag_solver + use psb_base_krylov_conv_mod, only : log_conv + use amg_s_jac_solver, amg_protect_name => amg_s_jac_solver_apply_vect + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(amg_s_jac_solver_type), intent(inout) :: sv + type(psb_s_vect_type),intent(inout) :: x + type(psb_s_vect_type),intent(inout) :: y + real(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_spk_),target, intent(inout) :: work(:) + type(psb_s_vect_type),intent(inout) :: wv(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_s_vect_type),intent(inout), optional :: initu + ! + integer(psb_ipk_) :: n_row,n_col, sweeps + type(psb_s_vect_type) :: tx, ty, r + real(psb_spk_), pointer :: aux(:) + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, i, err_act + character :: trans_, init_ + real(psb_dpk_) :: res, resdenum + character(len=20) :: name='s_jac_solver_apply_v' + + call psb_erractionsave(err_act) + + info = psb_success_ + ctxt = desc_data%get_context() + call psb_info(ctxt,me,np) + + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T','C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + sweeps = sv%sweeps + if (4*n_col <= size(work)) then + aux => work(:) + else + allocate(aux(4*n_col),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/4*n_col,izero,izero,izero,izero/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + endif + + if (sweeps >= 0) then + ! + ! This means we are dealing with a pure Jacobi smoother/solver. + ! + associate(tx => wv(1), ty => wv(2)) + select case (init_) + case('Z') + + call ty%mlt(sone,sv%dv,x,szero,info,conjgx=trans_) + + 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,sv%a,ty,sone,tx,desc_data,info,& + & work=aux,trans=trans_, doswap=.false.) + call ty%mlt(sone,sv%dv,tx,szero,info,conjgx=trans_) + + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(sone,x,szero,tx,desc_data,info) + call psb_geaxpby(sone,initu,szero,ty,desc_data,info) + call psb_spmm(-sone,sv%a,ty,sone,tx,desc_data,info,& + & work=aux,trans=trans_, doswap=.false.) + call ty%mlt(sone,sv%dv,tx,szero,info,conjgx=trans_) + + 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)), + ! where is the diagonal and A the matrix. + ! + call psb_geaxpby(sone,x,szero,tx,desc_data,info) + call psb_spmm(-sone,sv%a,ty,sone,tx,desc_data,info,& + & work=aux,trans=trans_, doswap=.false.) + if (info /= psb_success_) exit + call ty%mlt(sone,sv%dv,tx,sone,info,conjgx=trans_) + if (info /= psb_success_) exit + end do + + + if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) + + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='subsolve with Jacobi sweeps > 1') + goto 9999 + end if + + + end associate + + + else + + info = psb_err_iarg_neg_ + call psb_errpush(info,name,& + & i_err=(/itwo,sweeps,izero,izero,izero/)) + goto 9999 + + end if + + if (.not.(4*n_col <= size(work))) then + deallocate(aux) + endif + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine amg_s_jac_solver_apply_vect diff --git a/amgprec/impl/solver/amg_s_jac_solver_bld.f90 b/amgprec/impl/solver/amg_s_jac_solver_bld.f90 new file mode 100644 index 00000000..0af2cb78 --- /dev/null +++ b/amgprec/impl/solver/amg_s_jac_solver_bld.f90 @@ -0,0 +1,125 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_s_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) + + use psb_base_mod + use amg_s_jac_solver, amg_protect_name => amg_s_jac_solver_bld + + Implicit None + + ! Arguments + type(psb_sspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(amg_s_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + type(psb_sspmat_type), intent(in), target, optional :: b + class(psb_s_base_sparse_mat), intent(in), optional :: amold + class(psb_s_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + ! Local variables + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota + real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + real(psb_spk_), allocatable :: tdb(:) + type(psb_s_csr_sparse_mat) :: tcsr + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, i, err_act, debug_unit, debug_level + character(len=20) :: name='s_jac_solver_bld', ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + n_row = desc_a%get_local_rows() + nrow_a = a%get_nrows() + if (present(b)) then + info=psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end if + call a%cp_to(tcsr) + call sv%a%mv_from(tcsr) + if (present(amold)) call sv%a%cscnv(info,mold=amold) + + sv%d = a%get_diag(info) + if (info == psb_success_) call psb_realloc(n_row,sv%d,info) + if (present(b)) then + tdb=b%get_diag(info) + if (size(tdb)+nrow_a > n_row) call psb_realloc(nrow_a+size(tdb),sv%d,info) + if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) + end if + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='get_diag') + goto 9999 + end if + + do i=1,n_row + if (sv%d(i) == szero) then + sv%d(i) = sone + else + sv%d(i) = sone/sv%d(i) + end if + end do + allocate(sv%dv,stat=info) + if (info == psb_success_) then + call sv%dv%bld(sv%d) + if (present(vmold)) call sv%dv%cnv(vmold) + call sv%dv%sync() + else + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='Allocate sv%dv') + goto 9999 + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine amg_s_jac_solver_bld + + diff --git a/amgprec/impl/solver/amg_s_jac_solver_clear_data.f90 b/amgprec/impl/solver/amg_s_jac_solver_clear_data.f90 new file mode 100644 index 00000000..d4bdb7b8 --- /dev/null +++ b/amgprec/impl/solver/amg_s_jac_solver_clear_data.f90 @@ -0,0 +1,65 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_s_jac_solver_clear_data(sv,info) + + use psb_base_mod + use amg_s_jac_solver, amg_protect_name => amg_s_jac_solver_clear_data + + Implicit None + + ! Arguments + class(amg_s_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + ! Local variables + integer(psb_ipk_) :: err_act + + info=psb_success_ + call psb_erractionsave(err_act) + + call sv%a%free() + call sv%dv%free(info) + if ((info==0).and.allocated(sv%d)) deallocate(sv%d,stat=info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine amg_s_jac_solver_clear_data diff --git a/amgprec/impl/solver/amg_s_jac_solver_clone.f90 b/amgprec/impl/solver/amg_s_jac_solver_clone.f90 new file mode 100644 index 00000000..9026f90f --- /dev/null +++ b/amgprec/impl/solver/amg_s_jac_solver_clone.f90 @@ -0,0 +1,88 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_s_jac_solver_clone(sv,svout,info) + + use psb_base_mod + use amg_s_jac_solver, amg_protect_name => amg_s_jac_solver_clone + + Implicit None + + ! Arguments + class(amg_s_jac_solver_type), intent(inout) :: sv + class(amg_s_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info + ! Local variables + integer(psb_ipk_) :: err_act + + + info=psb_success_ + call psb_erractionsave(err_act) + if (allocated(svout)) then + call svout%free(info) + if (info == psb_success_) deallocate(svout, stat=info) + end if + if (info == psb_success_) & + & allocate(svout, mold=sv, stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + + select type(svo => svout) + class is (amg_s_jac_solver_type) + svo%sweeps = sv%sweeps + svo%eps = sv%eps + if (info == psb_success_) & + & call sv%a%clone(svo%a,info) + if (info == psb_success_) & + & call sv%dv%clone(svo%dv,info) + svo%d = sv%d + + class default + info = psb_err_internal_error_ + end select + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine amg_s_jac_solver_clone diff --git a/amgprec/impl/solver/amg_s_jac_solver_clone_settings.f90 b/amgprec/impl/solver/amg_s_jac_solver_clone_settings.f90 new file mode 100644 index 00000000..43363944 --- /dev/null +++ b/amgprec/impl/solver/amg_s_jac_solver_clone_settings.f90 @@ -0,0 +1,69 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_s_jac_solver_clone_settings(sv,svout,info) + + use psb_base_mod + use amg_s_jac_solver, amg_protect_name => amg_s_jac_solver_clone_settings + Implicit None + ! Arguments + class(amg_s_jac_solver_type), intent(inout) :: sv + class(amg_s_base_solver_type), intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='s_jac_solver_clone_settings' + + call psb_erractionsave(err_act) + + select type(svout) + class is(amg_s_jac_solver_type) + svout%sweeps = sv%sweeps + svout%eps = sv%eps + + class default + info = psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine amg_s_jac_solver_clone_settings diff --git a/amgprec/impl/solver/amg_s_jac_solver_cnv.f90 b/amgprec/impl/solver/amg_s_jac_solver_cnv.f90 new file mode 100644 index 00000000..7d7dd4e4 --- /dev/null +++ b/amgprec/impl/solver/amg_s_jac_solver_cnv.f90 @@ -0,0 +1,72 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_s_jac_solver_cnv(sv,info,amold,vmold,imold) + + use psb_base_mod + use amg_s_jac_solver, amg_protect_name => amg_s_jac_solver_cnv + + Implicit None + + ! Arguments + class(amg_s_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_sparse_mat), intent(in), optional :: amold + class(psb_s_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + ! Local variables + integer(psb_ipk_) :: err_act, debug_unit, debug_level + character(len=20) :: name='s_jac_solver_cnv', ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (present(amold)) call sv%a%cscnv(info,mold=amold) + if ((info==0).and.present(vmold)) call sv%dv%cnv(mold=vmold) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine amg_s_jac_solver_cnv diff --git a/amgprec/impl/solver/amg_s_jac_solver_dmp.f90 b/amgprec/impl/solver/amg_s_jac_solver_dmp.f90 new file mode 100644 index 00000000..5b0e724b --- /dev/null +++ b/amgprec/impl/solver/amg_s_jac_solver_dmp.f90 @@ -0,0 +1,107 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_s_jac_solver_dmp(sv,desc,level,info,prefix,head,solver,global_num) + + use psb_base_mod + use amg_s_jac_solver, amg_protect_name => amg_s_jac_solver_dmp + implicit none + class(amg_s_jac_solver_type), intent(in) :: sv + type(psb_desc_type), intent(in) :: desc + integer(psb_ipk_), intent(in) :: level + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: solver, global_num + integer(psb_ipk_) :: i, j, il1, iln, lname, lev + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np + character(len=80) :: prefix_ + character(len=120) :: fname ! len should be at least 20 more than + logical :: solver_, global_num_ + integer(psb_lpk_), allocatable :: iv(:) + ! len of prefix_ + + info = 0 + + ctxt = desc%get_context() + call psb_info(ctxt,iam,np) + + if (present(solver)) then + solver_ = solver + else + solver_ = .false. + end if + if (present(global_num)) then + global_num_ = global_num + else + global_num_ = .false. + end if + + + if (solver_) then + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_slv_s" + end if + lname = len_trim(prefix_) + fname = trim(prefix_) + write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam + lname = lname + 5 + + if (global_num_) then + iv = desc%get_global_indices(owned=.false.) + + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx' + if (sv%a%is_asb()) & + & call sv%a%print(fname,head=head,iv=iv) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_diag.mtx' + if (allocated(sv%dv)) & + & call psb_geprt(fname,sv%dv%v%v,head=head) + + else + + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx' + if (sv%a%is_asb()) & + & call sv%a%print(fname,head=head) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_diag.mtx' + if (allocated(sv%dv)) & + & call psb_geprt(fname,sv%dv%v%v,head=head) + end if + end if + +end subroutine amg_s_jac_solver_dmp diff --git a/amgprec/impl/solver/amg_s_l1_jac_solver_bld.f90 b/amgprec/impl/solver/amg_s_l1_jac_solver_bld.f90 new file mode 100644 index 00000000..d7663326 --- /dev/null +++ b/amgprec/impl/solver/amg_s_l1_jac_solver_bld.f90 @@ -0,0 +1,128 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_s_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) + + use psb_base_mod + use amg_s_jac_solver, amg_protect_name => amg_s_l1_jac_solver_bld + + Implicit None + + ! Arguments + type(psb_sspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(amg_s_l1_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + type(psb_sspmat_type), intent(in), target, optional :: b + class(psb_s_base_sparse_mat), intent(in), optional :: amold + class(psb_s_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + ! Local variables + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota + real(psb_spk_), allocatable :: tdb(:), tx(:),ty(:) + type(psb_s_csr_sparse_mat) :: tcsr + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, i, err_act, debug_unit, debug_level + character(len=20) :: name='s_l1_jac_solver_bld', ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + n_row = desc_a%get_local_rows() + nrow_a = a%get_nrows() + if (present(b)) then + info=psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end if + + call a%cp_to(tcsr) + call sv%a%mv_from(tcsr) + if (present(amold)) call sv%a%cscnv(info,mold=amold) + + tx = a%get_diag(info) + sv%d = a%arwsum(info) + sv%d(:) = sv%d(:) - abs(tx(:)) + tx(:) + if (info == psb_success_) call psb_realloc(n_row,sv%d,info) + if (present(b)) then + tdb=b%arwsum(info) + ty =b%get_diag(info) + if (size(tdb)+nrow_a > n_row) call psb_realloc(nrow_a+size(tdb),sv%d,info) + if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) - abs(ty(:)) + ty(:) + end if + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='get_diag') + goto 9999 + end if + + do i=1,n_row + if (sv%d(i) == szero) then + sv%d(i) = sone + else + sv%d(i) = sone/sv%d(i) + end if + end do + allocate(sv%dv,stat=info) + if (info == psb_success_) then + call sv%dv%bld(sv%d) + if (present(vmold)) call sv%dv%cnv(vmold) + call sv%dv%sync() + else + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='Allocate sv%dv') + goto 9999 + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine amg_s_l1_jac_solver_bld + + diff --git a/amgprec/impl/solver/amg_z_base_ainv_solver_cnv.f90 b/amgprec/impl/solver/amg_z_base_ainv_solver_cnv.f90 index 9a344c02..c56749d6 100644 --- a/amgprec/impl/solver/amg_z_base_ainv_solver_cnv.f90 +++ b/amgprec/impl/solver/amg_z_base_ainv_solver_cnv.f90 @@ -47,7 +47,6 @@ subroutine amg_z_base_ainv_solver_cnv(sv,info,amold,vmold,imold) class(psb_i_base_vect_type), intent(in), optional :: imold !local - integer(psb_ipk_) :: i, j, il1, iln, lname, lev integer(psb_ipk_) :: iam, np type(psb_ctxt_type) :: ctxt character(len=80) :: prefix_ diff --git a/amgprec/impl/solver/amg_z_diag_solver_bld.f90 b/amgprec/impl/solver/amg_z_diag_solver_bld.f90 index 5b84bf23..4db78218 100644 --- a/amgprec/impl/solver/amg_z_diag_solver_bld.f90 +++ b/amgprec/impl/solver/amg_z_diag_solver_bld.f90 @@ -132,8 +132,7 @@ subroutine amg_z_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) class(psb_i_base_vect_type), intent(in), optional :: imold ! Local variables integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota - complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) - complex(psb_dpk_), allocatable :: tdb(:) + complex(psb_dpk_), allocatable :: tdb(:), tx(:), ty(:) type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np, me, i, err_act, debug_unit, debug_level character(len=20) :: name='z_l1_diag_solver_bld', ch_err @@ -151,12 +150,15 @@ subroutine amg_z_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) n_row = desc_a%get_local_rows() nrow_a = a%get_nrows() + tx = a%get_diag(info) sv%d = a%arwsum(info) + sv%d(:) = sv%d(:) - abs(tx(:)) + tx(:) if (info == psb_success_) call psb_realloc(n_row,sv%d,info) if (present(b)) then tdb=b%arwsum(info) + ty =b%get_diag(info) if (size(tdb)+nrow_a > n_row) call psb_realloc(nrow_a+size(tdb),sv%d,info) - if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) + if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) - abs(ty(:)) + ty(:) end if if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='arwsum') diff --git a/amgprec/impl/solver/amg_z_jac_solver_apply.f90 b/amgprec/impl/solver/amg_z_jac_solver_apply.f90 new file mode 100644 index 00000000..12288551 --- /dev/null +++ b/amgprec/impl/solver/amg_z_jac_solver_apply.f90 @@ -0,0 +1,352 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_z_jac_solver_apply(alpha,sv,x,beta,y,desc_data,trans,& + & work,info,init,initu) + + use psb_base_mod + use amg_z_diag_solver + use psb_base_krylov_conv_mod, only : log_conv + use amg_z_jac_solver, amg_protect_name => amg_z_jac_solver_apply + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(amg_z_jac_solver_type), intent(inout) :: sv + complex(psb_dpk_),intent(inout) :: x(:) + complex(psb_dpk_),intent(inout) :: y(:) + complex(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + complex(psb_dpk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_dpk_),intent(inout), optional :: initu(:) + ! + integer(psb_ipk_) :: n_row,n_col, sweeps + complex(psb_dpk_), pointer :: aux(:) + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, i, err_act + character :: trans_, init_ + real(psb_dpk_) :: res, resdenum + character(len=20) :: name='z_jac_solver_apply_v' + + call psb_erractionsave(err_act) + + info = psb_success_ + ctxt = desc_data%get_context() + call psb_info(ctxt,me,np) + + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T','C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + sweeps = sv%sweeps + if (4*n_col <= size(work)) then + aux => work(:) + else + allocate(aux(4*n_col),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/4*n_col,izero,izero,izero,izero/),& + & a_err='complex(psb_dpk_)') + goto 9999 + end if + endif + + if (sweeps >= 0) then + ! + ! This means we are dealing with a pure Jacobi smoother/solver. + ! + associate(tx => aux(1:n_col), ty => aux(n_col+1:2*n_col)) + select case (init_) + case('Z') + + call inner_mlt(n_row,zone,sv%dv%v%v,x,zzero,ty,trans=trans_) + + 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,sv%a,ty,zone,tx,desc_data,info,& + & work=aux,trans=trans_, doswap=.false.) + call inner_mlt(n_row,zone,sv%dv%v%v,tx,zzero,ty,trans=trans_) + + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(zone,x,zzero,tx,desc_data,info) + call psb_geaxpby(zone,initu,zzero,ty,desc_data,info) + call psb_spmm(-zone,sv%a,ty,zone,tx,desc_data,info,& + & work=aux,trans=trans_, doswap=.false.) + call inner_mlt(n_row,zone,sv%dv%v%v,tx,zzero,ty,trans=trans_) + + 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)), + ! where is the diagonal and A the matrix. + ! + call psb_geaxpby(zone,x,zzero,tx,desc_data,info) + call psb_spmm(-zone,sv%a,ty,zone,tx,desc_data,info,& + & work=aux,trans=trans_, doswap=.false.) + if (info /= psb_success_) exit + call inner_mlt(n_row,zone,sv%dv%v%v,tx,zone,ty,trans=trans_) + if (info /= psb_success_) exit + end do + + if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) + + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='subsolve with Jacobi sweeps > 1') + goto 9999 + end if + + + end associate + + + else + + info = psb_err_iarg_neg_ + call psb_errpush(info,name,& + & i_err=(/itwo,sweeps,izero,izero,izero/)) + goto 9999 + + end if + + if (.not.(4*n_col <= size(work))) then + deallocate(aux) + endif + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +contains + subroutine inner_mlt(n_row,alpha,d,x,beta,y,trans) + implicit none + integer(psb_ipk_),intent(in) :: n_row + complex(psb_dpk_), intent(inout) :: d(:) + complex(psb_dpk_),intent(inout) :: x(:) + complex(psb_dpk_),intent(inout) :: y(:) + complex(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + + integer(psb_ipk_) :: i + + if (trans_ == 'C') then + if (beta == zzero) then + + if (alpha == zzero) then + y(1:n_row) = zzero + else if (alpha == zone) then + do i=1, n_row + y(i) = conjg(d(i)) * x(i) + end do + else if (alpha == -zone) then + do i=1, n_row + y(i) = -conjg(d(i)) * x(i) + end do + else + do i=1, n_row + y(i) = alpha * conjg(d(i)) * x(i) + end do + end if + + else if (beta == zone) then + + if (alpha == zzero) then + !y(1:n_row) = zzero + else if (alpha == zone) then + do i=1, n_row + y(i) = conjg(d(i)) * x(i) + y(i) + end do + else if (alpha == -zone) then + do i=1, n_row + y(i) = -conjg(d(i)) * x(i) + y(i) + end do + else + do i=1, n_row + y(i) = alpha * conjg(d(i)) * x(i) + y(i) + end do + end if + + else if (beta == -zone) then + + if (alpha == zzero) then + y(1:n_row) = -y(1:n_row) + else if (alpha == zone) then + do i=1, n_row + y(i) = conjg(d(i)) * x(i) - y(i) + end do + else if (alpha == -zone) then + do i=1, n_row + y(i) = -conjg(d(i)) * x(i) - y(i) + end do + else + do i=1, n_row + y(i) = alpha * conjg(d(i)) * x(i) - y(i) + end do + end if + + else + + if (alpha == zzero) then + y(1:n_row) = beta *y(1:n_row) + else if (alpha == zone) then + do i=1, n_row + y(i) = conjg(d(i)) * x(i) + beta*y(i) + end do + else if (alpha == -zone) then + do i=1, n_row + y(i) = -conjg(d(i)) * x(i) + beta*y(i) + end do + else + do i=1, n_row + y(i) = alpha * conjg(d(i)) * x(i) + beta*y(i) + end do + end if + + end if + + else if (trans_ /= 'C') then + + if (beta == zzero) then + + if (alpha == zzero) then + y(1:n_row) = zzero + else if (alpha == zone) then + do i=1, n_row + y(i) = d(i) * x(i) + end do + else if (alpha == -zone) then + do i=1, n_row + y(i) = -d(i) * x(i) + end do + else + do i=1, n_row + y(i) = alpha * d(i) * x(i) + end do + end if + + else if (beta == zone) then + + if (alpha == zzero) then + !y(1:n_row) = zzero + else if (alpha == zone) then + do i=1, n_row + y(i) = d(i) * x(i) + y(i) + end do + else if (alpha == -zone) then + do i=1, n_row + y(i) = -d(i) * x(i) + y(i) + end do + else + do i=1, n_row + y(i) = alpha * d(i) * x(i) + y(i) + end do + end if + + else if (beta == -zone) then + + if (alpha == zzero) then + y(1:n_row) = -y(1:n_row) + else if (alpha == zone) then + do i=1, n_row + y(i) = d(i) * x(i) - y(i) + end do + else if (alpha == -zone) then + do i=1, n_row + y(i) = -d(i) * x(i) - y(i) + end do + else + do i=1, n_row + y(i) = alpha * d(i) * x(i) - y(i) + end do + end if + + else + + if (alpha == zzero) then + y(1:n_row) = beta *y(1:n_row) + else if (alpha == zone) then + do i=1, n_row + y(i) = d(i) * x(i) + beta*y(i) + end do + else if (alpha == -zone) then + do i=1, n_row + y(i) = -d(i) * x(i) + beta*y(i) + end do + else + do i=1, n_row + y(i) = alpha * d(i) * x(i) + beta*y(i) + end do + end if + + end if + + end if + + end subroutine inner_mlt +end subroutine amg_z_jac_solver_apply diff --git a/amgprec/impl/solver/amg_z_jac_solver_apply_vect.f90 b/amgprec/impl/solver/amg_z_jac_solver_apply_vect.f90 new file mode 100644 index 00000000..241797e8 --- /dev/null +++ b/amgprec/impl/solver/amg_z_jac_solver_apply_vect.f90 @@ -0,0 +1,190 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_z_jac_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,& + & work,wv,info,init,initu) + + use psb_base_mod + use amg_z_diag_solver + use psb_base_krylov_conv_mod, only : log_conv + use amg_z_jac_solver, amg_protect_name => amg_z_jac_solver_apply_vect + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(amg_z_jac_solver_type), intent(inout) :: sv + type(psb_z_vect_type),intent(inout) :: x + type(psb_z_vect_type),intent(inout) :: y + complex(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + complex(psb_dpk_),target, intent(inout) :: work(:) + type(psb_z_vect_type),intent(inout) :: wv(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_z_vect_type),intent(inout), optional :: initu + ! + integer(psb_ipk_) :: n_row,n_col, sweeps + type(psb_z_vect_type) :: tx, ty, r + complex(psb_dpk_), pointer :: aux(:) + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, i, err_act + character :: trans_, init_ + real(psb_dpk_) :: res, resdenum + character(len=20) :: name='z_jac_solver_apply_v' + + call psb_erractionsave(err_act) + + info = psb_success_ + ctxt = desc_data%get_context() + call psb_info(ctxt,me,np) + + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T','C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + sweeps = sv%sweeps + if (4*n_col <= size(work)) then + aux => work(:) + else + allocate(aux(4*n_col),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/4*n_col,izero,izero,izero,izero/),& + & a_err='complex(psb_dpk_)') + goto 9999 + end if + endif + + if (sweeps >= 0) then + ! + ! This means we are dealing with a pure Jacobi smoother/solver. + ! + associate(tx => wv(1), ty => wv(2)) + select case (init_) + case('Z') + + call ty%mlt(zone,sv%dv,x,zzero,info,conjgx=trans_) + + 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,sv%a,ty,zone,tx,desc_data,info,& + & work=aux,trans=trans_, doswap=.false.) + call ty%mlt(zone,sv%dv,tx,zzero,info,conjgx=trans_) + + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(zone,x,zzero,tx,desc_data,info) + call psb_geaxpby(zone,initu,zzero,ty,desc_data,info) + call psb_spmm(-zone,sv%a,ty,zone,tx,desc_data,info,& + & work=aux,trans=trans_, doswap=.false.) + call ty%mlt(zone,sv%dv,tx,zzero,info,conjgx=trans_) + + 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)), + ! where is the diagonal and A the matrix. + ! + call psb_geaxpby(zone,x,zzero,tx,desc_data,info) + call psb_spmm(-zone,sv%a,ty,zone,tx,desc_data,info,& + & work=aux,trans=trans_, doswap=.false.) + if (info /= psb_success_) exit + call ty%mlt(zone,sv%dv,tx,zone,info,conjgx=trans_) + if (info /= psb_success_) exit + end do + + + if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) + + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='subsolve with Jacobi sweeps > 1') + goto 9999 + end if + + + end associate + + + else + + info = psb_err_iarg_neg_ + call psb_errpush(info,name,& + & i_err=(/itwo,sweeps,izero,izero,izero/)) + goto 9999 + + end if + + if (.not.(4*n_col <= size(work))) then + deallocate(aux) + endif + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine amg_z_jac_solver_apply_vect diff --git a/amgprec/impl/solver/amg_z_jac_solver_bld.f90 b/amgprec/impl/solver/amg_z_jac_solver_bld.f90 new file mode 100644 index 00000000..d9b2233f --- /dev/null +++ b/amgprec/impl/solver/amg_z_jac_solver_bld.f90 @@ -0,0 +1,125 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_z_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) + + use psb_base_mod + use amg_z_jac_solver, amg_protect_name => amg_z_jac_solver_bld + + Implicit None + + ! Arguments + type(psb_zspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(amg_z_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + type(psb_zspmat_type), intent(in), target, optional :: b + class(psb_z_base_sparse_mat), intent(in), optional :: amold + class(psb_z_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + ! Local variables + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota + complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) + complex(psb_dpk_), allocatable :: tdb(:) + type(psb_z_csr_sparse_mat) :: tcsr + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, i, err_act, debug_unit, debug_level + character(len=20) :: name='z_jac_solver_bld', ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + n_row = desc_a%get_local_rows() + nrow_a = a%get_nrows() + if (present(b)) then + info=psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end if + call a%cp_to(tcsr) + call sv%a%mv_from(tcsr) + if (present(amold)) call sv%a%cscnv(info,mold=amold) + + sv%d = a%get_diag(info) + if (info == psb_success_) call psb_realloc(n_row,sv%d,info) + if (present(b)) then + tdb=b%get_diag(info) + if (size(tdb)+nrow_a > n_row) call psb_realloc(nrow_a+size(tdb),sv%d,info) + if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) + end if + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='get_diag') + goto 9999 + end if + + do i=1,n_row + if (sv%d(i) == zzero) then + sv%d(i) = zone + else + sv%d(i) = zone/sv%d(i) + end if + end do + allocate(sv%dv,stat=info) + if (info == psb_success_) then + call sv%dv%bld(sv%d) + if (present(vmold)) call sv%dv%cnv(vmold) + call sv%dv%sync() + else + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='Allocate sv%dv') + goto 9999 + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine amg_z_jac_solver_bld + + diff --git a/amgprec/impl/solver/amg_z_jac_solver_clear_data.f90 b/amgprec/impl/solver/amg_z_jac_solver_clear_data.f90 new file mode 100644 index 00000000..ba3686dd --- /dev/null +++ b/amgprec/impl/solver/amg_z_jac_solver_clear_data.f90 @@ -0,0 +1,65 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_z_jac_solver_clear_data(sv,info) + + use psb_base_mod + use amg_z_jac_solver, amg_protect_name => amg_z_jac_solver_clear_data + + Implicit None + + ! Arguments + class(amg_z_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + ! Local variables + integer(psb_ipk_) :: err_act + + info=psb_success_ + call psb_erractionsave(err_act) + + call sv%a%free() + call sv%dv%free(info) + if ((info==0).and.allocated(sv%d)) deallocate(sv%d,stat=info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine amg_z_jac_solver_clear_data diff --git a/amgprec/impl/solver/amg_z_jac_solver_clone.f90 b/amgprec/impl/solver/amg_z_jac_solver_clone.f90 new file mode 100644 index 00000000..29b2cfee --- /dev/null +++ b/amgprec/impl/solver/amg_z_jac_solver_clone.f90 @@ -0,0 +1,88 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_z_jac_solver_clone(sv,svout,info) + + use psb_base_mod + use amg_z_jac_solver, amg_protect_name => amg_z_jac_solver_clone + + Implicit None + + ! Arguments + class(amg_z_jac_solver_type), intent(inout) :: sv + class(amg_z_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info + ! Local variables + integer(psb_ipk_) :: err_act + + + info=psb_success_ + call psb_erractionsave(err_act) + if (allocated(svout)) then + call svout%free(info) + if (info == psb_success_) deallocate(svout, stat=info) + end if + if (info == psb_success_) & + & allocate(svout, mold=sv, stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + + select type(svo => svout) + class is (amg_z_jac_solver_type) + svo%sweeps = sv%sweeps + svo%eps = sv%eps + if (info == psb_success_) & + & call sv%a%clone(svo%a,info) + if (info == psb_success_) & + & call sv%dv%clone(svo%dv,info) + svo%d = sv%d + + class default + info = psb_err_internal_error_ + end select + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine amg_z_jac_solver_clone diff --git a/amgprec/impl/solver/amg_z_jac_solver_clone_settings.f90 b/amgprec/impl/solver/amg_z_jac_solver_clone_settings.f90 new file mode 100644 index 00000000..9ce36cc9 --- /dev/null +++ b/amgprec/impl/solver/amg_z_jac_solver_clone_settings.f90 @@ -0,0 +1,69 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_z_jac_solver_clone_settings(sv,svout,info) + + use psb_base_mod + use amg_z_jac_solver, amg_protect_name => amg_z_jac_solver_clone_settings + Implicit None + ! Arguments + class(amg_z_jac_solver_type), intent(inout) :: sv + class(amg_z_base_solver_type), intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='z_jac_solver_clone_settings' + + call psb_erractionsave(err_act) + + select type(svout) + class is(amg_z_jac_solver_type) + svout%sweeps = sv%sweeps + svout%eps = sv%eps + + class default + info = psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine amg_z_jac_solver_clone_settings diff --git a/amgprec/impl/solver/amg_z_jac_solver_cnv.f90 b/amgprec/impl/solver/amg_z_jac_solver_cnv.f90 new file mode 100644 index 00000000..52f52983 --- /dev/null +++ b/amgprec/impl/solver/amg_z_jac_solver_cnv.f90 @@ -0,0 +1,72 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_z_jac_solver_cnv(sv,info,amold,vmold,imold) + + use psb_base_mod + use amg_z_jac_solver, amg_protect_name => amg_z_jac_solver_cnv + + Implicit None + + ! Arguments + class(amg_z_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_sparse_mat), intent(in), optional :: amold + class(psb_z_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + ! Local variables + integer(psb_ipk_) :: err_act, debug_unit, debug_level + character(len=20) :: name='z_jac_solver_cnv', ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (present(amold)) call sv%a%cscnv(info,mold=amold) + if ((info==0).and.present(vmold)) call sv%dv%cnv(mold=vmold) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine amg_z_jac_solver_cnv diff --git a/amgprec/impl/solver/amg_z_jac_solver_dmp.f90 b/amgprec/impl/solver/amg_z_jac_solver_dmp.f90 new file mode 100644 index 00000000..9339b328 --- /dev/null +++ b/amgprec/impl/solver/amg_z_jac_solver_dmp.f90 @@ -0,0 +1,107 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_z_jac_solver_dmp(sv,desc,level,info,prefix,head,solver,global_num) + + use psb_base_mod + use amg_z_jac_solver, amg_protect_name => amg_z_jac_solver_dmp + implicit none + class(amg_z_jac_solver_type), intent(in) :: sv + type(psb_desc_type), intent(in) :: desc + integer(psb_ipk_), intent(in) :: level + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: solver, global_num + integer(psb_ipk_) :: i, j, il1, iln, lname, lev + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np + character(len=80) :: prefix_ + character(len=120) :: fname ! len should be at least 20 more than + logical :: solver_, global_num_ + integer(psb_lpk_), allocatable :: iv(:) + ! len of prefix_ + + info = 0 + + ctxt = desc%get_context() + call psb_info(ctxt,iam,np) + + if (present(solver)) then + solver_ = solver + else + solver_ = .false. + end if + if (present(global_num)) then + global_num_ = global_num + else + global_num_ = .false. + end if + + + if (solver_) then + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_slv_z" + end if + lname = len_trim(prefix_) + fname = trim(prefix_) + write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam + lname = lname + 5 + + if (global_num_) then + iv = desc%get_global_indices(owned=.false.) + + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx' + if (sv%a%is_asb()) & + & call sv%a%print(fname,head=head,iv=iv) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_diag.mtx' + if (allocated(sv%dv)) & + & call psb_geprt(fname,sv%dv%v%v,head=head) + + else + + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx' + if (sv%a%is_asb()) & + & call sv%a%print(fname,head=head) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_diag.mtx' + if (allocated(sv%dv)) & + & call psb_geprt(fname,sv%dv%v%v,head=head) + end if + end if + +end subroutine amg_z_jac_solver_dmp diff --git a/amgprec/impl/solver/amg_z_l1_jac_solver_bld.f90 b/amgprec/impl/solver/amg_z_l1_jac_solver_bld.f90 new file mode 100644 index 00000000..8e9b0c37 --- /dev/null +++ b/amgprec/impl/solver/amg_z_l1_jac_solver_bld.f90 @@ -0,0 +1,128 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_z_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) + + use psb_base_mod + use amg_z_jac_solver, amg_protect_name => amg_z_l1_jac_solver_bld + + Implicit None + + ! Arguments + type(psb_zspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(inout) :: desc_a + class(amg_z_l1_jac_solver_type), intent(inout) :: sv + integer(psb_ipk_), intent(out) :: info + type(psb_zspmat_type), intent(in), target, optional :: b + class(psb_z_base_sparse_mat), intent(in), optional :: amold + class(psb_z_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + ! Local variables + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota + complex(psb_dpk_), allocatable :: tdb(:), tx(:),ty(:) + type(psb_z_csr_sparse_mat) :: tcsr + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, i, err_act, debug_unit, debug_level + character(len=20) :: name='z_l1_jac_solver_bld', ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + n_row = desc_a%get_local_rows() + nrow_a = a%get_nrows() + if (present(b)) then + info=psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end if + + call a%cp_to(tcsr) + call sv%a%mv_from(tcsr) + if (present(amold)) call sv%a%cscnv(info,mold=amold) + + tx = a%get_diag(info) + sv%d = a%arwsum(info) + sv%d(:) = sv%d(:) - abs(tx(:)) + tx(:) + if (info == psb_success_) call psb_realloc(n_row,sv%d,info) + if (present(b)) then + tdb=b%arwsum(info) + ty =b%get_diag(info) + if (size(tdb)+nrow_a > n_row) call psb_realloc(nrow_a+size(tdb),sv%d,info) + if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) - abs(ty(:)) + ty(:) + end if + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='get_diag') + goto 9999 + end if + + do i=1,n_row + if (sv%d(i) == zzero) then + sv%d(i) = zone + else + sv%d(i) = zone/sv%d(i) + end if + end do + allocate(sv%dv,stat=info) + if (info == psb_success_) then + call sv%dv%bld(sv%d) + if (present(vmold)) call sv%dv%cnv(vmold) + call sv%dv%sync() + else + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='Allocate sv%dv') + goto 9999 + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine amg_z_l1_jac_solver_bld + + diff --git a/samples/advanced/fileread/runs/amg_dfs.inp b/samples/advanced/fileread/runs/amg_dfs.inp index 9e0606b2..42bcb181 100644 --- a/samples/advanced/fileread/runs/amg_dfs.inp +++ b/samples/advanced/fileread/runs/amg_dfs.inp @@ -5,7 +5,7 @@ NONE ! Initial guess amg_sol.mtx ! Reference solution MM ! File format: MatrixMarket or Harwell-Boeing CSR ! Storage format: CSR COO JAD -GRAPH ! PART (partition method): BLOCK GRAPH +GRAPH ! PART (partition method): BLOCK GRAPH CG ! Iterative method: BiCGSTAB BiCGSTABL BiCG CG CGS FCG GCR RGMRES 2 ! ISTOPC 00500 ! ITMAX diff --git a/samples/advanced/pdegen/amg_d_pde3d.F90 b/samples/advanced/pdegen/amg_d_pde3d.F90 index ba46debf..c13cecee 100644 --- a/samples/advanced/pdegen/amg_d_pde3d.F90 +++ b/samples/advanced/pdegen/amg_d_pde3d.F90 @@ -288,6 +288,8 @@ program amg_d_pde3d call prec%set('sub_solve', p_choice%solve, info) if (psb_toupper(p_choice%solve)=='MUMPS') & & call prec%set('mumps_loc_glob','local_solver',info) + if ((psb_toupper(p_choice%solve)=='JACOBI').or.(psb_toupper(p_choice%solve)=='L1-JACOBI')) & + & call prec%set('solver_sweeps',8,info) call prec%set('sub_fillin', p_choice%fill, info) call prec%set('sub_iluthrs', p_choice%thr, info) diff --git a/samples/advanced/pdegen/runs/amg_pde3d.inp b/samples/advanced/pdegen/runs/amg_pde3d.inp index 7a3329cd..7eb4d02e 100644 --- a/samples/advanced/pdegen/runs/amg_pde3d.inp +++ b/samples/advanced/pdegen/runs/amg_pde3d.inp @@ -1,6 +1,6 @@ %%%%%%%%%%% General arguments % Lines starting with % are ignored. CSR ! Storage format CSR COO JAD -0200 ! IDIM; domain size. Linear system size is IDIM**3 +0040 ! IDIM; domain size. Linear system size is IDIM**3 CONST ! PDECOEFF: CONST, EXP, GAUSS Coefficients of the PDE BICGSTAB ! Iterative method: BiCGSTAB BiCGSTABL BiCG CG CGS FCG GCR RGMRES 2 ! ISTOPC @@ -10,14 +10,14 @@ BICGSTAB ! Iterative method: BiCGSTAB BiCGSTABL BiCG CG CGS F 1.d-6 ! EPS %%%%%%%%%%% Main preconditioner choices %%%%%%%%%%%%%%%% ML-VBM-VCYCLE-FBGS-D-BJAC ! Longer descriptive name for preconditioner (up to 20 chars) -ML ! Preconditioner type: NONE JACOBI GS FBGS BJAC AS ML +BJAC ! Preconditioner type: NONE JACOBI GS FBGS BJAC AS ML %%%%%%%%%%% First smoother (for all levels but coarsest) %%%%%%%%%%%%%%%% -FBGS ! Smoother type JACOBI FBGS GS BWGS BJAC AS. For 1-level, repeats previous. +BJAC ! Smoother type JACOBI FBGS GS BWGS BJAC AS. For 1-level, repeats previous. 1 ! Number of sweeps for smoother 0 ! Number of overlap layers for AS preconditioner HALO ! AS restriction operator: NONE HALO NONE ! AS prolongation operator: NONE SUM AVG -INVK ! Subdomain solver for BJAC/AS: JACOBI GS BGS ILU ILUT MILU MUMPS SLU UMF +JACOBI ! Subdomain solver for BJAC/AS: JACOBI GS BGS ILU ILUT MILU MUMPS SLU UMF LLK ! AINV variant 0 ! Fill level P for ILU(P) and ILU(T,P) 1 ! Inverse Fill level P for INVK