diff --git a/mlprec/impl/Makefile b/mlprec/impl/Makefile index 89825825..e66f699b 100644 --- a/mlprec/impl/Makefile +++ b/mlprec/impl/Makefile @@ -26,47 +26,31 @@ DINNEROBJS= mld_dcoarse_bld.o mld_dmlprec_bld.o \ mld_d_dec_map_bld.o mld_dmlprec_aply.o mld_daggrmat_asb.o \ $(DMPFOBJS) -# mld_d_base_solver_impl.o mld_d_base_smoother_impl.o mld_d_onelev_impl.o\ - mld_d_as_smoother_impl.o mld_d_jac_smoother_impl.o \ - mld_d_diag_solver_impl.o mld_d_id_solver_impl.o mld_d_ilu_solver_impl.o - SINNEROBJS= mld_scoarse_bld.o mld_smlprec_bld.o \ mld_silu0_fact.o mld_siluk_fact.o mld_silut_fact.o mld_saggrmap_bld.o \ mld_s_dec_map_bld.o mld_smlprec_aply.o mld_saggrmat_asb.o \ $(SMPFOBJS) -# mld_s_base_solver_impl.o mld_s_base_smoother_impl.o mld_s_onelev_impl.o\ - mld_s_as_smoother_impl.o mld_s_jac_smoother_impl.o \ - mld_s_diag_solver_impl.o mld_s_id_solver_impl.o mld_s_ilu_solver_impl.o - ZINNEROBJS= mld_zcoarse_bld.o mld_zmlprec_bld.o \ mld_zilu0_fact.o mld_ziluk_fact.o mld_zilut_fact.o mld_zaggrmap_bld.o \ mld_z_dec_map_bld.o mld_zmlprec_aply.o mld_zaggrmat_asb.o \ $(ZMPFOBJS) -# mld_z_base_solver_impl.o mld_z_base_smoother_impl.o mld_z_onelev_impl.o\ - mld_z_as_smoother_impl.o mld_z_jac_smoother_impl.o \ - mld_z_diag_solver_impl.o mld_z_id_solver_impl.o mld_z_ilu_solver_impl.o - CINNEROBJS= mld_ccoarse_bld.o mld_cmlprec_bld.o \ mld_cilu0_fact.o mld_ciluk_fact.o mld_cilut_fact.o mld_caggrmap_bld.o \ mld_c_dec_map_bld.o mld_cmlprec_aply.o mld_caggrmat_asb.o \ $(CMPFOBJS) -# mld_c_base_solver_impl.o mld_c_base_smoother_impl.o mld_c_onelev_impl.o\ - mld_c_as_smoother_impl.o mld_c_jac_smoother_impl.o \ - mld_c_diag_solver_impl.o mld_c_id_solver_impl.o mld_c_ilu_solver_impl.o - INNEROBJS= $(SINNEROBJS) $(DINNEROBJS) $(CINNEROBJS) $(ZINNEROBJS) DOUTEROBJS=mld_dprecbld.o mld_dprecset.o mld_dprecinit.o mld_dprecaply.o mld_dcprecset.o -SOUTEROBJS=mld_sprecbld.o mld_sprecset.o mld_sprecinit.o mld_sprecaply.o +SOUTEROBJS=mld_sprecbld.o mld_sprecset.o mld_sprecinit.o mld_sprecaply.o mld_scprecset.o -ZOUTEROBJS=mld_zprecbld.o mld_zprecset.o mld_zprecinit.o mld_zprecaply.o +ZOUTEROBJS=mld_zprecbld.o mld_zprecset.o mld_zprecinit.o mld_zprecaply.o mld_zcprecset.o -COUTEROBJS=mld_cprecbld.o mld_cprecset.o mld_cprecinit.o mld_cprecaply.o +COUTEROBJS=mld_cprecbld.o mld_cprecset.o mld_cprecinit.o mld_cprecaply.o mld_ccprecset.o OUTEROBJS=$(SOUTEROBJS) $(DOUTEROBJS) $(COUTEROBJS) $(ZOUTEROBJS) diff --git a/mlprec/impl/level/mld_c_base_onelev_csetc.f90 b/mlprec/impl/level/mld_c_base_onelev_csetc.f90 index 86c9097c..f1d19228 100644 --- a/mlprec/impl/level/mld_c_base_onelev_csetc.f90 +++ b/mlprec/impl/level/mld_c_base_onelev_csetc.f90 @@ -56,7 +56,7 @@ subroutine mld_c_base_onelev_csetc(lv,what,val,info) info = psb_success_ - ival = mld_stringval(val) + ival = lv%stringval(val) if (ival >= 0) then call lv%set(what,ival,info) else diff --git a/mlprec/impl/level/mld_c_base_onelev_cseti.f90 b/mlprec/impl/level/mld_c_base_onelev_cseti.f90 index bcd4403f..3856bd31 100644 --- a/mlprec/impl/level/mld_c_base_onelev_cseti.f90 +++ b/mlprec/impl/level/mld_c_base_onelev_cseti.f90 @@ -54,7 +54,7 @@ subroutine mld_c_base_onelev_cseti(lv,what,val,info) call psb_erractionsave(err_act) info = psb_success_ - select case (what) + select case (psb_toupper(what)) case ('SMOOTHER_SWEEPS') lv%parms%sweeps = val diff --git a/mlprec/impl/level/mld_c_base_onelev_csetr.f90 b/mlprec/impl/level/mld_c_base_onelev_csetr.f90 index 5e20a6e0..7c9d9666 100644 --- a/mlprec/impl/level/mld_c_base_onelev_csetr.f90 +++ b/mlprec/impl/level/mld_c_base_onelev_csetr.f90 @@ -56,7 +56,7 @@ subroutine mld_c_base_onelev_csetr(lv,what,val,info) info = psb_success_ - select case (what) + select case (psb_toupper(what)) case ('AGGR_OMEGA_VAL') lv%parms%aggr_omega_val= val diff --git a/mlprec/impl/level/mld_c_base_onelev_setc.f90 b/mlprec/impl/level/mld_c_base_onelev_setc.f90 index abc53594..d61a3e3c 100644 --- a/mlprec/impl/level/mld_c_base_onelev_setc.f90 +++ b/mlprec/impl/level/mld_c_base_onelev_setc.f90 @@ -56,7 +56,7 @@ subroutine mld_c_base_onelev_setc(lv,what,val,info) info = psb_success_ - ival = mld_stringval(val) + ival = lv%stringval(val) if (ival >= 0) then call lv%set(what,ival,info) else diff --git a/mlprec/impl/level/mld_d_base_onelev_csetc.f90 b/mlprec/impl/level/mld_d_base_onelev_csetc.f90 index f3cb715b..c58cf34b 100644 --- a/mlprec/impl/level/mld_d_base_onelev_csetc.f90 +++ b/mlprec/impl/level/mld_d_base_onelev_csetc.f90 @@ -56,7 +56,7 @@ subroutine mld_d_base_onelev_csetc(lv,what,val,info) info = psb_success_ - ival = mld_stringval(val) + ival = lv%stringval(val) if (ival >= 0) then call lv%set(what,ival,info) else diff --git a/mlprec/impl/level/mld_d_base_onelev_cseti.f90 b/mlprec/impl/level/mld_d_base_onelev_cseti.f90 index e4b5ee9c..0936284f 100644 --- a/mlprec/impl/level/mld_d_base_onelev_cseti.f90 +++ b/mlprec/impl/level/mld_d_base_onelev_cseti.f90 @@ -54,7 +54,7 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info) call psb_erractionsave(err_act) info = psb_success_ - select case (what) + select case (psb_toupper(what)) case ('SMOOTHER_SWEEPS') lv%parms%sweeps = val diff --git a/mlprec/impl/level/mld_d_base_onelev_csetr.f90 b/mlprec/impl/level/mld_d_base_onelev_csetr.f90 index fe54e40e..f6423050 100644 --- a/mlprec/impl/level/mld_d_base_onelev_csetr.f90 +++ b/mlprec/impl/level/mld_d_base_onelev_csetr.f90 @@ -56,7 +56,7 @@ subroutine mld_d_base_onelev_csetr(lv,what,val,info) info = psb_success_ - select case (what) + select case (psb_toupper(what)) case ('AGGR_OMEGA_VAL') lv%parms%aggr_omega_val= val diff --git a/mlprec/impl/level/mld_d_base_onelev_setc.f90 b/mlprec/impl/level/mld_d_base_onelev_setc.f90 index 1b4ccc20..5f8e141d 100644 --- a/mlprec/impl/level/mld_d_base_onelev_setc.f90 +++ b/mlprec/impl/level/mld_d_base_onelev_setc.f90 @@ -56,7 +56,7 @@ subroutine mld_d_base_onelev_setc(lv,what,val,info) info = psb_success_ - ival = mld_stringval(val) + ival = lv%stringval(val) if (ival >= 0) then call lv%set(what,ival,info) else diff --git a/mlprec/impl/level/mld_s_base_onelev_csetc.f90 b/mlprec/impl/level/mld_s_base_onelev_csetc.f90 index b4a46f17..353fa150 100644 --- a/mlprec/impl/level/mld_s_base_onelev_csetc.f90 +++ b/mlprec/impl/level/mld_s_base_onelev_csetc.f90 @@ -56,7 +56,7 @@ subroutine mld_s_base_onelev_csetc(lv,what,val,info) info = psb_success_ - ival = mld_stringval(val) + ival = lv%stringval(val) if (ival >= 0) then call lv%set(what,ival,info) else diff --git a/mlprec/impl/level/mld_s_base_onelev_cseti.f90 b/mlprec/impl/level/mld_s_base_onelev_cseti.f90 index f6abe349..b07d0633 100644 --- a/mlprec/impl/level/mld_s_base_onelev_cseti.f90 +++ b/mlprec/impl/level/mld_s_base_onelev_cseti.f90 @@ -54,7 +54,7 @@ subroutine mld_s_base_onelev_cseti(lv,what,val,info) call psb_erractionsave(err_act) info = psb_success_ - select case (what) + select case (psb_toupper(what)) case ('SMOOTHER_SWEEPS') lv%parms%sweeps = val diff --git a/mlprec/impl/level/mld_s_base_onelev_csetr.f90 b/mlprec/impl/level/mld_s_base_onelev_csetr.f90 index 3cf6e005..6261b02e 100644 --- a/mlprec/impl/level/mld_s_base_onelev_csetr.f90 +++ b/mlprec/impl/level/mld_s_base_onelev_csetr.f90 @@ -56,7 +56,7 @@ subroutine mld_s_base_onelev_csetr(lv,what,val,info) info = psb_success_ - select case (what) + select case (psb_toupper(what)) case ('AGGR_OMEGA_VAL') lv%parms%aggr_omega_val= val diff --git a/mlprec/impl/level/mld_s_base_onelev_setc.f90 b/mlprec/impl/level/mld_s_base_onelev_setc.f90 index 271d2de2..b1daa8fc 100644 --- a/mlprec/impl/level/mld_s_base_onelev_setc.f90 +++ b/mlprec/impl/level/mld_s_base_onelev_setc.f90 @@ -56,7 +56,7 @@ subroutine mld_s_base_onelev_setc(lv,what,val,info) info = psb_success_ - ival = mld_stringval(val) + ival = lv%stringval(val) if (ival >= 0) then call lv%set(what,ival,info) else diff --git a/mlprec/impl/level/mld_z_base_onelev_csetc.f90 b/mlprec/impl/level/mld_z_base_onelev_csetc.f90 index e7071b31..85cbf35c 100644 --- a/mlprec/impl/level/mld_z_base_onelev_csetc.f90 +++ b/mlprec/impl/level/mld_z_base_onelev_csetc.f90 @@ -56,7 +56,7 @@ subroutine mld_z_base_onelev_csetc(lv,what,val,info) info = psb_success_ - ival = mld_stringval(val) + ival = lv%stringval(val) if (ival >= 0) then call lv%set(what,ival,info) else diff --git a/mlprec/impl/level/mld_z_base_onelev_cseti.f90 b/mlprec/impl/level/mld_z_base_onelev_cseti.f90 index adb70a0f..d9256aa7 100644 --- a/mlprec/impl/level/mld_z_base_onelev_cseti.f90 +++ b/mlprec/impl/level/mld_z_base_onelev_cseti.f90 @@ -54,7 +54,7 @@ subroutine mld_z_base_onelev_cseti(lv,what,val,info) call psb_erractionsave(err_act) info = psb_success_ - select case (what) + select case (psb_toupper(what)) case ('SMOOTHER_SWEEPS') lv%parms%sweeps = val diff --git a/mlprec/impl/level/mld_z_base_onelev_csetr.f90 b/mlprec/impl/level/mld_z_base_onelev_csetr.f90 index 97e2a325..755f5963 100644 --- a/mlprec/impl/level/mld_z_base_onelev_csetr.f90 +++ b/mlprec/impl/level/mld_z_base_onelev_csetr.f90 @@ -56,7 +56,7 @@ subroutine mld_z_base_onelev_csetr(lv,what,val,info) info = psb_success_ - select case (what) + select case (psb_toupper(what)) case ('AGGR_OMEGA_VAL') lv%parms%aggr_omega_val= val diff --git a/mlprec/impl/level/mld_z_base_onelev_setc.f90 b/mlprec/impl/level/mld_z_base_onelev_setc.f90 index 9048ad5d..4ece5257 100644 --- a/mlprec/impl/level/mld_z_base_onelev_setc.f90 +++ b/mlprec/impl/level/mld_z_base_onelev_setc.f90 @@ -56,7 +56,7 @@ subroutine mld_z_base_onelev_setc(lv,what,val,info) info = psb_success_ - ival = mld_stringval(val) + ival = lv%stringval(val) if (ival >= 0) then call lv%set(what,ival,info) else diff --git a/mlprec/impl/mld_ccprecset.F90 b/mlprec/impl/mld_ccprecset.F90 new file mode 100644 index 00000000..78157c9d --- /dev/null +++ b/mlprec/impl/mld_ccprecset.F90 @@ -0,0 +1,763 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) +!!$ +!!$ (C) Copyright 2008,2009,2010,2012 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the MLD2P4 group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! File: mld_cprecset.f90 +! +! Subroutine: mld_cprecseti +! Version: real +! +! This routine sets the integer parameters defining the preconditioner. More +! precisely, the integer parameter identified by 'what' is assigned the value +! contained in 'val'. +! For the multilevel preconditioners, the levels are numbered in increasing +! order starting from the finest one, i.e. level 1 is the finest level. +! +! To set character and real parameters, see mld_cprecsetc and mld_cprecsetr, +! respectively. +! +! +! Arguments: +! p - type(mld_cprec_type), input/output. +! The preconditioner data structure. +! what - integer, input. +! The number identifying the parameter to be set. +! A mnemonic constant has been associated to each of these +! numbers, as reported in the MLD2P4 User's and Reference Guide. +! val - integer, input. +! The value of the parameter to be set. The list of allowed +! values is reported in the MLD2P4 User's and Reference Guide. +! info - integer, output. +! Error code. +! ilev - integer, optional, input. +! For the multilevel preconditioner, the level at which the +! preconditioner parameter has to be set. +! If nlev is not present, the parameter identified by 'what' +! is set at all the appropriate levels. +! +! NOTE: currently, the use of the argument ilev is not "safe" and is reserved to +! MLD2P4 developers. Indeed, by using ilev it is possible to set different values +! of the same parameter at different levels 1,...,nlev-1, even in cases where +! the parameter must have the same value at all the levels but the coarsest one. +! For this reason, the interface mld_precset to this routine has been built in +! such a way that ilev is not visible to the user (see mld_prec_mod.f90). +! +subroutine mld_ccprecseti(p,what,val,info,ilev) + + use psb_base_mod + use mld_c_prec_mod, mld_protect_name => mld_ccprecseti + use mld_c_jac_smoother + use mld_c_as_smoother + use mld_c_diag_solver + use mld_c_ilu_solver + use mld_c_id_solver +#if defined(HAVE_UMF_) && 0 + use mld_c_umf_solver +#endif +#if defined(HAVE_SLU_) + use mld_c_slu_solver +#endif + + implicit none + + ! Arguments + class(mld_cprec_type), intent(inout) :: p + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev + + ! Local variables + integer(psb_ipk_) :: ilev_, nlev_ + character(len=*), parameter :: name='mld_precseti' + + info = psb_success_ + + if (.not.allocated(p%precv)) then + info = 3111 + write(psb_err_unit,*) name,& + & ': Error: uninitialized preconditioner,',& + &' should call MLD_PRECINIT' + return + endif + nlev_ = size(p%precv) + + if (present(ilev)) then + ilev_ = ilev + else + ilev_ = 1 + end if + + if ((ilev_<1).or.(ilev_ > nlev_)) then + info = -1 + write(psb_err_unit,*) name,& + &': Error: invalid ILEV/NLEV combination',ilev_, nlev_ + return + endif + + if (psb_toupper(what) == 'COARSE_AGGR_SIZE') then + p%coarse_aggr_size = max(val,-1) + return + end if + + ! + ! Set preconditioner parameters at level ilev. + ! + if (present(ilev)) then + + if (ilev_ == 1) then + ! + ! Rules for fine level are slightly different. + ! + select case(psb_toupper(what)) + case('SMOOTHER_TYPE') + call onelev_set_smoother(p%precv(ilev_),val,info) + case('SUB_SOLVE') + call onelev_set_solver(p%precv(ilev_),val,info) + case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_KIND',& + & 'SMOOTHER_POS','AGGR_OMEGA_ALG','AGGR_EIG',& + & 'SMOOTHER_SWEEPS_PRE','SMOOTHER_SWEEPS_POST',& + & 'SUB_RESTR','SUB_PROL', & + & 'SUB_REN','SUB_OVR','SUB_FILLIN') + call p%precv(ilev_)%set(what,val,info) + + case default + call p%precv(ilev_)%set(what,val,info) + end select + + else if (ilev_ > 1) then + + select case(psb_toupper(what)) + case('SMOOTHER_TYPE') + call onelev_set_smoother(p%precv(ilev_),val,info) + case('SUB_SOLVE') + call onelev_set_solver(p%precv(ilev_),val,info) + case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_KIND',& + & 'SMOOTHER_POS','AGGR_OMEGA_ALG','AGGR_EIG',& + & 'SMOOTHER_SWEEPS_PRE','SMOOTHER_SWEEPS_POST',& + & 'SUB_RESTR','SUB_PROL', & + & 'SUB_REN','SUB_OVR','SUB_FILLIN',& + & 'COARSE_MAT') + call p%precv(ilev_)%set(what,val,info) + + case('COARSE_SUBSOLVE') + if (ilev_ /= nlev_) then + write(psb_err_unit,*) name,& + & ': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + call onelev_set_solver(p%precv(ilev_),val,info) + case('COARSE_SOLVE') + if (ilev_ /= nlev_) then + write(psb_err_unit,*) name,& + & ': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + + if (nlev_ > 1) then + call p%precv(nlev_)%set('COARSE_SOLVE',val,info) + select case (val) + case(mld_bjac_) + call onelev_set_smoother(p%precv(nlev_),val,info) +#if defined(HAVE_UMF_) && 0 + call onelev_set_solver(p%precv(nlev_),mld_umf_,info) +#elif defined(HAVE_SLU_) + call onelev_set_solver(p%precv(nlev_),mld_slu_,info) +#else + call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) +#endif + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) + call onelev_set_solver(p%precv(nlev_),val,info) + call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info) + case(mld_sludist_) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) + call onelev_set_solver(p%precv(nlev_),val,info) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + case(mld_jac_) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) + call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + end select + + endif + case('COARSE_SWEEPS') + if (ilev_ /= nlev_) then + write(psb_err_unit,*) name,& + & ': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info) + + case('COARSE_FILLIN') + if (ilev_ /= nlev_) then + write(psb_err_unit,*) name,& + & ': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + call p%precv(nlev_)%set('SUB_FILLIN',val,info) + case default + call p%precv(ilev_)%set(what,val,info) + end select + + endif + + else if (.not.present(ilev)) then + ! + ! ilev not specified: set preconditioner parameters at all the appropriate + ! levels + ! + select case(psb_toupper(what)) + case('SUB_SOLVE') + do ilev_=1,max(1,nlev_-1) + if (.not.allocated(p%precv(ilev_)%sm)) then + write(psb_err_unit,*) name,& + & ': Error: uninitialized preconditioner component,',& + & ' should call MLD_PRECINIT' + info = -1 + return + endif + call onelev_set_solver(p%precv(ilev_),val,info) + + end do + + case('SUB_RESTR','SUB_PROL',& + & 'SUB_REN','SUB_OVR','SUB_FILLIN') + do ilev_=1,max(1,nlev_-1) + call p%precv(ilev_)%set(what,val,info) + end do + + case('SMOOTHER_SWEEPS') + do ilev_=1,max(1,nlev_-1) + call p%precv(ilev_)%set(what,val,info) + end do + + case('SMOOTHER_TYPE') + do ilev_=1,max(1,nlev_-1) + call onelev_set_smoother(p%precv(ilev_),val,info) + end do + + case('ML_TYPE','AGGR_ALG','AGGR_KIND',& + & 'SMOOTHER_SWEEPS_PRE','SMOOTHER_SWEEPS_POST',& + & 'SMOOTHER_POS','AGGR_OMEGA_ALG',& + & 'AGGR_EIG','AGGR_FILTER') + do ilev_=1,nlev_ + call p%precv(ilev_)%set(what,val,info) + end do + + case('COARSE_MAT') + if (nlev_ > 1) then + call p%precv(nlev_)%set('COARSE_MAT',val,info) + end if + + case('COARSE_SOLVE') + if (nlev_ > 1) then + + call p%precv(nlev_)%set('COARSE_SOLVE',val,info) + select case (val) + case(mld_bjac_) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) +#if defined(HAVE_UMF_) && 0 + call onelev_set_solver(p%precv(nlev_),mld_umf_,info) +#elif defined(HAVE_SLU_) + call onelev_set_solver(p%precv(nlev_),mld_slu_,info) +#else + call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) +#endif + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) + call onelev_set_solver(p%precv(nlev_),val,info) + call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info) + case(mld_sludist_) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) + call onelev_set_solver(p%precv(nlev_),val,info) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + case(mld_jac_) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) + call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + end select + + endif + + case('COARSE_SUBSOLVE') + if (nlev_ > 1) then + call onelev_set_solver(p%precv(nlev_),val,info) + endif + + case('COARSE_SWEEPS') + + if (nlev_ > 1) then + call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info) + end if + + case('COARSE_FILLIN') + if (nlev_ > 1) then + call p%precv(nlev_)%set('SUB_FILLIN',val,info) + end if + case default + do ilev_=1,nlev_ + call p%precv(ilev_)%set(what,val,info) + end do + end select + + endif + +contains + + subroutine onelev_set_smoother(level,val,info) + type(mld_c_onelev_type), intent(inout) :: level + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + info = psb_success_ + + ! + ! This here requires a bit more attention. + ! + select case (val) + case (mld_noprec_) + if (allocated(level%sm)) then + select type (sm => level%sm) + type is (mld_c_base_smoother_type) + ! do nothing + class default + call level%sm%free(info) + if (info == 0) deallocate(level%sm) + if (info == 0) allocate(mld_c_base_smoother_type ::& + & level%sm, stat=info) + if (info == 0) allocate(mld_c_id_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_c_base_smoother_type ::& + & level%sm, stat=info) + if (info ==0) allocate(mld_c_id_solver_type ::& + & level%sm%sv, stat=info) + endif + + case (mld_jac_) + if (allocated(level%sm)) then + select type (sm => level%sm) + class is (mld_c_jac_smoother_type) + ! do nothing + class default + call level%sm%free(info) + if (info == 0) deallocate(level%sm) + if (info == 0) allocate(mld_c_jac_smoother_type :: & + & level%sm, stat=info) + if (info == 0) allocate(mld_c_diag_solver_type :: & + & level%sm%sv, stat=info) + end select + else + allocate(mld_c_jac_smoother_type :: level%sm, stat=info) + if (info == 0) allocate(mld_c_diag_solver_type ::& + & level%sm%sv, stat=info) + endif + + case (mld_bjac_) + if (allocated(level%sm)) then + select type (sm => level%sm) + class is (mld_c_jac_smoother_type) + ! do nothing + class default + call level%sm%free(info) + if (info == 0) deallocate(level%sm) + if (info == 0) allocate(mld_c_jac_smoother_type ::& + & level%sm, stat=info) + if (info == 0) allocate(mld_c_ilu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_c_jac_smoother_type :: level%sm, stat=info) + if (info == 0) allocate(mld_c_ilu_solver_type ::& + & level%sm%sv, stat=info) + endif + + case (mld_as_) + if (allocated(level%sm)) then + select type (sm => level%sm) + class is (mld_c_as_smoother_type) + ! do nothing + class default + call level%sm%free(info) + if (info == 0) deallocate(level%sm) + if (info == 0) allocate(mld_c_as_smoother_type ::& + & level%sm, stat=info) + if (info == 0) allocate(mld_c_ilu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_c_as_smoother_type :: level%sm, stat=info) + if (info == 0) allocate(mld_c_ilu_solver_type ::& + & level%sm%sv, stat=info) + endif + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if (allocated(level%sm)) & + & call level%sm%default() + + end subroutine onelev_set_smoother + + subroutine onelev_set_solver(level,val,info) + type(mld_c_onelev_type), intent(inout) :: level + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + info = psb_success_ + + ! + ! This here requires a bit more attention. + ! + select case (val) + case (mld_f_none_) + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_c_id_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_c_id_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_c_id_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) & + & call level%sm%sv%default() + end if + + + case (mld_diag_scale_) + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_c_diag_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_c_diag_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_c_diag_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) & + & call level%sm%sv%default() + end if + + + case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_c_ilu_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_c_ilu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_c_ilu_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) & + & call level%sm%sv%default() + end if + call level%sm%sv%set('SUB_SOLVE',val,info) + +#if defined(HAVE_UMF_) && 0 + case (mld_umf_) + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_c_umf_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_c_umf_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_c_umf_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) & + & call level%sm%sv%default() + end if +#endif +#ifdef HAVE_SLU_ + case (mld_slu_) + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_c_slu_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_c_slu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_c_slu_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) & + & call level%sm%sv%default() + end if +#endif + case default + ! + ! Do nothing and hope for the best :) + ! + end select + + end subroutine onelev_set_solver + + +end subroutine mld_ccprecseti + +! +! Subroutine: mld_cprecsetc +! Version: real +! +! This routine sets the character parameters defining the preconditioner. More +! precisely, the character parameter identified by 'what' is assigned the value +! contained in 'val'. +! For the multilevel preconditioners, the levels are numbered in increasing +! order starting from the finest one, i.e. level 1 is the finest level. +! +! To set integer and real parameters, see mld_cprecseti and mld_cprecsetr, +! respectively. +! +! +! Arguments: +! p - type(mld_cprec_type), input/output. +! The preconditioner data structure. +! what - integer, input. +! The number identifying the parameter to be set. +! A mnemonic constant has been associated to each of these +! numbers, as reported in the MLD2P4 User's and Reference Guide. +! string - character(len=*), input. +! The value of the parameter to be set. The list of allowed +! values is reported in the MLD2P4 User's and Reference Guide. +! info - integer, output. +! Error code. +! ilev - integer, optional, input. +! For the multilevel preconditioner, the level at which the +! preconditioner parameter has to be set. +! If nlev is not present, the parameter identified by 'what' +! is set at all the appropriate levels. +! +! NOTE: currently, the use of the argument ilev is not "safe" and is reserved to +! MLD2P4 developers. Indeed, by using ilev it is possible to set different values +! of the same parameter at different levels 1,...,nlev-1, even in cases where +! the parameter must have the same value at all the levels but the coarsest one. +! For this reason, the interface mld_precset to this routine has been built in +! such a way that ilev is not visible to the user (see mld_prec_mod.f90). +! +subroutine mld_ccprecsetc(p,what,string,info,ilev) + + use psb_base_mod + use mld_c_prec_mod, mld_protect_name => mld_ccprecsetc + + implicit none + + ! Arguments + class(mld_cprec_type), intent(inout) :: p + character(len=*), intent(in) :: what + character(len=*), intent(in) :: string + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev + + ! Local variables + integer(psb_ipk_) :: ilev_, nlev_,val + character(len=*), parameter :: name='mld_precsetc' + + info = psb_success_ + + if (.not.allocated(p%precv)) then + info = 3111 + return + endif + nlev_ = size(p%precv) + + if (present(ilev)) then + ilev_ = ilev + else + ilev_ = 1 + end if + + if ((ilev_<1).or.(ilev_ > nlev_)) then + write(psb_err_unit,*) name,& + & ': Error: invalid ILEV/NLEV combination',ilev_, nlev_ + info = -1 + return + endif + + val = mld_stringval(string) + if (val >=0) then + call p%set(what,val,info,ilev=ilev) + else + call p%precv(ilev_)%set(what,val,info) + end if + +end subroutine mld_ccprecsetc + + +! +! Subroutine: mld_cprecsetr +! Version: real +! +! This routine sets the real parameters defining the preconditioner. More +! precisely, the real parameter identified by 'what' is assigned the value +! contained in 'val'. +! For the multilevel preconditioners, the levels are numbered in increasing +! order starting from the finest one, i.e. level 1 is the finest level. +! +! To set integer and character parameters, see mld_cprecseti and mld_cprecsetc, +! respectively. +! +! Arguments: +! p - type(mld_cprec_type), input/output. +! The preconditioner data structure. +! what - integer, input. +! The number identifying the parameter to be set. +! A mnemonic constant has been associated to each of these +! numbers, as reported in the MLD2P4 User's and Reference Guide. +! val - real(psb_dpk_), input. +! The value of the parameter to be set. The list of allowed +! values is reported in the MLD2P4 User's and Reference Guide. +! info - integer, output. +! Error code. +! ilev - integer, optional, input. +! For the multilevel preconditioner, the level at which the +! preconditioner parameter has to be set. +! If nlev is not present, the parameter identified by 'what' +! is set at all the appropriate levels. +! +! NOTE: currently, the use of the argument ilev is not "safe" and is reserved to +! MLD2P4 developers. Indeed, by using ilev it is possible to set different values +! of the same parameter at different levels 1,...,nlev-1, even in cases where +! the parameter must have the same value at all the levels but the coarsest one. +! For this reason, the interface mld_precset to this routine has been built in +! such a way that ilev is not visible to the user (see mld_prec_mod.f90). +! +subroutine mld_ccprecsetr(p,what,val,info,ilev) + + use psb_base_mod + use mld_c_prec_mod, mld_protect_name => mld_ccprecsetr + + implicit none + + ! Arguments + class(mld_cprec_type), intent(inout) :: p + character(len=*), intent(in) :: what + real(psb_spk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev + +! Local variables + integer(psb_ipk_) :: ilev_,nlev_ + character(len=*), parameter :: name='mld_precsetr' + + info = psb_success_ + + if (present(ilev)) then + ilev_ = ilev + else + ilev_ = 1 + end if + + if (.not.allocated(p%precv)) then + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner,',& + &' should call MLD_PRECINIT' + info = 3111 + return + endif + nlev_ = size(p%precv) + + if ((ilev_<1).or.(ilev_ > nlev_)) then + write(psb_err_unit,*) name,& + & ': Error: invalid ILEV/NLEV combination',& + & ilev_, nlev_ + info = -1 + return + endif + + ! + ! Set preconditioner parameters at level ilev. + ! + if (present(ilev)) then + + call p%precv(ilev_)%set(what,val,info) + + else if (.not.present(ilev)) then + ! + ! ilev not specified: set preconditioner parameters at all the appropriate levels + ! + + select case(psb_toupper(what)) + case('COARSE_ILUTHRS') + ilev_=nlev_ + call p%precv(ilev_)%set('SUB_ILUTHRS',val,info) + + case default + + do ilev_=1,nlev_ + call p%precv(ilev_)%set(what,val,info) + end do + end select + + endif + +end subroutine mld_ccprecsetr + + diff --git a/mlprec/impl/mld_cprecset.F90 b/mlprec/impl/mld_cprecset.F90 index fe73b471..11298f28 100644 --- a/mlprec/impl/mld_cprecset.F90 +++ b/mlprec/impl/mld_cprecset.F90 @@ -892,130 +892,3 @@ subroutine mld_cprecsetr(p,what,val,info,ilev) end subroutine mld_cprecsetr - - -subroutine mld_ccprecseti(p,what,val,info,ilev) - - use psb_base_mod - use mld_c_prec_mod, mld_protect_name => mld_ccprecseti - use mld_c_jac_smoother - use mld_c_as_smoother - use mld_c_diag_solver - use mld_c_ilu_solver - use mld_c_id_solver -#if defined(HAVE_UMF_) && 0 - use mld_c_umf_solver -#endif -#if defined(HAVE_SLU_) - use mld_c_slu_solver -#endif - - implicit none - - ! Arguments - class(mld_cprec_type), intent(inout) :: p - character(len=*), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: ilev - - ! Local variables - integer(psb_ipk_) :: ilev_, nlev_ - character(len=*), parameter :: name='mld_precseti' - - info = psb_success_ - - -end subroutine mld_ccprecseti - - -subroutine mld_ccprecsetc(p,what,string,info,ilev) - - use psb_base_mod - use mld_c_prec_mod, mld_protect_name => mld_ccprecsetc - - implicit none - - ! Arguments - class(mld_cprec_type), intent(inout) :: p - character(len=*), intent(in) :: what - character(len=*), intent(in) :: string - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: ilev - - ! Local variables - integer(psb_ipk_) :: ilev_, nlev_,val - character(len=*), parameter :: name='mld_precsetc' - - info = psb_success_ - - if (.not.allocated(p%precv)) then - info = 3111 - return - endif - nlev_ = size(p%precv) - - if (present(ilev)) then - ilev_ = ilev - else - ilev_ = 1 - end if - - if ((ilev_<1).or.(ilev_ > nlev_)) then - write(psb_err_unit,*) name,& - & ': Error: invalid ILEV/NLEV combination',ilev_, nlev_ - info = -1 - return - endif - - -end subroutine mld_ccprecsetc - -subroutine mld_ccprecsetr(p,what,val,info,ilev) - - use psb_base_mod - use mld_c_prec_mod, mld_protect_name => mld_ccprecsetr - - implicit none - - ! Arguments - class(mld_cprec_type), intent(inout) :: p - character(len=*), intent(in) :: what - real(psb_spk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: ilev - -! Local variables - integer(psb_ipk_) :: ilev_,nlev_ - character(len=*), parameter :: name='mld_precsetr' - - info = psb_success_ - - if (present(ilev)) then - ilev_ = ilev - else - ilev_ = 1 - end if - - if (.not.allocated(p%precv)) then - write(psb_err_unit,*) name,& - &': Error: uninitialized preconditioner,',& - &' should call MLD_PRECINIT' - info = 3111 - return - endif - nlev_ = size(p%precv) - - if ((ilev_<1).or.(ilev_ > nlev_)) then - write(psb_err_unit,*) name,& - & ': Error: invalid ILEV/NLEV combination',& - & ilev_, nlev_ - info = -1 - return - endif - - - - -end subroutine mld_ccprecsetr - diff --git a/mlprec/impl/mld_dcprecset.F90 b/mlprec/impl/mld_dcprecset.F90 index 7b49d82e..68ec452b 100644 --- a/mlprec/impl/mld_dcprecset.F90 +++ b/mlprec/impl/mld_dcprecset.F90 @@ -129,7 +129,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev) return endif - if (what == 'COARSE_AGGR_SIZE') then + if (psb_toupper(what) == 'COARSE_AGGR_SIZE') then p%coarse_aggr_size = max(val,-1) return end if @@ -143,7 +143,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev) ! ! Rules for fine level are slightly different. ! - select case(what) + select case(psb_toupper(what)) case('SMOOTHER_TYPE') call onelev_set_smoother(p%precv(ilev_),val,info) case('SUB_SOLVE') @@ -161,7 +161,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev) else if (ilev_ > 1) then - select case(what) + select case(psb_toupper(what)) case('SMOOTHER_TYPE') call onelev_set_smoother(p%precv(ilev_),val,info) case('SUB_SOLVE') @@ -246,7 +246,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev) ! ilev not specified: set preconditioner parameters at all the appropriate ! levels ! - select case(what) + select case(psb_toupper(what)) case('SUB_SOLVE') do ilev_=1,max(1,nlev_-1) if (.not.allocated(p%precv(ilev_)%sm)) then @@ -744,7 +744,7 @@ subroutine mld_dcprecsetr(p,what,val,info,ilev) ! ilev not specified: set preconditioner parameters at all the appropriate levels ! - select case(what) + select case(psb_toupper(what)) case('COARSE_ILUTHRS') ilev_=nlev_ call p%precv(ilev_)%set('SUB_ILUTHRS',val,info) diff --git a/mlprec/impl/mld_scprecset.F90 b/mlprec/impl/mld_scprecset.F90 new file mode 100644 index 00000000..4db32fe1 --- /dev/null +++ b/mlprec/impl/mld_scprecset.F90 @@ -0,0 +1,763 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) +!!$ +!!$ (C) Copyright 2008,2009,2010,2012 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the MLD2P4 group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! File: mld_sprecset.f90 +! +! Subroutine: mld_sprecseti +! Version: real +! +! This routine sets the integer parameters defining the preconditioner. More +! precisely, the integer parameter identified by 'what' is assigned the value +! contained in 'val'. +! For the multilevel preconditioners, the levels are numbered in increasing +! order starting from the finest one, i.e. level 1 is the finest level. +! +! To set character and real parameters, see mld_sprecsetc and mld_sprecsetr, +! respectively. +! +! +! Arguments: +! p - type(mld_sprec_type), input/output. +! The preconditioner data structure. +! what - integer, input. +! The number identifying the parameter to be set. +! A mnemonic constant has been associated to each of these +! numbers, as reported in the MLD2P4 User's and Reference Guide. +! val - integer, input. +! The value of the parameter to be set. The list of allowed +! values is reported in the MLD2P4 User's and Reference Guide. +! info - integer, output. +! Error code. +! ilev - integer, optional, input. +! For the multilevel preconditioner, the level at which the +! preconditioner parameter has to be set. +! If nlev is not present, the parameter identified by 'what' +! is set at all the appropriate levels. +! +! NOTE: currently, the use of the argument ilev is not "safe" and is reserved to +! MLD2P4 developers. Indeed, by using ilev it is possible to set different values +! of the same parameter at different levels 1,...,nlev-1, even in cases where +! the parameter must have the same value at all the levels but the coarsest one. +! For this reason, the interface mld_precset to this routine has been built in +! such a way that ilev is not visible to the user (see mld_prec_mod.f90). +! +subroutine mld_scprecseti(p,what,val,info,ilev) + + use psb_base_mod + use mld_s_prec_mod, mld_protect_name => mld_scprecseti + use mld_s_jac_smoother + use mld_s_as_smoother + use mld_s_diag_solver + use mld_s_ilu_solver + use mld_s_id_solver +#if defined(HAVE_UMF_) && 0 + use mld_s_umf_solver +#endif +#if defined(HAVE_SLU_) + use mld_s_slu_solver +#endif + + implicit none + + ! Arguments + class(mld_sprec_type), intent(inout) :: p + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev + + ! Local variables + integer(psb_ipk_) :: ilev_, nlev_ + character(len=*), parameter :: name='mld_precseti' + + info = psb_success_ + + if (.not.allocated(p%precv)) then + info = 3111 + write(psb_err_unit,*) name,& + & ': Error: uninitialized preconditioner,',& + &' should call MLD_PRECINIT' + return + endif + nlev_ = size(p%precv) + + if (present(ilev)) then + ilev_ = ilev + else + ilev_ = 1 + end if + + if ((ilev_<1).or.(ilev_ > nlev_)) then + info = -1 + write(psb_err_unit,*) name,& + &': Error: invalid ILEV/NLEV combination',ilev_, nlev_ + return + endif + + if (psb_toupper(what) == 'COARSE_AGGR_SIZE') then + p%coarse_aggr_size = max(val,-1) + return + end if + + ! + ! Set preconditioner parameters at level ilev. + ! + if (present(ilev)) then + + if (ilev_ == 1) then + ! + ! Rules for fine level are slightly different. + ! + select case(psb_toupper(what)) + case('SMOOTHER_TYPE') + call onelev_set_smoother(p%precv(ilev_),val,info) + case('SUB_SOLVE') + call onelev_set_solver(p%precv(ilev_),val,info) + case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_KIND',& + & 'SMOOTHER_POS','AGGR_OMEGA_ALG','AGGR_EIG',& + & 'SMOOTHER_SWEEPS_PRE','SMOOTHER_SWEEPS_POST',& + & 'SUB_RESTR','SUB_PROL', & + & 'SUB_REN','SUB_OVR','SUB_FILLIN') + call p%precv(ilev_)%set(what,val,info) + + case default + call p%precv(ilev_)%set(what,val,info) + end select + + else if (ilev_ > 1) then + + select case(psb_toupper(what)) + case('SMOOTHER_TYPE') + call onelev_set_smoother(p%precv(ilev_),val,info) + case('SUB_SOLVE') + call onelev_set_solver(p%precv(ilev_),val,info) + case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_KIND',& + & 'SMOOTHER_POS','AGGR_OMEGA_ALG','AGGR_EIG',& + & 'SMOOTHER_SWEEPS_PRE','SMOOTHER_SWEEPS_POST',& + & 'SUB_RESTR','SUB_PROL', & + & 'SUB_REN','SUB_OVR','SUB_FILLIN',& + & 'COARSE_MAT') + call p%precv(ilev_)%set(what,val,info) + + case('COARSE_SUBSOLVE') + if (ilev_ /= nlev_) then + write(psb_err_unit,*) name,& + & ': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + call onelev_set_solver(p%precv(ilev_),val,info) + case('COARSE_SOLVE') + if (ilev_ /= nlev_) then + write(psb_err_unit,*) name,& + & ': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + + if (nlev_ > 1) then + call p%precv(nlev_)%set('COARSE_SOLVE',val,info) + select case (val) + case(mld_bjac_) + call onelev_set_smoother(p%precv(nlev_),val,info) +#if defined(HAVE_UMF_) && 0 + call onelev_set_solver(p%precv(nlev_),mld_umf_,info) +#elif defined(HAVE_SLU_) + call onelev_set_solver(p%precv(nlev_),mld_slu_,info) +#else + call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) +#endif + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) + call onelev_set_solver(p%precv(nlev_),val,info) + call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info) + case(mld_sludist_) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) + call onelev_set_solver(p%precv(nlev_),val,info) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + case(mld_jac_) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) + call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + end select + + endif + case('COARSE_SWEEPS') + if (ilev_ /= nlev_) then + write(psb_err_unit,*) name,& + & ': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info) + + case('COARSE_FILLIN') + if (ilev_ /= nlev_) then + write(psb_err_unit,*) name,& + & ': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + call p%precv(nlev_)%set('SUB_FILLIN',val,info) + case default + call p%precv(ilev_)%set(what,val,info) + end select + + endif + + else if (.not.present(ilev)) then + ! + ! ilev not specified: set preconditioner parameters at all the appropriate + ! levels + ! + select case(psb_toupper(what)) + case('SUB_SOLVE') + do ilev_=1,max(1,nlev_-1) + if (.not.allocated(p%precv(ilev_)%sm)) then + write(psb_err_unit,*) name,& + & ': Error: uninitialized preconditioner component,',& + & ' should call MLD_PRECINIT' + info = -1 + return + endif + call onelev_set_solver(p%precv(ilev_),val,info) + + end do + + case('SUB_RESTR','SUB_PROL',& + & 'SUB_REN','SUB_OVR','SUB_FILLIN') + do ilev_=1,max(1,nlev_-1) + call p%precv(ilev_)%set(what,val,info) + end do + + case('SMOOTHER_SWEEPS') + do ilev_=1,max(1,nlev_-1) + call p%precv(ilev_)%set(what,val,info) + end do + + case('SMOOTHER_TYPE') + do ilev_=1,max(1,nlev_-1) + call onelev_set_smoother(p%precv(ilev_),val,info) + end do + + case('ML_TYPE','AGGR_ALG','AGGR_KIND',& + & 'SMOOTHER_SWEEPS_PRE','SMOOTHER_SWEEPS_POST',& + & 'SMOOTHER_POS','AGGR_OMEGA_ALG',& + & 'AGGR_EIG','AGGR_FILTER') + do ilev_=1,nlev_ + call p%precv(ilev_)%set(what,val,info) + end do + + case('COARSE_MAT') + if (nlev_ > 1) then + call p%precv(nlev_)%set('COARSE_MAT',val,info) + end if + + case('COARSE_SOLVE') + if (nlev_ > 1) then + + call p%precv(nlev_)%set('COARSE_SOLVE',val,info) + select case (val) + case(mld_bjac_) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) +#if defined(HAVE_UMF_) && 0 + call onelev_set_solver(p%precv(nlev_),mld_umf_,info) +#elif defined(HAVE_SLU_) + call onelev_set_solver(p%precv(nlev_),mld_slu_,info) +#else + call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) +#endif + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) + call onelev_set_solver(p%precv(nlev_),val,info) + call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info) + case(mld_sludist_) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) + call onelev_set_solver(p%precv(nlev_),val,info) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + case(mld_jac_) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) + call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + end select + + endif + + case('COARSE_SUBSOLVE') + if (nlev_ > 1) then + call onelev_set_solver(p%precv(nlev_),val,info) + endif + + case('COARSE_SWEEPS') + + if (nlev_ > 1) then + call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info) + end if + + case('COARSE_FILLIN') + if (nlev_ > 1) then + call p%precv(nlev_)%set('SUB_FILLIN',val,info) + end if + case default + do ilev_=1,nlev_ + call p%precv(ilev_)%set(what,val,info) + end do + end select + + endif + +contains + + subroutine onelev_set_smoother(level,val,info) + type(mld_s_onelev_type), intent(inout) :: level + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + info = psb_success_ + + ! + ! This here requires a bit more attention. + ! + select case (val) + case (mld_noprec_) + if (allocated(level%sm)) then + select type (sm => level%sm) + type is (mld_s_base_smoother_type) + ! do nothing + class default + call level%sm%free(info) + if (info == 0) deallocate(level%sm) + if (info == 0) allocate(mld_s_base_smoother_type ::& + & level%sm, stat=info) + if (info == 0) allocate(mld_s_id_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_s_base_smoother_type ::& + & level%sm, stat=info) + if (info ==0) allocate(mld_s_id_solver_type ::& + & level%sm%sv, stat=info) + endif + + case (mld_jac_) + if (allocated(level%sm)) then + select type (sm => level%sm) + class is (mld_s_jac_smoother_type) + ! do nothing + class default + call level%sm%free(info) + if (info == 0) deallocate(level%sm) + if (info == 0) allocate(mld_s_jac_smoother_type :: & + & level%sm, stat=info) + if (info == 0) allocate(mld_s_diag_solver_type :: & + & level%sm%sv, stat=info) + end select + else + allocate(mld_s_jac_smoother_type :: level%sm, stat=info) + if (info == 0) allocate(mld_s_diag_solver_type ::& + & level%sm%sv, stat=info) + endif + + case (mld_bjac_) + if (allocated(level%sm)) then + select type (sm => level%sm) + class is (mld_s_jac_smoother_type) + ! do nothing + class default + call level%sm%free(info) + if (info == 0) deallocate(level%sm) + if (info == 0) allocate(mld_s_jac_smoother_type ::& + & level%sm, stat=info) + if (info == 0) allocate(mld_s_ilu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_s_jac_smoother_type :: level%sm, stat=info) + if (info == 0) allocate(mld_s_ilu_solver_type ::& + & level%sm%sv, stat=info) + endif + + case (mld_as_) + if (allocated(level%sm)) then + select type (sm => level%sm) + class is (mld_s_as_smoother_type) + ! do nothing + class default + call level%sm%free(info) + if (info == 0) deallocate(level%sm) + if (info == 0) allocate(mld_s_as_smoother_type ::& + & level%sm, stat=info) + if (info == 0) allocate(mld_s_ilu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_s_as_smoother_type :: level%sm, stat=info) + if (info == 0) allocate(mld_s_ilu_solver_type ::& + & level%sm%sv, stat=info) + endif + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if (allocated(level%sm)) & + & call level%sm%default() + + end subroutine onelev_set_smoother + + subroutine onelev_set_solver(level,val,info) + type(mld_s_onelev_type), intent(inout) :: level + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + info = psb_success_ + + ! + ! This here requires a bit more attention. + ! + select case (val) + case (mld_f_none_) + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_s_id_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_s_id_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_s_id_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) & + & call level%sm%sv%default() + end if + + + case (mld_diag_scale_) + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_s_diag_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_s_diag_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_s_diag_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) & + & call level%sm%sv%default() + end if + + + case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_s_ilu_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_s_ilu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_s_ilu_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) & + & call level%sm%sv%default() + end if + call level%sm%sv%set('SUB_SOLVE',val,info) + +#if defined(HAVE_UMF_) && 0 + case (mld_umf_) + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_s_umf_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_s_umf_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_s_umf_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) & + & call level%sm%sv%default() + end if +#endif +#ifdef HAVE_SLU_ + case (mld_slu_) + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_s_slu_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_s_slu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_s_slu_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) & + & call level%sm%sv%default() + end if +#endif + case default + ! + ! Do nothing and hope for the best :) + ! + end select + + end subroutine onelev_set_solver + + +end subroutine mld_scprecseti + +! +! Subroutine: mld_sprecsetc +! Version: real +! +! This routine sets the character parameters defining the preconditioner. More +! precisely, the character parameter identified by 'what' is assigned the value +! contained in 'val'. +! For the multilevel preconditioners, the levels are numbered in increasing +! order starting from the finest one, i.e. level 1 is the finest level. +! +! To set integer and real parameters, see mld_sprecseti and mld_sprecsetr, +! respectively. +! +! +! Arguments: +! p - type(mld_sprec_type), input/output. +! The preconditioner data structure. +! what - integer, input. +! The number identifying the parameter to be set. +! A mnemonic constant has been associated to each of these +! numbers, as reported in the MLD2P4 User's and Reference Guide. +! string - character(len=*), input. +! The value of the parameter to be set. The list of allowed +! values is reported in the MLD2P4 User's and Reference Guide. +! info - integer, output. +! Error code. +! ilev - integer, optional, input. +! For the multilevel preconditioner, the level at which the +! preconditioner parameter has to be set. +! If nlev is not present, the parameter identified by 'what' +! is set at all the appropriate levels. +! +! NOTE: currently, the use of the argument ilev is not "safe" and is reserved to +! MLD2P4 developers. Indeed, by using ilev it is possible to set different values +! of the same parameter at different levels 1,...,nlev-1, even in cases where +! the parameter must have the same value at all the levels but the coarsest one. +! For this reason, the interface mld_precset to this routine has been built in +! such a way that ilev is not visible to the user (see mld_prec_mod.f90). +! +subroutine mld_scprecsetc(p,what,string,info,ilev) + + use psb_base_mod + use mld_s_prec_mod, mld_protect_name => mld_scprecsetc + + implicit none + + ! Arguments + class(mld_sprec_type), intent(inout) :: p + character(len=*), intent(in) :: what + character(len=*), intent(in) :: string + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev + + ! Local variables + integer(psb_ipk_) :: ilev_, nlev_,val + character(len=*), parameter :: name='mld_precsetc' + + info = psb_success_ + + if (.not.allocated(p%precv)) then + info = 3111 + return + endif + nlev_ = size(p%precv) + + if (present(ilev)) then + ilev_ = ilev + else + ilev_ = 1 + end if + + if ((ilev_<1).or.(ilev_ > nlev_)) then + write(psb_err_unit,*) name,& + & ': Error: invalid ILEV/NLEV combination',ilev_, nlev_ + info = -1 + return + endif + + val = mld_stringval(string) + if (val >=0) then + call p%set(what,val,info,ilev=ilev) + else + call p%precv(ilev_)%set(what,val,info) + end if + +end subroutine mld_scprecsetc + + +! +! Subroutine: mld_sprecsetr +! Version: real +! +! This routine sets the real parameters defining the preconditioner. More +! precisely, the real parameter identified by 'what' is assigned the value +! contained in 'val'. +! For the multilevel preconditioners, the levels are numbered in increasing +! order starting from the finest one, i.e. level 1 is the finest level. +! +! To set integer and character parameters, see mld_sprecseti and mld_sprecsetc, +! respectively. +! +! Arguments: +! p - type(mld_sprec_type), input/output. +! The preconditioner data structure. +! what - integer, input. +! The number identifying the parameter to be set. +! A mnemonic constant has been associated to each of these +! numbers, as reported in the MLD2P4 User's and Reference Guide. +! val - real(psb_dpk_), input. +! The value of the parameter to be set. The list of allowed +! values is reported in the MLD2P4 User's and Reference Guide. +! info - integer, output. +! Error code. +! ilev - integer, optional, input. +! For the multilevel preconditioner, the level at which the +! preconditioner parameter has to be set. +! If nlev is not present, the parameter identified by 'what' +! is set at all the appropriate levels. +! +! NOTE: currently, the use of the argument ilev is not "safe" and is reserved to +! MLD2P4 developers. Indeed, by using ilev it is possible to set different values +! of the same parameter at different levels 1,...,nlev-1, even in cases where +! the parameter must have the same value at all the levels but the coarsest one. +! For this reason, the interface mld_precset to this routine has been built in +! such a way that ilev is not visible to the user (see mld_prec_mod.f90). +! +subroutine mld_scprecsetr(p,what,val,info,ilev) + + use psb_base_mod + use mld_s_prec_mod, mld_protect_name => mld_scprecsetr + + implicit none + + ! Arguments + class(mld_sprec_type), intent(inout) :: p + character(len=*), intent(in) :: what + real(psb_spk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev + +! Local variables + integer(psb_ipk_) :: ilev_,nlev_ + character(len=*), parameter :: name='mld_precsetr' + + info = psb_success_ + + if (present(ilev)) then + ilev_ = ilev + else + ilev_ = 1 + end if + + if (.not.allocated(p%precv)) then + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner,',& + &' should call MLD_PRECINIT' + info = 3111 + return + endif + nlev_ = size(p%precv) + + if ((ilev_<1).or.(ilev_ > nlev_)) then + write(psb_err_unit,*) name,& + & ': Error: invalid ILEV/NLEV combination',& + & ilev_, nlev_ + info = -1 + return + endif + + ! + ! Set preconditioner parameters at level ilev. + ! + if (present(ilev)) then + + call p%precv(ilev_)%set(what,val,info) + + else if (.not.present(ilev)) then + ! + ! ilev not specified: set preconditioner parameters at all the appropriate levels + ! + + select case(psb_toupper(what)) + case('COARSE_ILUTHRS') + ilev_=nlev_ + call p%precv(ilev_)%set('SUB_ILUTHRS',val,info) + + case default + + do ilev_=1,nlev_ + call p%precv(ilev_)%set(what,val,info) + end do + end select + + endif + +end subroutine mld_scprecsetr + + diff --git a/mlprec/impl/mld_sprecset.F90 b/mlprec/impl/mld_sprecset.F90 index d156c972..441eea0d 100644 --- a/mlprec/impl/mld_sprecset.F90 +++ b/mlprec/impl/mld_sprecset.F90 @@ -893,129 +893,3 @@ subroutine mld_sprecsetr(p,what,val,info,ilev) end subroutine mld_sprecsetr - - -subroutine mld_scprecseti(p,what,val,info,ilev) - - use psb_base_mod - use mld_s_prec_mod, mld_protect_name => mld_scprecseti - use mld_s_jac_smoother - use mld_s_as_smoother - use mld_s_diag_solver - use mld_s_ilu_solver - use mld_s_id_solver -#if defined(HAVE_UMF_) && 0 - use mld_s_umf_solver -#endif -#if defined(HAVE_SLU_) - use mld_s_slu_solver -#endif - - implicit none - - ! Arguments - class(mld_sprec_type), intent(inout) :: p - character(len=*), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: ilev - - ! Local variables - integer(psb_ipk_) :: ilev_, nlev_ - character(len=*), parameter :: name='mld_precseti' - - info = psb_success_ - - -end subroutine mld_scprecseti - - -subroutine mld_scprecsetc(p,what,string,info,ilev) - - use psb_base_mod - use mld_s_prec_mod, mld_protect_name => mld_scprecsetc - - implicit none - - ! Arguments - class(mld_sprec_type), intent(inout) :: p - character(len=*), intent(in) :: what - character(len=*), intent(in) :: string - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: ilev - - ! Local variables - integer(psb_ipk_) :: ilev_, nlev_,val - character(len=*), parameter :: name='mld_precsetc' - - info = psb_success_ - - if (.not.allocated(p%precv)) then - info = 3111 - return - endif - nlev_ = size(p%precv) - - if (present(ilev)) then - ilev_ = ilev - else - ilev_ = 1 - end if - - if ((ilev_<1).or.(ilev_ > nlev_)) then - write(psb_err_unit,*) name,& - & ': Error: invalid ILEV/NLEV combination',ilev_, nlev_ - info = -1 - return - endif - - -end subroutine mld_scprecsetc - -subroutine mld_scprecsetr(p,what,val,info,ilev) - - use psb_base_mod - use mld_s_prec_mod, mld_protect_name => mld_scprecsetr - - implicit none - - ! Arguments - class(mld_sprec_type), intent(inout) :: p - character(len=*), intent(in) :: what - real(psb_spk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: ilev - -! Local variables - integer(psb_ipk_) :: ilev_,nlev_ - character(len=*), parameter :: name='mld_precsetr' - - info = psb_success_ - - if (present(ilev)) then - ilev_ = ilev - else - ilev_ = 1 - end if - - if (.not.allocated(p%precv)) then - write(psb_err_unit,*) name,& - &': Error: uninitialized preconditioner,',& - &' should call MLD_PRECINIT' - info = 3111 - return - endif - nlev_ = size(p%precv) - - if ((ilev_<1).or.(ilev_ > nlev_)) then - write(psb_err_unit,*) name,& - & ': Error: invalid ILEV/NLEV combination',& - & ilev_, nlev_ - info = -1 - return - endif - - - - -end subroutine mld_scprecsetr diff --git a/mlprec/impl/mld_zcprecset.F90 b/mlprec/impl/mld_zcprecset.F90 new file mode 100644 index 00000000..bf35a43b --- /dev/null +++ b/mlprec/impl/mld_zcprecset.F90 @@ -0,0 +1,763 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) +!!$ +!!$ (C) Copyright 2008,2009,2010,2012 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the MLD2P4 group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! File: mld_zprecset.f90 +! +! Subroutine: mld_zprecseti +! Version: real +! +! This routine sets the integer parameters defining the preconditioner. More +! precisely, the integer parameter identified by 'what' is assigned the value +! contained in 'val'. +! For the multilevel preconditioners, the levels are numbered in increasing +! order starting from the finest one, i.e. level 1 is the finest level. +! +! To set character and real parameters, see mld_zprecsetc and mld_zprecsetr, +! respectively. +! +! +! Arguments: +! p - type(mld_zprec_type), input/output. +! The preconditioner data structure. +! what - integer, input. +! The number identifying the parameter to be set. +! A mnemonic constant has been associated to each of these +! numbers, as reported in the MLD2P4 User's and Reference Guide. +! val - integer, input. +! The value of the parameter to be set. The list of allowed +! values is reported in the MLD2P4 User's and Reference Guide. +! info - integer, output. +! Error code. +! ilev - integer, optional, input. +! For the multilevel preconditioner, the level at which the +! preconditioner parameter has to be set. +! If nlev is not present, the parameter identified by 'what' +! is set at all the appropriate levels. +! +! NOTE: currently, the use of the argument ilev is not "safe" and is reserved to +! MLD2P4 developers. Indeed, by using ilev it is possible to set different values +! of the same parameter at different levels 1,...,nlev-1, even in cases where +! the parameter must have the same value at all the levels but the coarsest one. +! For this reason, the interface mld_precset to this routine has been built in +! such a way that ilev is not visible to the user (see mld_prec_mod.f90). +! +subroutine mld_zcprecseti(p,what,val,info,ilev) + + use psb_base_mod + use mld_z_prec_mod, mld_protect_name => mld_zcprecseti + use mld_z_jac_smoother + use mld_z_as_smoother + use mld_z_diag_solver + use mld_z_ilu_solver + use mld_z_id_solver +#if defined(HAVE_UMF_) + use mld_z_umf_solver +#endif +#if defined(HAVE_SLU_) + use mld_z_slu_solver +#endif + + implicit none + + ! Arguments + class(mld_zprec_type), intent(inout) :: p + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev + + ! Local variables + integer(psb_ipk_) :: ilev_, nlev_ + character(len=*), parameter :: name='mld_precseti' + + info = psb_success_ + + if (.not.allocated(p%precv)) then + info = 3111 + write(psb_err_unit,*) name,& + & ': Error: uninitialized preconditioner,',& + &' should call MLD_PRECINIT' + return + endif + nlev_ = size(p%precv) + + if (present(ilev)) then + ilev_ = ilev + else + ilev_ = 1 + end if + + if ((ilev_<1).or.(ilev_ > nlev_)) then + info = -1 + write(psb_err_unit,*) name,& + &': Error: invalid ILEV/NLEV combination',ilev_, nlev_ + return + endif + + if (psb_toupper(what) == 'COARSE_AGGR_SIZE') then + p%coarse_aggr_size = max(val,-1) + return + end if + + ! + ! Set preconditioner parameters at level ilev. + ! + if (present(ilev)) then + + if (ilev_ == 1) then + ! + ! Rules for fine level are slightly different. + ! + select case(psb_toupper(what)) + case('SMOOTHER_TYPE') + call onelev_set_smoother(p%precv(ilev_),val,info) + case('SUB_SOLVE') + call onelev_set_solver(p%precv(ilev_),val,info) + case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_KIND',& + & 'SMOOTHER_POS','AGGR_OMEGA_ALG','AGGR_EIG',& + & 'SMOOTHER_SWEEPS_PRE','SMOOTHER_SWEEPS_POST',& + & 'SUB_RESTR','SUB_PROL', & + & 'SUB_REN','SUB_OVR','SUB_FILLIN') + call p%precv(ilev_)%set(what,val,info) + + case default + call p%precv(ilev_)%set(what,val,info) + end select + + else if (ilev_ > 1) then + + select case(psb_toupper(what)) + case('SMOOTHER_TYPE') + call onelev_set_smoother(p%precv(ilev_),val,info) + case('SUB_SOLVE') + call onelev_set_solver(p%precv(ilev_),val,info) + case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_KIND',& + & 'SMOOTHER_POS','AGGR_OMEGA_ALG','AGGR_EIG',& + & 'SMOOTHER_SWEEPS_PRE','SMOOTHER_SWEEPS_POST',& + & 'SUB_RESTR','SUB_PROL', & + & 'SUB_REN','SUB_OVR','SUB_FILLIN',& + & 'COARSE_MAT') + call p%precv(ilev_)%set(what,val,info) + + case('COARSE_SUBSOLVE') + if (ilev_ /= nlev_) then + write(psb_err_unit,*) name,& + & ': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + call onelev_set_solver(p%precv(ilev_),val,info) + case('COARSE_SOLVE') + if (ilev_ /= nlev_) then + write(psb_err_unit,*) name,& + & ': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + + if (nlev_ > 1) then + call p%precv(nlev_)%set('COARSE_SOLVE',val,info) + select case (val) + case(mld_bjac_) + call onelev_set_smoother(p%precv(nlev_),val,info) +#if defined(HAVE_UMF_) + call onelev_set_solver(p%precv(nlev_),mld_umf_,info) +#elif defined(HAVE_SLU_) + call onelev_set_solver(p%precv(nlev_),mld_slu_,info) +#else + call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) +#endif + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) + call onelev_set_solver(p%precv(nlev_),val,info) + call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info) + case(mld_sludist_) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) + call onelev_set_solver(p%precv(nlev_),val,info) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + case(mld_jac_) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) + call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + end select + + endif + case('COARSE_SWEEPS') + if (ilev_ /= nlev_) then + write(psb_err_unit,*) name,& + & ': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info) + + case('COARSE_FILLIN') + if (ilev_ /= nlev_) then + write(psb_err_unit,*) name,& + & ': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + call p%precv(nlev_)%set('SUB_FILLIN',val,info) + case default + call p%precv(ilev_)%set(what,val,info) + end select + + endif + + else if (.not.present(ilev)) then + ! + ! ilev not specified: set preconditioner parameters at all the appropriate + ! levels + ! + select case(psb_toupper(what)) + case('SUB_SOLVE') + do ilev_=1,max(1,nlev_-1) + if (.not.allocated(p%precv(ilev_)%sm)) then + write(psb_err_unit,*) name,& + & ': Error: uninitialized preconditioner component,',& + & ' should call MLD_PRECINIT' + info = -1 + return + endif + call onelev_set_solver(p%precv(ilev_),val,info) + + end do + + case('SUB_RESTR','SUB_PROL',& + & 'SUB_REN','SUB_OVR','SUB_FILLIN') + do ilev_=1,max(1,nlev_-1) + call p%precv(ilev_)%set(what,val,info) + end do + + case('SMOOTHER_SWEEPS') + do ilev_=1,max(1,nlev_-1) + call p%precv(ilev_)%set(what,val,info) + end do + + case('SMOOTHER_TYPE') + do ilev_=1,max(1,nlev_-1) + call onelev_set_smoother(p%precv(ilev_),val,info) + end do + + case('ML_TYPE','AGGR_ALG','AGGR_KIND',& + & 'SMOOTHER_SWEEPS_PRE','SMOOTHER_SWEEPS_POST',& + & 'SMOOTHER_POS','AGGR_OMEGA_ALG',& + & 'AGGR_EIG','AGGR_FILTER') + do ilev_=1,nlev_ + call p%precv(ilev_)%set(what,val,info) + end do + + case('COARSE_MAT') + if (nlev_ > 1) then + call p%precv(nlev_)%set('COARSE_MAT',val,info) + end if + + case('COARSE_SOLVE') + if (nlev_ > 1) then + + call p%precv(nlev_)%set('COARSE_SOLVE',val,info) + select case (val) + case(mld_bjac_) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) +#if defined(HAVE_UMF_) + call onelev_set_solver(p%precv(nlev_),mld_umf_,info) +#elif defined(HAVE_SLU_) + call onelev_set_solver(p%precv(nlev_),mld_slu_,info) +#else + call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) +#endif + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) + call onelev_set_solver(p%precv(nlev_),val,info) + call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info) + case(mld_sludist_) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) + call onelev_set_solver(p%precv(nlev_),val,info) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + case(mld_jac_) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) + call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + end select + + endif + + case('COARSE_SUBSOLVE') + if (nlev_ > 1) then + call onelev_set_solver(p%precv(nlev_),val,info) + endif + + case('COARSE_SWEEPS') + + if (nlev_ > 1) then + call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info) + end if + + case('COARSE_FILLIN') + if (nlev_ > 1) then + call p%precv(nlev_)%set('SUB_FILLIN',val,info) + end if + case default + do ilev_=1,nlev_ + call p%precv(ilev_)%set(what,val,info) + end do + end select + + endif + +contains + + subroutine onelev_set_smoother(level,val,info) + type(mld_z_onelev_type), intent(inout) :: level + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + info = psb_success_ + + ! + ! This here requires a bit more attention. + ! + select case (val) + case (mld_noprec_) + if (allocated(level%sm)) then + select type (sm => level%sm) + type is (mld_z_base_smoother_type) + ! do nothing + class default + call level%sm%free(info) + if (info == 0) deallocate(level%sm) + if (info == 0) allocate(mld_z_base_smoother_type ::& + & level%sm, stat=info) + if (info == 0) allocate(mld_z_id_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_z_base_smoother_type ::& + & level%sm, stat=info) + if (info ==0) allocate(mld_z_id_solver_type ::& + & level%sm%sv, stat=info) + endif + + case (mld_jac_) + if (allocated(level%sm)) then + select type (sm => level%sm) + class is (mld_z_jac_smoother_type) + ! do nothing + class default + call level%sm%free(info) + if (info == 0) deallocate(level%sm) + if (info == 0) allocate(mld_z_jac_smoother_type :: & + & level%sm, stat=info) + if (info == 0) allocate(mld_z_diag_solver_type :: & + & level%sm%sv, stat=info) + end select + else + allocate(mld_z_jac_smoother_type :: level%sm, stat=info) + if (info == 0) allocate(mld_z_diag_solver_type ::& + & level%sm%sv, stat=info) + endif + + case (mld_bjac_) + if (allocated(level%sm)) then + select type (sm => level%sm) + class is (mld_z_jac_smoother_type) + ! do nothing + class default + call level%sm%free(info) + if (info == 0) deallocate(level%sm) + if (info == 0) allocate(mld_z_jac_smoother_type ::& + & level%sm, stat=info) + if (info == 0) allocate(mld_z_ilu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_z_jac_smoother_type :: level%sm, stat=info) + if (info == 0) allocate(mld_z_ilu_solver_type ::& + & level%sm%sv, stat=info) + endif + + case (mld_as_) + if (allocated(level%sm)) then + select type (sm => level%sm) + class is (mld_z_as_smoother_type) + ! do nothing + class default + call level%sm%free(info) + if (info == 0) deallocate(level%sm) + if (info == 0) allocate(mld_z_as_smoother_type ::& + & level%sm, stat=info) + if (info == 0) allocate(mld_z_ilu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_z_as_smoother_type :: level%sm, stat=info) + if (info == 0) allocate(mld_z_ilu_solver_type ::& + & level%sm%sv, stat=info) + endif + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if (allocated(level%sm)) & + & call level%sm%default() + + end subroutine onelev_set_smoother + + subroutine onelev_set_solver(level,val,info) + type(mld_z_onelev_type), intent(inout) :: level + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + info = psb_success_ + + ! + ! This here requires a bit more attention. + ! + select case (val) + case (mld_f_none_) + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_z_id_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_z_id_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_z_id_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) & + & call level%sm%sv%default() + end if + + + case (mld_diag_scale_) + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_z_diag_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_z_diag_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_z_diag_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) & + & call level%sm%sv%default() + end if + + + case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_z_ilu_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_z_ilu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_z_ilu_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) & + & call level%sm%sv%default() + end if + call level%sm%sv%set('SUB_SOLVE',val,info) + +#ifdef HAVE_UMF_ + case (mld_umf_) + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_z_umf_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_z_umf_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_z_umf_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) & + & call level%sm%sv%default() + end if +#endif +#ifdef HAVE_SLU_ + case (mld_slu_) + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_z_slu_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_z_slu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_z_slu_solver_type :: level%sm%sv, stat=info) + endif + if (allocated(level%sm)) then + if (allocated(level%sm%sv)) & + & call level%sm%sv%default() + end if +#endif + case default + ! + ! Do nothing and hope for the best :) + ! + end select + + end subroutine onelev_set_solver + + +end subroutine mld_zcprecseti + +! +! Subroutine: mld_zprecsetc +! Version: real +! +! This routine sets the character parameters defining the preconditioner. More +! precisely, the character parameter identified by 'what' is assigned the value +! contained in 'val'. +! For the multilevel preconditioners, the levels are numbered in increasing +! order starting from the finest one, i.e. level 1 is the finest level. +! +! To set integer and real parameters, see mld_zprecseti and mld_zprecsetr, +! respectively. +! +! +! Arguments: +! p - type(mld_zprec_type), input/output. +! The preconditioner data structure. +! what - integer, input. +! The number identifying the parameter to be set. +! A mnemonic constant has been associated to each of these +! numbers, as reported in the MLD2P4 User's and Reference Guide. +! string - character(len=*), input. +! The value of the parameter to be set. The list of allowed +! values is reported in the MLD2P4 User's and Reference Guide. +! info - integer, output. +! Error code. +! ilev - integer, optional, input. +! For the multilevel preconditioner, the level at which the +! preconditioner parameter has to be set. +! If nlev is not present, the parameter identified by 'what' +! is set at all the appropriate levels. +! +! NOTE: currently, the use of the argument ilev is not "safe" and is reserved to +! MLD2P4 developers. Indeed, by using ilev it is possible to set different values +! of the same parameter at different levels 1,...,nlev-1, even in cases where +! the parameter must have the same value at all the levels but the coarsest one. +! For this reason, the interface mld_precset to this routine has been built in +! such a way that ilev is not visible to the user (see mld_prec_mod.f90). +! +subroutine mld_zcprecsetc(p,what,string,info,ilev) + + use psb_base_mod + use mld_z_prec_mod, mld_protect_name => mld_zcprecsetc + + implicit none + + ! Arguments + class(mld_zprec_type), intent(inout) :: p + character(len=*), intent(in) :: what + character(len=*), intent(in) :: string + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev + + ! Local variables + integer(psb_ipk_) :: ilev_, nlev_,val + character(len=*), parameter :: name='mld_precsetc' + + info = psb_success_ + + if (.not.allocated(p%precv)) then + info = 3111 + return + endif + nlev_ = size(p%precv) + + if (present(ilev)) then + ilev_ = ilev + else + ilev_ = 1 + end if + + if ((ilev_<1).or.(ilev_ > nlev_)) then + write(psb_err_unit,*) name,& + & ': Error: invalid ILEV/NLEV combination',ilev_, nlev_ + info = -1 + return + endif + + val = mld_stringval(string) + if (val >=0) then + call p%set(what,val,info,ilev=ilev) + else + call p%precv(ilev_)%set(what,val,info) + end if + +end subroutine mld_zcprecsetc + + +! +! Subroutine: mld_zprecsetr +! Version: real +! +! This routine sets the real parameters defining the preconditioner. More +! precisely, the real parameter identified by 'what' is assigned the value +! contained in 'val'. +! For the multilevel preconditioners, the levels are numbered in increasing +! order starting from the finest one, i.e. level 1 is the finest level. +! +! To set integer and character parameters, see mld_zprecseti and mld_zprecsetc, +! respectively. +! +! Arguments: +! p - type(mld_zprec_type), input/output. +! The preconditioner data structure. +! what - integer, input. +! The number identifying the parameter to be set. +! A mnemonic constant has been associated to each of these +! numbers, as reported in the MLD2P4 User's and Reference Guide. +! val - real(psb_dpk_), input. +! The value of the parameter to be set. The list of allowed +! values is reported in the MLD2P4 User's and Reference Guide. +! info - integer, output. +! Error code. +! ilev - integer, optional, input. +! For the multilevel preconditioner, the level at which the +! preconditioner parameter has to be set. +! If nlev is not present, the parameter identified by 'what' +! is set at all the appropriate levels. +! +! NOTE: currently, the use of the argument ilev is not "safe" and is reserved to +! MLD2P4 developers. Indeed, by using ilev it is possible to set different values +! of the same parameter at different levels 1,...,nlev-1, even in cases where +! the parameter must have the same value at all the levels but the coarsest one. +! For this reason, the interface mld_precset to this routine has been built in +! such a way that ilev is not visible to the user (see mld_prec_mod.f90). +! +subroutine mld_zcprecsetr(p,what,val,info,ilev) + + use psb_base_mod + use mld_z_prec_mod, mld_protect_name => mld_zcprecsetr + + implicit none + + ! Arguments + class(mld_zprec_type), intent(inout) :: p + character(len=*), intent(in) :: what + real(psb_dpk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev + +! Local variables + integer(psb_ipk_) :: ilev_,nlev_ + character(len=*), parameter :: name='mld_precsetr' + + info = psb_success_ + + if (present(ilev)) then + ilev_ = ilev + else + ilev_ = 1 + end if + + if (.not.allocated(p%precv)) then + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner,',& + &' should call MLD_PRECINIT' + info = 3111 + return + endif + nlev_ = size(p%precv) + + if ((ilev_<1).or.(ilev_ > nlev_)) then + write(psb_err_unit,*) name,& + & ': Error: invalid ILEV/NLEV combination',& + & ilev_, nlev_ + info = -1 + return + endif + + ! + ! Set preconditioner parameters at level ilev. + ! + if (present(ilev)) then + + call p%precv(ilev_)%set(what,val,info) + + else if (.not.present(ilev)) then + ! + ! ilev not specified: set preconditioner parameters at all the appropriate levels + ! + + select case(psb_toupper(what)) + case('COARSE_ILUTHRS') + ilev_=nlev_ + call p%precv(ilev_)%set('SUB_ILUTHRS',val,info) + + case default + + do ilev_=1,nlev_ + call p%precv(ilev_)%set(what,val,info) + end do + end select + + endif + +end subroutine mld_zcprecsetr + + diff --git a/mlprec/impl/mld_zprecset.F90 b/mlprec/impl/mld_zprecset.F90 index 773b4116..8476eb7c 100644 --- a/mlprec/impl/mld_zprecset.F90 +++ b/mlprec/impl/mld_zprecset.F90 @@ -892,130 +892,3 @@ subroutine mld_zprecsetr(p,what,val,info,ilev) end subroutine mld_zprecsetr - - - -subroutine mld_zcprecseti(p,what,val,info,ilev) - - use psb_base_mod - use mld_z_prec_mod, mld_protect_name => mld_zcprecseti - use mld_z_jac_smoother - use mld_z_as_smoother - use mld_z_diag_solver - use mld_z_ilu_solver - use mld_z_id_solver -#if defined(HAVE_UMF_) - use mld_z_umf_solver -#endif -#if defined(HAVE_SLU_) - use mld_z_slu_solver -#endif - - implicit none - - ! Arguments - class(mld_zprec_type), intent(inout) :: p - character(len=*), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: ilev - - ! Local variables - integer(psb_ipk_) :: ilev_, nlev_ - character(len=*), parameter :: name='mld_precseti' - - info = psb_success_ - - -end subroutine mld_zcprecseti - - -subroutine mld_zcprecsetc(p,what,string,info,ilev) - - use psb_base_mod - use mld_z_prec_mod, mld_protect_name => mld_zcprecsetc - - implicit none - - ! Arguments - class(mld_zprec_type), intent(inout) :: p - character(len=*), intent(in) :: what - character(len=*), intent(in) :: string - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: ilev - - ! Local variables - integer(psb_ipk_) :: ilev_, nlev_,val - character(len=*), parameter :: name='mld_precsetc' - - info = psb_success_ - - if (.not.allocated(p%precv)) then - info = 3111 - return - endif - nlev_ = size(p%precv) - - if (present(ilev)) then - ilev_ = ilev - else - ilev_ = 1 - end if - - if ((ilev_<1).or.(ilev_ > nlev_)) then - write(psb_err_unit,*) name,& - & ': Error: invalid ILEV/NLEV combination',ilev_, nlev_ - info = -1 - return - endif - - -end subroutine mld_zcprecsetc - -subroutine mld_zcprecsetr(p,what,val,info,ilev) - - use psb_base_mod - use mld_z_prec_mod, mld_protect_name => mld_zcprecsetr - - implicit none - - ! Arguments - class(mld_zprec_type), intent(inout) :: p - character(len=*), intent(in) :: what - real(psb_dpk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: ilev - -! Local variables - integer(psb_ipk_) :: ilev_,nlev_ - character(len=*), parameter :: name='mld_precsetr' - - info = psb_success_ - - if (present(ilev)) then - ilev_ = ilev - else - ilev_ = 1 - end if - - if (.not.allocated(p%precv)) then - write(psb_err_unit,*) name,& - &': Error: uninitialized preconditioner,',& - &' should call MLD_PRECINIT' - info = 3111 - return - endif - nlev_ = size(p%precv) - - if ((ilev_<1).or.(ilev_ > nlev_)) then - write(psb_err_unit,*) name,& - & ': Error: invalid ILEV/NLEV combination',& - & ilev_, nlev_ - info = -1 - return - endif - - - - -end subroutine mld_zcprecsetr diff --git a/mlprec/impl/smoother/Makefile b/mlprec/impl/smoother/Makefile index 8fac6f78..f6886cbf 100644 --- a/mlprec/impl/smoother/Makefile +++ b/mlprec/impl/smoother/Makefile @@ -15,10 +15,8 @@ mld_c_as_smoother_dmp.o \ mld_c_as_smoother_free.o \ mld_c_as_smoother_setc.o \ mld_c_as_smoother_seti.o \ -mld_c_as_smoother_setr.o \ mld_c_as_smoother_csetc.o \ mld_c_as_smoother_cseti.o \ -mld_c_as_smoother_csetr.o \ mld_c_base_smoother_apply.o \ mld_c_base_smoother_apply_vect.o \ mld_c_base_smoother_bld.o \ @@ -43,10 +41,8 @@ mld_d_as_smoother_dmp.o \ mld_d_as_smoother_free.o \ mld_d_as_smoother_setc.o \ mld_d_as_smoother_seti.o \ -mld_d_as_smoother_setr.o \ mld_d_as_smoother_csetc.o \ mld_d_as_smoother_cseti.o \ -mld_d_as_smoother_csetr.o \ mld_d_base_smoother_apply.o \ mld_d_base_smoother_apply_vect.o \ mld_d_base_smoother_bld.o \ @@ -71,10 +67,8 @@ mld_s_as_smoother_dmp.o \ mld_s_as_smoother_free.o \ mld_s_as_smoother_setc.o \ mld_s_as_smoother_seti.o \ -mld_s_as_smoother_setr.o \ mld_s_as_smoother_csetc.o \ mld_s_as_smoother_cseti.o \ -mld_s_as_smoother_csetr.o \ mld_s_base_smoother_apply.o \ mld_s_base_smoother_apply_vect.o \ mld_s_base_smoother_bld.o \ @@ -99,10 +93,8 @@ mld_z_as_smoother_dmp.o \ mld_z_as_smoother_free.o \ mld_z_as_smoother_setc.o \ mld_z_as_smoother_seti.o \ -mld_z_as_smoother_setr.o \ mld_z_as_smoother_csetc.o \ mld_z_as_smoother_cseti.o \ -mld_z_as_smoother_csetr.o \ mld_z_base_smoother_apply.o \ mld_z_base_smoother_apply_vect.o \ mld_z_base_smoother_bld.o \ diff --git a/mlprec/impl/smoother/mld_c_as_smoother_csetc.f90 b/mlprec/impl/smoother/mld_c_as_smoother_csetc.f90 index 29b85afa..62ad4dd4 100644 --- a/mlprec/impl/smoother/mld_c_as_smoother_csetc.f90 +++ b/mlprec/impl/smoother/mld_c_as_smoother_csetc.f90 @@ -53,13 +53,11 @@ subroutine mld_c_as_smoother_csetc(sm,what,val,info) call psb_erractionsave(err_act) - ival = mld_stringval(val) + ival = sm%stringval(val) if (ival >= 0) then call sm%set(what,ival,info) else - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if + call sm%mld_c_base_smoother_type%set(what,val,info) end if if (info /= psb_success_) then diff --git a/mlprec/impl/smoother/mld_c_as_smoother_cseti.f90 b/mlprec/impl/smoother/mld_c_as_smoother_cseti.f90 index 0939de39..45bd0f51 100644 --- a/mlprec/impl/smoother/mld_c_as_smoother_cseti.f90 +++ b/mlprec/impl/smoother/mld_c_as_smoother_cseti.f90 @@ -44,9 +44,9 @@ subroutine mld_c_as_smoother_cseti(sm,what,val,info) ! Arguments class(mld_c_as_smoother_type), intent(inout) :: sm - character(len=*), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act character(len=20) :: name='c_as_smoother_cseti' @@ -54,8 +54,6 @@ subroutine mld_c_as_smoother_cseti(sm,what,val,info) call psb_erractionsave(err_act) select case(what) -!!$ case('SMOOTHER_SWEEPS') -!!$ sm%sweeps = val case('SUB_OVR') sm%novr = val case('SUB_RESTR') @@ -63,9 +61,7 @@ subroutine mld_c_as_smoother_cseti(sm,what,val,info) case('SUB_PROL') sm%prol = val case default - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if + call sm%mld_c_base_smoother_type%set(what,val,info) end select call psb_erractionrestore(err_act) diff --git a/mlprec/impl/smoother/mld_c_as_smoother_setc.f90 b/mlprec/impl/smoother/mld_c_as_smoother_setc.f90 index 9c9fb302..a2b36290 100644 --- a/mlprec/impl/smoother/mld_c_as_smoother_setc.f90 +++ b/mlprec/impl/smoother/mld_c_as_smoother_setc.f90 @@ -53,13 +53,11 @@ subroutine mld_c_as_smoother_setc(sm,what,val,info) call psb_erractionsave(err_act) - ival = mld_stringval(val) + ival = sm%stringval(val) if (ival >= 0) then call sm%set(what,ival,info) else - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if + call sm%mld_c_base_smoother_type%set(what,val,info) end if if (info /= psb_success_) then diff --git a/mlprec/impl/smoother/mld_c_as_smoother_seti.f90 b/mlprec/impl/smoother/mld_c_as_smoother_seti.f90 index b7c2d328..c8e8be47 100644 --- a/mlprec/impl/smoother/mld_c_as_smoother_seti.f90 +++ b/mlprec/impl/smoother/mld_c_as_smoother_seti.f90 @@ -54,8 +54,6 @@ subroutine mld_c_as_smoother_seti(sm,what,val,info) call psb_erractionsave(err_act) select case(what) -!!$ case(mld_smoother_sweeps_) -!!$ sm%sweeps = val case(mld_sub_ovr_) sm%novr = val case(mld_sub_restr_) @@ -63,9 +61,7 @@ subroutine mld_c_as_smoother_seti(sm,what,val,info) case(mld_sub_prol_) sm%prol = val case default - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if + call sm%mld_c_base_smoother_type%set(what,val,info) end select call psb_erractionrestore(err_act) diff --git a/mlprec/impl/smoother/mld_c_base_smoother_csetc.f90 b/mlprec/impl/smoother/mld_c_base_smoother_csetc.f90 index 07bd90d5..05f67642 100644 --- a/mlprec/impl/smoother/mld_c_base_smoother_csetc.f90 +++ b/mlprec/impl/smoother/mld_c_base_smoother_csetc.f90 @@ -54,7 +54,7 @@ subroutine mld_c_base_smoother_csetc(sm,what,val,info) info = psb_success_ - ival = mld_stringval(val) + ival = sm%stringval(val) if (ival >= 0) then call sm%set(what,ival,info) else diff --git a/mlprec/impl/smoother/mld_c_base_smoother_setc.f90 b/mlprec/impl/smoother/mld_c_base_smoother_setc.f90 index f8f59827..3d60947d 100644 --- a/mlprec/impl/smoother/mld_c_base_smoother_setc.f90 +++ b/mlprec/impl/smoother/mld_c_base_smoother_setc.f90 @@ -54,7 +54,7 @@ subroutine mld_c_base_smoother_setc(sm,what,val,info) info = psb_success_ - ival = mld_stringval(val) + ival = sm%stringval(val) if (ival >= 0) then call sm%set(what,ival,info) else diff --git a/mlprec/impl/smoother/mld_d_as_smoother_csetc.f90 b/mlprec/impl/smoother/mld_d_as_smoother_csetc.f90 index b770d28f..87337584 100644 --- a/mlprec/impl/smoother/mld_d_as_smoother_csetc.f90 +++ b/mlprec/impl/smoother/mld_d_as_smoother_csetc.f90 @@ -53,13 +53,11 @@ subroutine mld_d_as_smoother_csetc(sm,what,val,info) call psb_erractionsave(err_act) - ival = mld_stringval(val) + ival = sm%stringval(val) if (ival >= 0) then call sm%set(what,ival,info) else - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if + call sm%mld_d_base_smoother_type%set(what,val,info) end if if (info /= psb_success_) then diff --git a/mlprec/impl/smoother/mld_d_as_smoother_cseti.f90 b/mlprec/impl/smoother/mld_d_as_smoother_cseti.f90 index 4b195909..b49117ca 100644 --- a/mlprec/impl/smoother/mld_d_as_smoother_cseti.f90 +++ b/mlprec/impl/smoother/mld_d_as_smoother_cseti.f90 @@ -44,9 +44,9 @@ subroutine mld_d_as_smoother_cseti(sm,what,val,info) ! Arguments class(mld_d_as_smoother_type), intent(inout) :: sm - character(len=*), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act character(len=20) :: name='d_as_smoother_cseti' @@ -54,8 +54,6 @@ subroutine mld_d_as_smoother_cseti(sm,what,val,info) call psb_erractionsave(err_act) select case(what) -!!$ case('SMOOTHER_SWEEPS') -!!$ sm%sweeps = val case('SUB_OVR') sm%novr = val case('SUB_RESTR') @@ -63,9 +61,7 @@ subroutine mld_d_as_smoother_cseti(sm,what,val,info) case('SUB_PROL') sm%prol = val case default - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if + call sm%mld_d_base_smoother_type%set(what,val,info) end select call psb_erractionrestore(err_act) diff --git a/mlprec/impl/smoother/mld_d_as_smoother_setc.f90 b/mlprec/impl/smoother/mld_d_as_smoother_setc.f90 index a6b04c59..1a9e455e 100644 --- a/mlprec/impl/smoother/mld_d_as_smoother_setc.f90 +++ b/mlprec/impl/smoother/mld_d_as_smoother_setc.f90 @@ -53,13 +53,11 @@ subroutine mld_d_as_smoother_setc(sm,what,val,info) call psb_erractionsave(err_act) - ival = mld_stringval(val) + ival = sm%stringval(val) if (ival >= 0) then call sm%set(what,ival,info) else - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if + call sm%mld_d_base_smoother_type%set(what,val,info) end if if (info /= psb_success_) then diff --git a/mlprec/impl/smoother/mld_d_as_smoother_seti.f90 b/mlprec/impl/smoother/mld_d_as_smoother_seti.f90 index ee1ebaa2..a0f6af39 100644 --- a/mlprec/impl/smoother/mld_d_as_smoother_seti.f90 +++ b/mlprec/impl/smoother/mld_d_as_smoother_seti.f90 @@ -54,8 +54,6 @@ subroutine mld_d_as_smoother_seti(sm,what,val,info) call psb_erractionsave(err_act) select case(what) -!!$ case(mld_smoother_sweeps_) -!!$ sm%sweeps = val case(mld_sub_ovr_) sm%novr = val case(mld_sub_restr_) @@ -63,9 +61,7 @@ subroutine mld_d_as_smoother_seti(sm,what,val,info) case(mld_sub_prol_) sm%prol = val case default - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if + call sm%mld_d_base_smoother_type%set(what,val,info) end select call psb_erractionrestore(err_act) diff --git a/mlprec/impl/smoother/mld_d_base_smoother_csetc.f90 b/mlprec/impl/smoother/mld_d_base_smoother_csetc.f90 index a4e1bd60..a9937282 100644 --- a/mlprec/impl/smoother/mld_d_base_smoother_csetc.f90 +++ b/mlprec/impl/smoother/mld_d_base_smoother_csetc.f90 @@ -54,7 +54,7 @@ subroutine mld_d_base_smoother_csetc(sm,what,val,info) info = psb_success_ - ival = mld_stringval(val) + ival = sm%stringval(val) if (ival >= 0) then call sm%set(what,ival,info) else diff --git a/mlprec/impl/smoother/mld_d_base_smoother_setc.f90 b/mlprec/impl/smoother/mld_d_base_smoother_setc.f90 index 83bb75b8..c6748adf 100644 --- a/mlprec/impl/smoother/mld_d_base_smoother_setc.f90 +++ b/mlprec/impl/smoother/mld_d_base_smoother_setc.f90 @@ -54,7 +54,7 @@ subroutine mld_d_base_smoother_setc(sm,what,val,info) info = psb_success_ - ival = mld_stringval(val) + ival = sm%stringval(val) if (ival >= 0) then call sm%set(what,ival,info) else diff --git a/mlprec/impl/smoother/mld_s_as_smoother_csetc.f90 b/mlprec/impl/smoother/mld_s_as_smoother_csetc.f90 index 1609c97f..9dc53d7c 100644 --- a/mlprec/impl/smoother/mld_s_as_smoother_csetc.f90 +++ b/mlprec/impl/smoother/mld_s_as_smoother_csetc.f90 @@ -53,13 +53,11 @@ subroutine mld_s_as_smoother_csetc(sm,what,val,info) call psb_erractionsave(err_act) - ival = mld_stringval(val) + ival = sm%stringval(val) if (ival >= 0) then call sm%set(what,ival,info) else - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if + call sm%mld_s_base_smoother_type%set(what,val,info) end if if (info /= psb_success_) then diff --git a/mlprec/impl/smoother/mld_s_as_smoother_cseti.f90 b/mlprec/impl/smoother/mld_s_as_smoother_cseti.f90 index 1e40e4a4..b5b8fdc4 100644 --- a/mlprec/impl/smoother/mld_s_as_smoother_cseti.f90 +++ b/mlprec/impl/smoother/mld_s_as_smoother_cseti.f90 @@ -44,9 +44,9 @@ subroutine mld_s_as_smoother_cseti(sm,what,val,info) ! Arguments class(mld_s_as_smoother_type), intent(inout) :: sm - character(len=*), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act character(len=20) :: name='s_as_smoother_cseti' @@ -54,8 +54,6 @@ subroutine mld_s_as_smoother_cseti(sm,what,val,info) call psb_erractionsave(err_act) select case(what) -!!$ case('SMOOTHER_SWEEPS') -!!$ sm%sweeps = val case('SUB_OVR') sm%novr = val case('SUB_RESTR') @@ -63,9 +61,7 @@ subroutine mld_s_as_smoother_cseti(sm,what,val,info) case('SUB_PROL') sm%prol = val case default - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if + call sm%mld_s_base_smoother_type%set(what,val,info) end select call psb_erractionrestore(err_act) diff --git a/mlprec/impl/smoother/mld_s_as_smoother_setc.f90 b/mlprec/impl/smoother/mld_s_as_smoother_setc.f90 index c59d7002..bbdce8ba 100644 --- a/mlprec/impl/smoother/mld_s_as_smoother_setc.f90 +++ b/mlprec/impl/smoother/mld_s_as_smoother_setc.f90 @@ -53,13 +53,11 @@ subroutine mld_s_as_smoother_setc(sm,what,val,info) call psb_erractionsave(err_act) - ival = mld_stringval(val) + ival = sm%stringval(val) if (ival >= 0) then call sm%set(what,ival,info) else - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if + call sm%mld_s_base_smoother_type%set(what,val,info) end if if (info /= psb_success_) then diff --git a/mlprec/impl/smoother/mld_s_as_smoother_seti.f90 b/mlprec/impl/smoother/mld_s_as_smoother_seti.f90 index c0bfac0e..28a345e3 100644 --- a/mlprec/impl/smoother/mld_s_as_smoother_seti.f90 +++ b/mlprec/impl/smoother/mld_s_as_smoother_seti.f90 @@ -54,8 +54,6 @@ subroutine mld_s_as_smoother_seti(sm,what,val,info) call psb_erractionsave(err_act) select case(what) -!!$ case(mld_smoother_sweeps_) -!!$ sm%sweeps = val case(mld_sub_ovr_) sm%novr = val case(mld_sub_restr_) @@ -63,9 +61,7 @@ subroutine mld_s_as_smoother_seti(sm,what,val,info) case(mld_sub_prol_) sm%prol = val case default - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if + call sm%mld_s_base_smoother_type%set(what,val,info) end select call psb_erractionrestore(err_act) diff --git a/mlprec/impl/smoother/mld_s_base_smoother_csetc.f90 b/mlprec/impl/smoother/mld_s_base_smoother_csetc.f90 index 7282caae..b56bd68d 100644 --- a/mlprec/impl/smoother/mld_s_base_smoother_csetc.f90 +++ b/mlprec/impl/smoother/mld_s_base_smoother_csetc.f90 @@ -54,7 +54,7 @@ subroutine mld_s_base_smoother_csetc(sm,what,val,info) info = psb_success_ - ival = mld_stringval(val) + ival = sm%stringval(val) if (ival >= 0) then call sm%set(what,ival,info) else diff --git a/mlprec/impl/smoother/mld_s_base_smoother_setc.f90 b/mlprec/impl/smoother/mld_s_base_smoother_setc.f90 index 4a3359ee..40ce854e 100644 --- a/mlprec/impl/smoother/mld_s_base_smoother_setc.f90 +++ b/mlprec/impl/smoother/mld_s_base_smoother_setc.f90 @@ -54,7 +54,7 @@ subroutine mld_s_base_smoother_setc(sm,what,val,info) info = psb_success_ - ival = mld_stringval(val) + ival = sm%stringval(val) if (ival >= 0) then call sm%set(what,ival,info) else diff --git a/mlprec/impl/smoother/mld_z_as_smoother_csetc.f90 b/mlprec/impl/smoother/mld_z_as_smoother_csetc.f90 index 0f434284..fc613036 100644 --- a/mlprec/impl/smoother/mld_z_as_smoother_csetc.f90 +++ b/mlprec/impl/smoother/mld_z_as_smoother_csetc.f90 @@ -53,13 +53,11 @@ subroutine mld_z_as_smoother_csetc(sm,what,val,info) call psb_erractionsave(err_act) - ival = mld_stringval(val) + ival = sm%stringval(val) if (ival >= 0) then call sm%set(what,ival,info) else - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if + call sm%mld_z_base_smoother_type%set(what,val,info) end if if (info /= psb_success_) then diff --git a/mlprec/impl/smoother/mld_z_as_smoother_cseti.f90 b/mlprec/impl/smoother/mld_z_as_smoother_cseti.f90 index 12a28d12..0d09d6c0 100644 --- a/mlprec/impl/smoother/mld_z_as_smoother_cseti.f90 +++ b/mlprec/impl/smoother/mld_z_as_smoother_cseti.f90 @@ -44,9 +44,9 @@ subroutine mld_z_as_smoother_cseti(sm,what,val,info) ! Arguments class(mld_z_as_smoother_type), intent(inout) :: sm - character(len=*), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act character(len=20) :: name='z_as_smoother_cseti' @@ -54,8 +54,6 @@ subroutine mld_z_as_smoother_cseti(sm,what,val,info) call psb_erractionsave(err_act) select case(what) -!!$ case('SMOOTHER_SWEEPS') -!!$ sm%sweeps = val case('SUB_OVR') sm%novr = val case('SUB_RESTR') @@ -63,9 +61,7 @@ subroutine mld_z_as_smoother_cseti(sm,what,val,info) case('SUB_PROL') sm%prol = val case default - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if + call sm%mld_z_base_smoother_type%set(what,val,info) end select call psb_erractionrestore(err_act) diff --git a/mlprec/impl/smoother/mld_z_as_smoother_setc.f90 b/mlprec/impl/smoother/mld_z_as_smoother_setc.f90 index a37467c0..b9af9080 100644 --- a/mlprec/impl/smoother/mld_z_as_smoother_setc.f90 +++ b/mlprec/impl/smoother/mld_z_as_smoother_setc.f90 @@ -53,13 +53,11 @@ subroutine mld_z_as_smoother_setc(sm,what,val,info) call psb_erractionsave(err_act) - ival = mld_stringval(val) + ival = sm%stringval(val) if (ival >= 0) then call sm%set(what,ival,info) else - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if + call sm%mld_z_base_smoother_type%set(what,val,info) end if if (info /= psb_success_) then diff --git a/mlprec/impl/smoother/mld_z_as_smoother_seti.f90 b/mlprec/impl/smoother/mld_z_as_smoother_seti.f90 index 739a7f00..4b26d1d7 100644 --- a/mlprec/impl/smoother/mld_z_as_smoother_seti.f90 +++ b/mlprec/impl/smoother/mld_z_as_smoother_seti.f90 @@ -54,8 +54,6 @@ subroutine mld_z_as_smoother_seti(sm,what,val,info) call psb_erractionsave(err_act) select case(what) -!!$ case(mld_smoother_sweeps_) -!!$ sm%sweeps = val case(mld_sub_ovr_) sm%novr = val case(mld_sub_restr_) @@ -63,9 +61,7 @@ subroutine mld_z_as_smoother_seti(sm,what,val,info) case(mld_sub_prol_) sm%prol = val case default - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if + call sm%mld_z_base_smoother_type%set(what,val,info) end select call psb_erractionrestore(err_act) diff --git a/mlprec/impl/smoother/mld_z_base_smoother_csetc.f90 b/mlprec/impl/smoother/mld_z_base_smoother_csetc.f90 index 9b462b4f..23ce95e3 100644 --- a/mlprec/impl/smoother/mld_z_base_smoother_csetc.f90 +++ b/mlprec/impl/smoother/mld_z_base_smoother_csetc.f90 @@ -54,7 +54,7 @@ subroutine mld_z_base_smoother_csetc(sm,what,val,info) info = psb_success_ - ival = mld_stringval(val) + ival = sm%stringval(val) if (ival >= 0) then call sm%set(what,ival,info) else diff --git a/mlprec/impl/smoother/mld_z_base_smoother_setc.f90 b/mlprec/impl/smoother/mld_z_base_smoother_setc.f90 index 8216e6a6..e9fb4c13 100644 --- a/mlprec/impl/smoother/mld_z_base_smoother_setc.f90 +++ b/mlprec/impl/smoother/mld_z_base_smoother_setc.f90 @@ -54,7 +54,7 @@ subroutine mld_z_base_smoother_setc(sm,what,val,info) info = psb_success_ - ival = mld_stringval(val) + ival = sm%stringval(val) if (ival >= 0) then call sm%set(what,ival,info) else diff --git a/mlprec/impl/solver/mld_c_base_solver_csetc.f90 b/mlprec/impl/solver/mld_c_base_solver_csetc.f90 index 2c498d59..7f1e3fe5 100644 --- a/mlprec/impl/solver/mld_c_base_solver_csetc.f90 +++ b/mlprec/impl/solver/mld_c_base_solver_csetc.f90 @@ -53,7 +53,7 @@ subroutine mld_c_base_solver_csetc(sv,what,val,info) info = psb_success_ - ival = mld_stringval(val) + ival = sv%stringval(val) if (ival >=0) then call sv%set(what,ival,info) end if diff --git a/mlprec/impl/solver/mld_c_base_solver_setc.f90 b/mlprec/impl/solver/mld_c_base_solver_setc.f90 index 7bea2b8f..a122619c 100644 --- a/mlprec/impl/solver/mld_c_base_solver_setc.f90 +++ b/mlprec/impl/solver/mld_c_base_solver_setc.f90 @@ -53,7 +53,7 @@ subroutine mld_c_base_solver_setc(sv,what,val,info) info = psb_success_ - ival = mld_stringval(val) + ival = sv%stringval(val) if (ival >=0) then call sv%set(what,ival,info) end if diff --git a/mlprec/impl/solver/mld_d_base_solver_csetc.f90 b/mlprec/impl/solver/mld_d_base_solver_csetc.f90 index 357261ff..7bad2433 100644 --- a/mlprec/impl/solver/mld_d_base_solver_csetc.f90 +++ b/mlprec/impl/solver/mld_d_base_solver_csetc.f90 @@ -53,7 +53,7 @@ subroutine mld_d_base_solver_csetc(sv,what,val,info) info = psb_success_ - ival = mld_stringval(val) + ival = sv%stringval(val) if (ival >=0) then call sv%set(what,ival,info) end if diff --git a/mlprec/impl/solver/mld_d_base_solver_setc.f90 b/mlprec/impl/solver/mld_d_base_solver_setc.f90 index 7b827a72..016aa6bd 100644 --- a/mlprec/impl/solver/mld_d_base_solver_setc.f90 +++ b/mlprec/impl/solver/mld_d_base_solver_setc.f90 @@ -53,7 +53,7 @@ subroutine mld_d_base_solver_setc(sv,what,val,info) info = psb_success_ - ival = mld_stringval(val) + ival = sv%stringval(val) if (ival >=0) then call sv%set(what,ival,info) end if diff --git a/mlprec/impl/solver/mld_s_base_solver_csetc.f90 b/mlprec/impl/solver/mld_s_base_solver_csetc.f90 index 16498da6..60689da5 100644 --- a/mlprec/impl/solver/mld_s_base_solver_csetc.f90 +++ b/mlprec/impl/solver/mld_s_base_solver_csetc.f90 @@ -53,7 +53,7 @@ subroutine mld_s_base_solver_csetc(sv,what,val,info) info = psb_success_ - ival = mld_stringval(val) + ival = sv%stringval(val) if (ival >=0) then call sv%set(what,ival,info) end if diff --git a/mlprec/impl/solver/mld_s_base_solver_setc.f90 b/mlprec/impl/solver/mld_s_base_solver_setc.f90 index 915c6b7f..270953e3 100644 --- a/mlprec/impl/solver/mld_s_base_solver_setc.f90 +++ b/mlprec/impl/solver/mld_s_base_solver_setc.f90 @@ -53,7 +53,7 @@ subroutine mld_s_base_solver_setc(sv,what,val,info) info = psb_success_ - ival = mld_stringval(val) + ival = sv%stringval(val) if (ival >=0) then call sv%set(what,ival,info) end if diff --git a/mlprec/impl/solver/mld_z_base_solver_csetc.f90 b/mlprec/impl/solver/mld_z_base_solver_csetc.f90 index db6e933e..f0d1adc2 100644 --- a/mlprec/impl/solver/mld_z_base_solver_csetc.f90 +++ b/mlprec/impl/solver/mld_z_base_solver_csetc.f90 @@ -53,7 +53,7 @@ subroutine mld_z_base_solver_csetc(sv,what,val,info) info = psb_success_ - ival = mld_stringval(val) + ival = sv%stringval(val) if (ival >=0) then call sv%set(what,ival,info) end if diff --git a/mlprec/impl/solver/mld_z_base_solver_setc.f90 b/mlprec/impl/solver/mld_z_base_solver_setc.f90 index 500dde36..a2918ce8 100644 --- a/mlprec/impl/solver/mld_z_base_solver_setc.f90 +++ b/mlprec/impl/solver/mld_z_base_solver_setc.f90 @@ -53,7 +53,7 @@ subroutine mld_z_base_solver_setc(sv,what,val,info) info = psb_success_ - ival = mld_stringval(val) + ival = sv%stringval(val) if (ival >=0) then call sv%set(what,ival,info) end if diff --git a/mlprec/mld_c_as_smoother.f90 b/mlprec/mld_c_as_smoother.f90 index 8e1a1a92..b8186684 100644 --- a/mlprec/mld_c_as_smoother.f90 +++ b/mlprec/mld_c_as_smoother.f90 @@ -63,10 +63,8 @@ module mld_c_as_smoother procedure, pass(sm) :: free => mld_c_as_smoother_free procedure, pass(sm) :: seti => mld_c_as_smoother_seti procedure, pass(sm) :: setc => mld_c_as_smoother_setc - procedure, pass(sm) :: setr => mld_c_as_smoother_setr procedure, pass(sm) :: cseti => mld_c_as_smoother_cseti procedure, pass(sm) :: csetc => mld_c_as_smoother_csetc - procedure, pass(sm) :: csetr => mld_c_as_smoother_csetr procedure, pass(sm) :: descr => c_as_smoother_descr procedure, pass(sm) :: sizeof => c_as_smoother_sizeof procedure, pass(sm) :: default => c_as_smoother_default diff --git a/mlprec/mld_c_base_smoother_mod.f90 b/mlprec/mld_c_base_smoother_mod.f90 index 8897ef60..8fdc5845 100644 --- a/mlprec/mld_c_base_smoother_mod.f90 +++ b/mlprec/mld_c_base_smoother_mod.f90 @@ -110,6 +110,7 @@ module mld_c_base_smoother_mod procedure, pass(sm) :: descr => mld_c_base_smoother_descr procedure, pass(sm) :: sizeof => c_base_smoother_sizeof procedure, pass(sm) :: get_nzeros => c_base_smoother_get_nzeros + procedure, nopass :: stringval => mld_stringval end type mld_c_base_smoother_type diff --git a/mlprec/mld_c_base_solver_mod.f90 b/mlprec/mld_c_base_solver_mod.f90 index 73e79574..3d2be13d 100644 --- a/mlprec/mld_c_base_solver_mod.f90 +++ b/mlprec/mld_c_base_solver_mod.f90 @@ -102,6 +102,7 @@ module mld_c_base_solver_mod procedure, pass(sv) :: descr => mld_c_base_solver_descr procedure, pass(sv) :: sizeof => c_base_solver_sizeof procedure, pass(sv) :: get_nzeros => c_base_solver_get_nzeros + procedure, nopass :: stringval => mld_stringval end type mld_c_base_solver_type private :: c_base_solver_sizeof, c_base_solver_default,& diff --git a/mlprec/mld_c_diag_solver.f90 b/mlprec/mld_c_diag_solver.f90 index b036ba5d..684bb154 100644 --- a/mlprec/mld_c_diag_solver.f90 +++ b/mlprec/mld_c_diag_solver.f90 @@ -55,19 +55,14 @@ module mld_c_diag_solver procedure, pass(sv) :: apply_v => mld_c_diag_solver_apply_vect procedure, pass(sv) :: apply_a => mld_c_diag_solver_apply procedure, pass(sv) :: free => c_diag_solver_free - procedure, pass(sv) :: seti => c_diag_solver_seti - procedure, pass(sv) :: setc => c_diag_solver_setc - procedure, pass(sv) :: setr => c_diag_solver_setr procedure, pass(sv) :: descr => c_diag_solver_descr procedure, pass(sv) :: sizeof => c_diag_solver_sizeof procedure, pass(sv) :: get_nzeros => c_diag_solver_get_nzeros end type mld_c_diag_solver_type - private :: c_diag_solver_free, c_diag_solver_seti, & - & c_diag_solver_setc, c_diag_solver_setr,& - & c_diag_solver_descr, c_diag_solver_sizeof,& - & c_diag_solver_get_nzeros + private :: c_diag_solver_free, c_diag_solver_descr, & + & c_diag_solver_sizeof, c_diag_solver_get_nzeros interface @@ -121,61 +116,6 @@ module mld_c_diag_solver contains - - subroutine c_diag_solver_seti(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_c_diag_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - Integer(Psb_ipk_) :: err_act - character(len=20) :: name='c_diag_solver_seti' - - info = psb_success_ - - - return - - end subroutine c_diag_solver_seti - - subroutine c_diag_solver_setc(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_c_diag_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - Integer(Psb_ipk_) :: err_act, ival - character(len=20) :: name='c_diag_solver_setc' - - info = psb_success_ - - return - end subroutine c_diag_solver_setc - - subroutine c_diag_solver_setr(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_c_diag_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what - real(psb_spk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - Integer(Psb_ipk_) :: err_act - character(len=20) :: name='c_diag_solver_setr' - - info = psb_success_ - - return - - end subroutine c_diag_solver_setr - subroutine c_diag_solver_free(sv,info) Implicit None diff --git a/mlprec/mld_c_id_solver.f90 b/mlprec/mld_c_id_solver.f90 index 2af6b760..ec1b40ee 100644 --- a/mlprec/mld_c_id_solver.f90 +++ b/mlprec/mld_c_id_solver.f90 @@ -53,16 +53,12 @@ module mld_c_id_solver procedure, pass(sv) :: apply_v => mld_c_id_solver_apply_vect procedure, pass(sv) :: apply_a => mld_c_id_solver_apply procedure, pass(sv) :: free => c_id_solver_free - procedure, pass(sv) :: seti => c_id_solver_seti - procedure, pass(sv) :: setc => c_id_solver_setc - procedure, pass(sv) :: setr => c_id_solver_setr procedure, pass(sv) :: descr => c_id_solver_descr end type mld_c_id_solver_type private :: c_id_solver_bld, & - & c_id_solver_free, c_id_solver_seti, & - & c_id_solver_setc, c_id_solver_setr,& + & c_id_solver_free, & & c_id_solver_descr interface @@ -124,60 +120,6 @@ contains return end subroutine c_id_solver_bld - - subroutine c_id_solver_seti(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_c_id_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - character(len=20) :: name='c_id_solver_seti' - - info = psb_success_ - - return - - end subroutine c_id_solver_seti - - subroutine c_id_solver_setc(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_c_id_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, ival - character(len=20) :: name='c_id_solver_setc' - - info = psb_success_ - - return - end subroutine c_id_solver_setc - - subroutine c_id_solver_setr(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_c_id_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what - real(psb_spk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - character(len=20) :: name='c_id_solver_setr' - - info = psb_success_ - - return - - end subroutine c_id_solver_setr - subroutine c_id_solver_free(sv,info) Implicit None diff --git a/mlprec/mld_c_ilu_solver.f90 b/mlprec/mld_c_ilu_solver.f90 index e5a16c65..6232ea75 100644 --- a/mlprec/mld_c_ilu_solver.f90 +++ b/mlprec/mld_c_ilu_solver.f90 @@ -231,8 +231,7 @@ contains case(mld_sub_fillin_) sv%fill_in = val case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 + call sv%mld_c_base_solver_type%set(what,val,info) end select call psb_erractionrestore(err_act) @@ -263,7 +262,7 @@ contains call psb_erractionsave(err_act) - ival = mld_stringval(val) + ival = sv%stringval(val) if (ival >= 0) then call sv%set(what,ival,info) end if @@ -305,9 +304,7 @@ contains case(mld_sub_iluthrs_) sv%thresh = val case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ goto 9999 + call sv%mld_c_base_solver_type%set(what,val,info) end select call psb_erractionrestore(err_act) @@ -343,8 +340,7 @@ contains case('SUB_FILLIN') sv%fill_in = val case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 + call sv%mld_c_base_solver_type%set(what,val,info) end select call psb_erractionrestore(err_act) @@ -375,7 +371,7 @@ contains call psb_erractionsave(err_act) - ival = mld_stringval(val) + ival = sv%stringval(val) if (ival >= 0) then call sv%set(what,ival,info) end if @@ -417,9 +413,7 @@ contains case('SUB_ILUTHRS') sv%thresh = val case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ goto 9999 + call sv%mld_c_base_solver_type%set(what,val,info) end select call psb_erractionrestore(err_act) diff --git a/mlprec/mld_c_jac_smoother.f90 b/mlprec/mld_c_jac_smoother.f90 index 6d2268f0..c66e91b3 100644 --- a/mlprec/mld_c_jac_smoother.f90 +++ b/mlprec/mld_c_jac_smoother.f90 @@ -58,19 +58,14 @@ module mld_c_jac_smoother procedure, pass(sm) :: apply_v => mld_c_jac_smoother_apply_vect procedure, pass(sm) :: apply_a => mld_c_jac_smoother_apply procedure, pass(sm) :: free => c_jac_smoother_free - procedure, pass(sm) :: seti => c_jac_smoother_seti - procedure, pass(sm) :: setc => c_jac_smoother_setc - procedure, pass(sm) :: setr => c_jac_smoother_setr procedure, pass(sm) :: descr => c_jac_smoother_descr procedure, pass(sm) :: sizeof => c_jac_smoother_sizeof procedure, pass(sm) :: get_nzeros => c_jac_smoother_get_nzeros end type mld_c_jac_smoother_type - private :: c_jac_smoother_free, c_jac_smoother_seti, & - & c_jac_smoother_setc, c_jac_smoother_setr,& - & c_jac_smoother_descr, c_jac_smoother_sizeof, & - & c_jac_smoother_get_nzeros + private :: c_jac_smoother_free, c_jac_smoother_descr, & + & c_jac_smoother_sizeof, c_jac_smoother_get_nzeros interface @@ -122,116 +117,6 @@ module mld_c_jac_smoother contains - subroutine c_jac_smoother_seti(sm,what,val,info) - - Implicit None - - ! Arguments - class(mld_c_jac_smoother_type), intent(inout) :: sm - integer(psb_ipk_), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - Integer(Psb_ipk_) :: err_act - character(len=20) :: name='c_jac_smoother_seti' - - info = psb_success_ - call psb_erractionsave(err_act) - - select case(what) -! !$ case(mld_smoother_sweeps_) -! !$ sm%sweeps = val - case default - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine c_jac_smoother_seti - - subroutine c_jac_smoother_setc(sm,what,val,info) - - Implicit None - - ! Arguments - class(mld_c_jac_smoother_type), intent(inout) :: sm - integer(psb_ipk_), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - Integer(Psb_ipk_) :: err_act, ival - character(len=20) :: name='c_jac_smoother_setc' - - info = psb_success_ - call psb_erractionsave(err_act) - - - ival = mld_stringval(val) - if (ival >= 0) then - call sm%set(what,ival,info) - else - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if - end if - - 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 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine c_jac_smoother_setc - - subroutine c_jac_smoother_setr(sm,what,val,info) - - Implicit None - - ! Arguments - class(mld_c_jac_smoother_type), intent(inout) :: sm - integer(psb_ipk_), intent(in) :: what - real(psb_spk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - character(len=20) :: name='c_jac_smoother_setr' - - call psb_erractionsave(err_act) - info = psb_success_ - - - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine c_jac_smoother_setr subroutine c_jac_smoother_free(sm,info) diff --git a/mlprec/mld_c_onelev_mod.f90 b/mlprec/mld_c_onelev_mod.f90 index 314bf707..f06e978b 100644 --- a/mlprec/mld_c_onelev_mod.f90 +++ b/mlprec/mld_c_onelev_mod.f90 @@ -142,6 +142,7 @@ module mld_c_onelev_mod generic, public :: set => seti, setr, setc, cseti, csetr, csetc procedure, pass(lv) :: sizeof => c_base_onelev_sizeof procedure, pass(lv) :: get_nzeros => c_base_onelev_get_nzeros + procedure, nopass :: stringval => mld_stringval end type mld_c_onelev_type type mld_c_onelev_node diff --git a/mlprec/mld_c_slu_solver.F90 b/mlprec/mld_c_slu_solver.F90 index e636e0e0..40982d0b 100644 --- a/mlprec/mld_c_slu_solver.F90 +++ b/mlprec/mld_c_slu_solver.F90 @@ -59,18 +59,13 @@ module mld_c_slu_solver procedure, pass(sv) :: build => c_slu_solver_bld procedure, pass(sv) :: apply_a => c_slu_solver_apply procedure, pass(sv) :: free => c_slu_solver_free - procedure, pass(sv) :: seti => c_slu_solver_seti - procedure, pass(sv) :: setc => c_slu_solver_setc - procedure, pass(sv) :: setr => c_slu_solver_setr procedure, pass(sv) :: descr => c_slu_solver_descr procedure, pass(sv) :: sizeof => c_slu_solver_sizeof end type mld_c_slu_solver_type private :: c_slu_solver_bld, c_slu_solver_apply, & - & c_slu_solver_free, c_slu_solver_seti, & - & c_slu_solver_setc, c_slu_solver_setr,& - & c_slu_solver_descr, c_slu_solver_sizeof + & c_slu_solver_free, c_slu_solver_descr, c_slu_solver_sizeof interface @@ -273,112 +268,6 @@ contains return end subroutine c_slu_solver_bld - - subroutine c_slu_solver_seti(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_c_slu_solver_type), intent(inout) :: sv - integer, intent(in) :: what - integer, intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='c_slu_solver_seti' - - info = psb_success_ - call psb_erractionsave(err_act) - - select case(what) - case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine c_slu_solver_seti - - subroutine c_slu_solver_setc(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_c_slu_solver_type), intent(inout) :: sv - integer, intent(in) :: what - character(len=*), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act, ival - character(len=20) :: name='c_slu_solver_setc' - - info = psb_success_ - call psb_erractionsave(err_act) - - - ival = mld_stringval(val) - if (ival >=0) then - call sv%set(what,ival,info) - end if - 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 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine c_slu_solver_setc - - subroutine c_slu_solver_setr(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_c_slu_solver_type), intent(inout) :: sv - integer, intent(in) :: what - real(psb_spk_), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='c_slu_solver_setr' - - call psb_erractionsave(err_act) - info = psb_success_ - - select case(what) - case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine c_slu_solver_setr - subroutine c_slu_solver_free(sv,info) Implicit None diff --git a/mlprec/mld_c_sludist_solver.F90 b/mlprec/mld_c_sludist_solver.F90 index bd936892..49184f10 100644 --- a/mlprec/mld_c_sludist_solver.F90 +++ b/mlprec/mld_c_sludist_solver.F90 @@ -62,18 +62,13 @@ module mld_c_sludist_solver procedure, pass(sv) :: build => c_sludist_solver_bld procedure, pass(sv) :: apply_a => c_sludist_solver_apply procedure, pass(sv) :: free => c_sludist_solver_free - procedure, pass(sv) :: seti => c_sludist_solver_seti - procedure, pass(sv) :: setc => c_sludist_solver_setc - procedure, pass(sv) :: setr => c_sludist_solver_setr procedure, pass(sv) :: descr => c_sludist_solver_descr procedure, pass(sv) :: sizeof => c_sludist_solver_sizeof end type mld_c_sludist_solver_type private :: c_sludist_solver_bld, c_sludist_solver_apply, & - & c_sludist_solver_free, c_sludist_solver_seti, & - & c_sludist_solver_setc, c_sludist_solver_setr,& - & c_sludist_solver_descr, c_sludist_solver_sizeof + & c_sludist_solver_free, c_sludist_solver_descr, c_sludist_solver_sizeof interface @@ -280,112 +275,6 @@ contains return end subroutine c_sludist_solver_bld - - subroutine c_sludist_solver_seti(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_c_sludist_solver_type), intent(inout) :: sv - integer, intent(in) :: what - integer, intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='c_sludist_solver_seti' - - info = psb_success_ - call psb_erractionsave(err_act) - - select case(what) - case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine c_sludist_solver_seti - - subroutine c_sludist_solver_setc(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_c_sludist_solver_type), intent(inout) :: sv - integer, intent(in) :: what - character(len=*), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act, ival - character(len=20) :: name='c_sludist_solver_setc' - - info = psb_success_ - call psb_erractionsave(err_act) - - - ival = mld_stringval(val) - if (ival >=0) then - call sv%set(what,ival,info) - end if - 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 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine c_sludist_solver_setc - - subroutine c_sludist_solver_setr(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_c_sludist_solver_type), intent(inout) :: sv - integer, intent(in) :: what - real(psb_spk_), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='c_sludist_solver_setr' - - call psb_erractionsave(err_act) - info = psb_success_ - - select case(what) - case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine c_sludist_solver_setr - subroutine c_sludist_solver_free(sv,info) Implicit None diff --git a/mlprec/mld_c_umf_solver.F90 b/mlprec/mld_c_umf_solver.F90 index 2a5a41be..50556092 100644 --- a/mlprec/mld_c_umf_solver.F90 +++ b/mlprec/mld_c_umf_solver.F90 @@ -59,18 +59,13 @@ module mld_c_umf_solver procedure, pass(sv) :: build => c_umf_solver_bld procedure, pass(sv) :: apply_a => c_umf_solver_apply procedure, pass(sv) :: free => c_umf_solver_free - procedure, pass(sv) :: seti => c_umf_solver_seti - procedure, pass(sv) :: setc => c_umf_solver_setc - procedure, pass(sv) :: setr => c_umf_solver_setr procedure, pass(sv) :: descr => c_umf_solver_descr procedure, pass(sv) :: sizeof => c_umf_solver_sizeof end type mld_c_umf_solver_type private :: c_umf_solver_bld, c_umf_solver_apply, & - & c_umf_solver_free, c_umf_solver_seti, & - & c_umf_solver_setc, c_umf_solver_setr,& - & c_umf_solver_descr, c_umf_solver_sizeof + & c_umf_solver_free, c_umf_solver_descr, c_umf_solver_sizeof interface @@ -274,112 +269,6 @@ contains return end subroutine c_umf_solver_bld - - subroutine c_umf_solver_seti(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_c_umf_solver_type), intent(inout) :: sv - integer, intent(in) :: what - integer, intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='c_umf_solver_seti' - - info = psb_success_ - call psb_erractionsave(err_act) - - select case(what) - case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine c_umf_solver_seti - - subroutine c_umf_solver_setc(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_c_umf_solver_type), intent(inout) :: sv - integer, intent(in) :: what - character(len=*), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act, ival - character(len=20) :: name='c_umf_solver_setc' - - info = psb_success_ - call psb_erractionsave(err_act) - - - ival = mld_stringval(val) - if (ival >=0) then - call sv%set(what,ival,info) - end if - 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 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine c_umf_solver_setc - - subroutine c_umf_solver_setr(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_c_umf_solver_type), intent(inout) :: sv - integer, intent(in) :: what - real(psb_spk_), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='c_umf_solver_setr' - - call psb_erractionsave(err_act) - info = psb_success_ - - select case(what) - case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine c_umf_solver_setr - subroutine c_umf_solver_free(sv,info) Implicit None diff --git a/mlprec/mld_d_as_smoother.f90 b/mlprec/mld_d_as_smoother.f90 index 072b50a6..7caeead9 100644 --- a/mlprec/mld_d_as_smoother.f90 +++ b/mlprec/mld_d_as_smoother.f90 @@ -63,10 +63,8 @@ module mld_d_as_smoother procedure, pass(sm) :: free => mld_d_as_smoother_free procedure, pass(sm) :: seti => mld_d_as_smoother_seti procedure, pass(sm) :: setc => mld_d_as_smoother_setc - procedure, pass(sm) :: setr => mld_d_as_smoother_setr procedure, pass(sm) :: cseti => mld_d_as_smoother_cseti procedure, pass(sm) :: csetc => mld_d_as_smoother_csetc - procedure, pass(sm) :: csetr => mld_d_as_smoother_csetr procedure, pass(sm) :: descr => d_as_smoother_descr procedure, pass(sm) :: sizeof => d_as_smoother_sizeof procedure, pass(sm) :: default => d_as_smoother_default diff --git a/mlprec/mld_d_base_smoother_mod.f90 b/mlprec/mld_d_base_smoother_mod.f90 index 8ea7c8d0..28e3c2c4 100644 --- a/mlprec/mld_d_base_smoother_mod.f90 +++ b/mlprec/mld_d_base_smoother_mod.f90 @@ -110,6 +110,7 @@ module mld_d_base_smoother_mod procedure, pass(sm) :: descr => mld_d_base_smoother_descr procedure, pass(sm) :: sizeof => d_base_smoother_sizeof procedure, pass(sm) :: get_nzeros => d_base_smoother_get_nzeros + procedure, nopass :: stringval => mld_stringval end type mld_d_base_smoother_type diff --git a/mlprec/mld_d_base_solver_mod.f90 b/mlprec/mld_d_base_solver_mod.f90 index a584a1b2..c7ebadf9 100644 --- a/mlprec/mld_d_base_solver_mod.f90 +++ b/mlprec/mld_d_base_solver_mod.f90 @@ -102,6 +102,7 @@ module mld_d_base_solver_mod procedure, pass(sv) :: descr => mld_d_base_solver_descr procedure, pass(sv) :: sizeof => d_base_solver_sizeof procedure, pass(sv) :: get_nzeros => d_base_solver_get_nzeros + procedure, nopass :: stringval => mld_stringval end type mld_d_base_solver_type private :: d_base_solver_sizeof, d_base_solver_default,& diff --git a/mlprec/mld_d_diag_solver.f90 b/mlprec/mld_d_diag_solver.f90 index e34db685..1f802859 100644 --- a/mlprec/mld_d_diag_solver.f90 +++ b/mlprec/mld_d_diag_solver.f90 @@ -55,19 +55,14 @@ module mld_d_diag_solver procedure, pass(sv) :: apply_v => mld_d_diag_solver_apply_vect procedure, pass(sv) :: apply_a => mld_d_diag_solver_apply procedure, pass(sv) :: free => d_diag_solver_free - procedure, pass(sv) :: seti => d_diag_solver_seti - procedure, pass(sv) :: setc => d_diag_solver_setc - procedure, pass(sv) :: setr => d_diag_solver_setr procedure, pass(sv) :: descr => d_diag_solver_descr procedure, pass(sv) :: sizeof => d_diag_solver_sizeof procedure, pass(sv) :: get_nzeros => d_diag_solver_get_nzeros end type mld_d_diag_solver_type - private :: d_diag_solver_free, d_diag_solver_seti, & - & d_diag_solver_setc, d_diag_solver_setr,& - & d_diag_solver_descr, d_diag_solver_sizeof,& - & d_diag_solver_get_nzeros + private :: d_diag_solver_free, d_diag_solver_descr, & + & d_diag_solver_sizeof, d_diag_solver_get_nzeros interface @@ -121,61 +116,6 @@ module mld_d_diag_solver contains - - subroutine d_diag_solver_seti(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_d_diag_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - Integer(Psb_ipk_) :: err_act - character(len=20) :: name='d_diag_solver_seti' - - info = psb_success_ - - - return - - end subroutine d_diag_solver_seti - - subroutine d_diag_solver_setc(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_d_diag_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - Integer(Psb_ipk_) :: err_act, ival - character(len=20) :: name='d_diag_solver_setc' - - info = psb_success_ - - return - end subroutine d_diag_solver_setc - - subroutine d_diag_solver_setr(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_d_diag_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what - real(psb_dpk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - Integer(Psb_ipk_) :: err_act - character(len=20) :: name='d_diag_solver_setr' - - info = psb_success_ - - return - - end subroutine d_diag_solver_setr - subroutine d_diag_solver_free(sv,info) Implicit None diff --git a/mlprec/mld_d_id_solver.f90 b/mlprec/mld_d_id_solver.f90 index 15c3c586..61e5a615 100644 --- a/mlprec/mld_d_id_solver.f90 +++ b/mlprec/mld_d_id_solver.f90 @@ -53,16 +53,12 @@ module mld_d_id_solver procedure, pass(sv) :: apply_v => mld_d_id_solver_apply_vect procedure, pass(sv) :: apply_a => mld_d_id_solver_apply procedure, pass(sv) :: free => d_id_solver_free - procedure, pass(sv) :: seti => d_id_solver_seti - procedure, pass(sv) :: setc => d_id_solver_setc - procedure, pass(sv) :: setr => d_id_solver_setr procedure, pass(sv) :: descr => d_id_solver_descr end type mld_d_id_solver_type private :: d_id_solver_bld, & - & d_id_solver_free, d_id_solver_seti, & - & d_id_solver_setc, d_id_solver_setr,& + & d_id_solver_free, & & d_id_solver_descr interface @@ -124,60 +120,6 @@ contains return end subroutine d_id_solver_bld - - subroutine d_id_solver_seti(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_d_id_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - character(len=20) :: name='d_id_solver_seti' - - info = psb_success_ - - return - - end subroutine d_id_solver_seti - - subroutine d_id_solver_setc(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_d_id_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, ival - character(len=20) :: name='d_id_solver_setc' - - info = psb_success_ - - return - end subroutine d_id_solver_setc - - subroutine d_id_solver_setr(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_d_id_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what - real(psb_dpk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - character(len=20) :: name='d_id_solver_setr' - - info = psb_success_ - - return - - end subroutine d_id_solver_setr - subroutine d_id_solver_free(sv,info) Implicit None diff --git a/mlprec/mld_d_ilu_solver.f90 b/mlprec/mld_d_ilu_solver.f90 index 5f38649f..f207da28 100644 --- a/mlprec/mld_d_ilu_solver.f90 +++ b/mlprec/mld_d_ilu_solver.f90 @@ -231,8 +231,7 @@ contains case(mld_sub_fillin_) sv%fill_in = val case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 + call sv%mld_d_base_solver_type%set(what,val,info) end select call psb_erractionrestore(err_act) @@ -263,7 +262,7 @@ contains call psb_erractionsave(err_act) - ival = mld_stringval(val) + ival = sv%stringval(val) if (ival >= 0) then call sv%set(what,ival,info) end if @@ -305,9 +304,7 @@ contains case(mld_sub_iluthrs_) sv%thresh = val case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ goto 9999 + call sv%mld_d_base_solver_type%set(what,val,info) end select call psb_erractionrestore(err_act) @@ -343,8 +340,7 @@ contains case('SUB_FILLIN') sv%fill_in = val case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 + call sv%mld_d_base_solver_type%set(what,val,info) end select call psb_erractionrestore(err_act) @@ -375,7 +371,7 @@ contains call psb_erractionsave(err_act) - ival = mld_stringval(val) + ival = sv%stringval(val) if (ival >= 0) then call sv%set(what,ival,info) end if @@ -417,9 +413,7 @@ contains case('SUB_ILUTHRS') sv%thresh = val case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ goto 9999 + call sv%mld_d_base_solver_type%set(what,val,info) end select call psb_erractionrestore(err_act) diff --git a/mlprec/mld_d_jac_smoother.f90 b/mlprec/mld_d_jac_smoother.f90 index 492a191e..0ee8abf6 100644 --- a/mlprec/mld_d_jac_smoother.f90 +++ b/mlprec/mld_d_jac_smoother.f90 @@ -58,19 +58,14 @@ module mld_d_jac_smoother procedure, pass(sm) :: apply_v => mld_d_jac_smoother_apply_vect procedure, pass(sm) :: apply_a => mld_d_jac_smoother_apply procedure, pass(sm) :: free => d_jac_smoother_free - procedure, pass(sm) :: seti => d_jac_smoother_seti - procedure, pass(sm) :: setc => d_jac_smoother_setc - procedure, pass(sm) :: setr => d_jac_smoother_setr procedure, pass(sm) :: descr => d_jac_smoother_descr procedure, pass(sm) :: sizeof => d_jac_smoother_sizeof procedure, pass(sm) :: get_nzeros => d_jac_smoother_get_nzeros end type mld_d_jac_smoother_type - private :: d_jac_smoother_free, d_jac_smoother_seti, & - & d_jac_smoother_setc, d_jac_smoother_setr,& - & d_jac_smoother_descr, d_jac_smoother_sizeof, & - & d_jac_smoother_get_nzeros + private :: d_jac_smoother_free, d_jac_smoother_descr, & + & d_jac_smoother_sizeof, d_jac_smoother_get_nzeros interface @@ -122,116 +117,6 @@ module mld_d_jac_smoother contains - subroutine d_jac_smoother_seti(sm,what,val,info) - - Implicit None - - ! Arguments - class(mld_d_jac_smoother_type), intent(inout) :: sm - integer(psb_ipk_), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - Integer(Psb_ipk_) :: err_act - character(len=20) :: name='d_jac_smoother_seti' - - info = psb_success_ - call psb_erractionsave(err_act) - - select case(what) -! !$ case(mld_smoother_sweeps_) -! !$ sm%sweeps = val - case default - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine d_jac_smoother_seti - - subroutine d_jac_smoother_setc(sm,what,val,info) - - Implicit None - - ! Arguments - class(mld_d_jac_smoother_type), intent(inout) :: sm - integer(psb_ipk_), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - Integer(Psb_ipk_) :: err_act, ival - character(len=20) :: name='d_jac_smoother_setc' - - info = psb_success_ - call psb_erractionsave(err_act) - - - ival = mld_stringval(val) - if (ival >= 0) then - call sm%set(what,ival,info) - else - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if - end if - - 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 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine d_jac_smoother_setc - - subroutine d_jac_smoother_setr(sm,what,val,info) - - Implicit None - - ! Arguments - class(mld_d_jac_smoother_type), intent(inout) :: sm - integer(psb_ipk_), intent(in) :: what - real(psb_dpk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - character(len=20) :: name='d_jac_smoother_setr' - - call psb_erractionsave(err_act) - info = psb_success_ - - - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine d_jac_smoother_setr subroutine d_jac_smoother_free(sm,info) diff --git a/mlprec/mld_d_onelev_mod.f90 b/mlprec/mld_d_onelev_mod.f90 index 9ec6e264..6f3b9a02 100644 --- a/mlprec/mld_d_onelev_mod.f90 +++ b/mlprec/mld_d_onelev_mod.f90 @@ -142,6 +142,7 @@ module mld_d_onelev_mod generic, public :: set => seti, setr, setc, cseti, csetr, csetc procedure, pass(lv) :: sizeof => d_base_onelev_sizeof procedure, pass(lv) :: get_nzeros => d_base_onelev_get_nzeros + procedure, nopass :: stringval => mld_stringval end type mld_d_onelev_type type mld_d_onelev_node diff --git a/mlprec/mld_d_slu_solver.F90 b/mlprec/mld_d_slu_solver.F90 index 22abb0e8..388c1bd2 100644 --- a/mlprec/mld_d_slu_solver.F90 +++ b/mlprec/mld_d_slu_solver.F90 @@ -61,18 +61,13 @@ module mld_d_slu_solver procedure, pass(sv) :: build => d_slu_solver_bld procedure, pass(sv) :: apply_a => d_slu_solver_apply procedure, pass(sv) :: free => d_slu_solver_free - procedure, pass(sv) :: seti => d_slu_solver_seti - procedure, pass(sv) :: setc => d_slu_solver_setc - procedure, pass(sv) :: setr => d_slu_solver_setr procedure, pass(sv) :: descr => d_slu_solver_descr procedure, pass(sv) :: sizeof => d_slu_solver_sizeof end type mld_d_slu_solver_type private :: d_slu_solver_bld, d_slu_solver_apply, & - & d_slu_solver_free, d_slu_solver_seti, & - & d_slu_solver_setc, d_slu_solver_setr,& - & d_slu_solver_descr, d_slu_solver_sizeof + & d_slu_solver_free, d_slu_solver_descr, d_slu_solver_sizeof interface @@ -273,111 +268,6 @@ contains return end subroutine d_slu_solver_bld - - subroutine d_slu_solver_seti(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_d_slu_solver_type), intent(inout) :: sv - integer, intent(in) :: what - integer, intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='d_slu_solver_seti' - - info = psb_success_ - call psb_erractionsave(err_act) - - select case(what) - case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine d_slu_solver_seti - - subroutine d_slu_solver_setc(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_d_slu_solver_type), intent(inout) :: sv - integer, intent(in) :: what - character(len=*), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act, ival - character(len=20) :: name='d_slu_solver_setc' - - info = psb_success_ - call psb_erractionsave(err_act) - - ival = mld_stringval(val) - if (ival >=0) then - call sv%set(what,ival,info) - end if - 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 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine d_slu_solver_setc - - subroutine d_slu_solver_setr(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_d_slu_solver_type), intent(inout) :: sv - integer, intent(in) :: what - real(psb_dpk_), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='d_slu_solver_setr' - - call psb_erractionsave(err_act) - info = psb_success_ - - select case(what) - case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine d_slu_solver_setr - subroutine d_slu_solver_free(sv,info) Implicit None diff --git a/mlprec/mld_d_sludist_solver.F90 b/mlprec/mld_d_sludist_solver.F90 index 7a93613f..9c9c76de 100644 --- a/mlprec/mld_d_sludist_solver.F90 +++ b/mlprec/mld_d_sludist_solver.F90 @@ -62,18 +62,13 @@ module mld_d_sludist_solver procedure, pass(sv) :: build => d_sludist_solver_bld procedure, pass(sv) :: apply_a => d_sludist_solver_apply procedure, pass(sv) :: free => d_sludist_solver_free - procedure, pass(sv) :: seti => d_sludist_solver_seti - procedure, pass(sv) :: setc => d_sludist_solver_setc - procedure, pass(sv) :: setr => d_sludist_solver_setr procedure, pass(sv) :: descr => d_sludist_solver_descr procedure, pass(sv) :: sizeof => d_sludist_solver_sizeof end type mld_d_sludist_solver_type private :: d_sludist_solver_bld, d_sludist_solver_apply, & - & d_sludist_solver_free, d_sludist_solver_seti, & - & d_sludist_solver_setc, d_sludist_solver_setr,& - & d_sludist_solver_descr, d_sludist_solver_sizeof + & d_sludist_solver_free, d_sludist_solver_descr, d_sludist_solver_sizeof interface @@ -278,111 +273,6 @@ contains return end subroutine d_sludist_solver_bld - - subroutine d_sludist_solver_seti(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_d_sludist_solver_type), intent(inout) :: sv - integer, intent(in) :: what - integer, intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='d_sludist_solver_seti' - - info = psb_success_ - call psb_erractionsave(err_act) - - select case(what) - case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine d_sludist_solver_seti - - subroutine d_sludist_solver_setc(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_d_sludist_solver_type), intent(inout) :: sv - integer, intent(in) :: what - character(len=*), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act, ival - character(len=20) :: name='d_sludist_solver_setc' - - info = psb_success_ - call psb_erractionsave(err_act) - - ival = mld_stringval(val) - if (ival >=0) then - call sv%set(what,ival,info) - end if - 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 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine d_sludist_solver_setc - - subroutine d_sludist_solver_setr(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_d_sludist_solver_type), intent(inout) :: sv - integer, intent(in) :: what - real(psb_dpk_), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='d_sludist_solver_setr' - - call psb_erractionsave(err_act) - info = psb_success_ - - select case(what) - case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine d_sludist_solver_setr - subroutine d_sludist_solver_free(sv,info) Implicit None diff --git a/mlprec/mld_d_umf_solver.F90 b/mlprec/mld_d_umf_solver.F90 index d240e156..b849806d 100644 --- a/mlprec/mld_d_umf_solver.F90 +++ b/mlprec/mld_d_umf_solver.F90 @@ -61,18 +61,13 @@ module mld_d_umf_solver procedure, pass(sv) :: build => d_umf_solver_bld procedure, pass(sv) :: apply_a => d_umf_solver_apply procedure, pass(sv) :: free => d_umf_solver_free - procedure, pass(sv) :: seti => d_umf_solver_seti - procedure, pass(sv) :: setc => d_umf_solver_setc - procedure, pass(sv) :: setr => d_umf_solver_setr procedure, pass(sv) :: descr => d_umf_solver_descr procedure, pass(sv) :: sizeof => d_umf_solver_sizeof end type mld_d_umf_solver_type private :: d_umf_solver_bld, d_umf_solver_apply, & - & d_umf_solver_free, d_umf_solver_seti, & - & d_umf_solver_setc, d_umf_solver_setr,& - & d_umf_solver_descr, d_umf_solver_sizeof + & d_umf_solver_free, d_umf_solver_descr, d_umf_solver_sizeof interface @@ -274,111 +269,6 @@ contains return end subroutine d_umf_solver_bld - - subroutine d_umf_solver_seti(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_d_umf_solver_type), intent(inout) :: sv - integer, intent(in) :: what - integer, intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='d_umf_solver_seti' - - info = psb_success_ - call psb_erractionsave(err_act) - - select case(what) - case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine d_umf_solver_seti - - subroutine d_umf_solver_setc(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_d_umf_solver_type), intent(inout) :: sv - integer, intent(in) :: what - character(len=*), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act, ival - character(len=20) :: name='d_umf_solver_setc' - - info = psb_success_ - call psb_erractionsave(err_act) - - ival = mld_stringval(val) - if (ival >=0) then - call sv%set(what,ival,info) - end if - 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 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine d_umf_solver_setc - - subroutine d_umf_solver_setr(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_d_umf_solver_type), intent(inout) :: sv - integer, intent(in) :: what - real(psb_dpk_), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='d_umf_solver_setr' - - call psb_erractionsave(err_act) - info = psb_success_ - - select case(what) - case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine d_umf_solver_setr - subroutine d_umf_solver_free(sv,info) Implicit None diff --git a/mlprec/mld_s_as_smoother.f90 b/mlprec/mld_s_as_smoother.f90 index 8520d5bd..953abc12 100644 --- a/mlprec/mld_s_as_smoother.f90 +++ b/mlprec/mld_s_as_smoother.f90 @@ -63,10 +63,8 @@ module mld_s_as_smoother procedure, pass(sm) :: free => mld_s_as_smoother_free procedure, pass(sm) :: seti => mld_s_as_smoother_seti procedure, pass(sm) :: setc => mld_s_as_smoother_setc - procedure, pass(sm) :: setr => mld_s_as_smoother_setr procedure, pass(sm) :: cseti => mld_s_as_smoother_cseti procedure, pass(sm) :: csetc => mld_s_as_smoother_csetc - procedure, pass(sm) :: csetr => mld_s_as_smoother_csetr procedure, pass(sm) :: descr => s_as_smoother_descr procedure, pass(sm) :: sizeof => s_as_smoother_sizeof procedure, pass(sm) :: default => s_as_smoother_default diff --git a/mlprec/mld_s_base_smoother_mod.f90 b/mlprec/mld_s_base_smoother_mod.f90 index d256636a..84883e0d 100644 --- a/mlprec/mld_s_base_smoother_mod.f90 +++ b/mlprec/mld_s_base_smoother_mod.f90 @@ -110,6 +110,7 @@ module mld_s_base_smoother_mod procedure, pass(sm) :: descr => mld_s_base_smoother_descr procedure, pass(sm) :: sizeof => s_base_smoother_sizeof procedure, pass(sm) :: get_nzeros => s_base_smoother_get_nzeros + procedure, nopass :: stringval => mld_stringval end type mld_s_base_smoother_type diff --git a/mlprec/mld_s_base_solver_mod.f90 b/mlprec/mld_s_base_solver_mod.f90 index f1595abc..d2ccd0b7 100644 --- a/mlprec/mld_s_base_solver_mod.f90 +++ b/mlprec/mld_s_base_solver_mod.f90 @@ -102,6 +102,7 @@ module mld_s_base_solver_mod procedure, pass(sv) :: descr => mld_s_base_solver_descr procedure, pass(sv) :: sizeof => s_base_solver_sizeof procedure, pass(sv) :: get_nzeros => s_base_solver_get_nzeros + procedure, nopass :: stringval => mld_stringval end type mld_s_base_solver_type private :: s_base_solver_sizeof, s_base_solver_default,& diff --git a/mlprec/mld_s_diag_solver.f90 b/mlprec/mld_s_diag_solver.f90 index 0b3be178..a6a0b082 100644 --- a/mlprec/mld_s_diag_solver.f90 +++ b/mlprec/mld_s_diag_solver.f90 @@ -55,19 +55,14 @@ module mld_s_diag_solver procedure, pass(sv) :: apply_v => mld_s_diag_solver_apply_vect procedure, pass(sv) :: apply_a => mld_s_diag_solver_apply procedure, pass(sv) :: free => s_diag_solver_free - procedure, pass(sv) :: seti => s_diag_solver_seti - procedure, pass(sv) :: setc => s_diag_solver_setc - procedure, pass(sv) :: setr => s_diag_solver_setr procedure, pass(sv) :: descr => s_diag_solver_descr procedure, pass(sv) :: sizeof => s_diag_solver_sizeof procedure, pass(sv) :: get_nzeros => s_diag_solver_get_nzeros end type mld_s_diag_solver_type - private :: s_diag_solver_free, s_diag_solver_seti, & - & s_diag_solver_setc, s_diag_solver_setr,& - & s_diag_solver_descr, s_diag_solver_sizeof,& - & s_diag_solver_get_nzeros + private :: s_diag_solver_free, s_diag_solver_descr, & + & s_diag_solver_sizeof, s_diag_solver_get_nzeros interface @@ -121,61 +116,6 @@ module mld_s_diag_solver contains - - subroutine s_diag_solver_seti(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_s_diag_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - Integer(Psb_ipk_) :: err_act - character(len=20) :: name='s_diag_solver_seti' - - info = psb_success_ - - - return - - end subroutine s_diag_solver_seti - - subroutine s_diag_solver_setc(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_s_diag_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - Integer(Psb_ipk_) :: err_act, ival - character(len=20) :: name='s_diag_solver_setc' - - info = psb_success_ - - return - end subroutine s_diag_solver_setc - - subroutine s_diag_solver_setr(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_s_diag_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what - real(psb_spk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - Integer(Psb_ipk_) :: err_act - character(len=20) :: name='s_diag_solver_setr' - - info = psb_success_ - - return - - end subroutine s_diag_solver_setr - subroutine s_diag_solver_free(sv,info) Implicit None diff --git a/mlprec/mld_s_id_solver.f90 b/mlprec/mld_s_id_solver.f90 index c4b559a7..ca154059 100644 --- a/mlprec/mld_s_id_solver.f90 +++ b/mlprec/mld_s_id_solver.f90 @@ -53,16 +53,12 @@ module mld_s_id_solver procedure, pass(sv) :: apply_v => mld_s_id_solver_apply_vect procedure, pass(sv) :: apply_a => mld_s_id_solver_apply procedure, pass(sv) :: free => s_id_solver_free - procedure, pass(sv) :: seti => s_id_solver_seti - procedure, pass(sv) :: setc => s_id_solver_setc - procedure, pass(sv) :: setr => s_id_solver_setr procedure, pass(sv) :: descr => s_id_solver_descr end type mld_s_id_solver_type private :: s_id_solver_bld, & - & s_id_solver_free, s_id_solver_seti, & - & s_id_solver_setc, s_id_solver_setr,& + & s_id_solver_free, & & s_id_solver_descr interface @@ -124,60 +120,6 @@ contains return end subroutine s_id_solver_bld - - subroutine s_id_solver_seti(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_s_id_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - character(len=20) :: name='s_id_solver_seti' - - info = psb_success_ - - return - - end subroutine s_id_solver_seti - - subroutine s_id_solver_setc(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_s_id_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, ival - character(len=20) :: name='s_id_solver_setc' - - info = psb_success_ - - return - end subroutine s_id_solver_setc - - subroutine s_id_solver_setr(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_s_id_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what - real(psb_spk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - character(len=20) :: name='s_id_solver_setr' - - info = psb_success_ - - return - - end subroutine s_id_solver_setr - subroutine s_id_solver_free(sv,info) Implicit None diff --git a/mlprec/mld_s_ilu_solver.f90 b/mlprec/mld_s_ilu_solver.f90 index 01d253d8..e89ad10d 100644 --- a/mlprec/mld_s_ilu_solver.f90 +++ b/mlprec/mld_s_ilu_solver.f90 @@ -231,8 +231,7 @@ contains case(mld_sub_fillin_) sv%fill_in = val case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 + call sv%mld_s_base_solver_type%set(what,val,info) end select call psb_erractionrestore(err_act) @@ -263,7 +262,7 @@ contains call psb_erractionsave(err_act) - ival = mld_stringval(val) + ival = sv%stringval(val) if (ival >= 0) then call sv%set(what,ival,info) end if @@ -305,9 +304,7 @@ contains case(mld_sub_iluthrs_) sv%thresh = val case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ goto 9999 + call sv%mld_s_base_solver_type%set(what,val,info) end select call psb_erractionrestore(err_act) @@ -343,8 +340,7 @@ contains case('SUB_FILLIN') sv%fill_in = val case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 + call sv%mld_s_base_solver_type%set(what,val,info) end select call psb_erractionrestore(err_act) @@ -375,7 +371,7 @@ contains call psb_erractionsave(err_act) - ival = mld_stringval(val) + ival = sv%stringval(val) if (ival >= 0) then call sv%set(what,ival,info) end if @@ -417,9 +413,7 @@ contains case('SUB_ILUTHRS') sv%thresh = val case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ goto 9999 + call sv%mld_s_base_solver_type%set(what,val,info) end select call psb_erractionrestore(err_act) diff --git a/mlprec/mld_s_jac_smoother.f90 b/mlprec/mld_s_jac_smoother.f90 index 8312c2b5..2342120e 100644 --- a/mlprec/mld_s_jac_smoother.f90 +++ b/mlprec/mld_s_jac_smoother.f90 @@ -58,19 +58,14 @@ module mld_s_jac_smoother procedure, pass(sm) :: apply_v => mld_s_jac_smoother_apply_vect procedure, pass(sm) :: apply_a => mld_s_jac_smoother_apply procedure, pass(sm) :: free => s_jac_smoother_free - procedure, pass(sm) :: seti => s_jac_smoother_seti - procedure, pass(sm) :: setc => s_jac_smoother_setc - procedure, pass(sm) :: setr => s_jac_smoother_setr procedure, pass(sm) :: descr => s_jac_smoother_descr procedure, pass(sm) :: sizeof => s_jac_smoother_sizeof procedure, pass(sm) :: get_nzeros => s_jac_smoother_get_nzeros end type mld_s_jac_smoother_type - private :: s_jac_smoother_free, s_jac_smoother_seti, & - & s_jac_smoother_setc, s_jac_smoother_setr,& - & s_jac_smoother_descr, s_jac_smoother_sizeof, & - & s_jac_smoother_get_nzeros + private :: s_jac_smoother_free, s_jac_smoother_descr, & + & s_jac_smoother_sizeof, s_jac_smoother_get_nzeros interface @@ -122,116 +117,6 @@ module mld_s_jac_smoother contains - subroutine s_jac_smoother_seti(sm,what,val,info) - - Implicit None - - ! Arguments - class(mld_s_jac_smoother_type), intent(inout) :: sm - integer(psb_ipk_), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - Integer(Psb_ipk_) :: err_act - character(len=20) :: name='s_jac_smoother_seti' - - info = psb_success_ - call psb_erractionsave(err_act) - - select case(what) -! !$ case(mld_smoother_sweeps_) -! !$ sm%sweeps = val - case default - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine s_jac_smoother_seti - - subroutine s_jac_smoother_setc(sm,what,val,info) - - Implicit None - - ! Arguments - class(mld_s_jac_smoother_type), intent(inout) :: sm - integer(psb_ipk_), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - Integer(Psb_ipk_) :: err_act, ival - character(len=20) :: name='s_jac_smoother_setc' - - info = psb_success_ - call psb_erractionsave(err_act) - - - ival = mld_stringval(val) - if (ival >= 0) then - call sm%set(what,ival,info) - else - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if - end if - - 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 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine s_jac_smoother_setc - - subroutine s_jac_smoother_setr(sm,what,val,info) - - Implicit None - - ! Arguments - class(mld_s_jac_smoother_type), intent(inout) :: sm - integer(psb_ipk_), intent(in) :: what - real(psb_spk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - character(len=20) :: name='s_jac_smoother_setr' - - call psb_erractionsave(err_act) - info = psb_success_ - - - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine s_jac_smoother_setr subroutine s_jac_smoother_free(sm,info) diff --git a/mlprec/mld_s_onelev_mod.f90 b/mlprec/mld_s_onelev_mod.f90 index c35a7d22..8bf7c5c0 100644 --- a/mlprec/mld_s_onelev_mod.f90 +++ b/mlprec/mld_s_onelev_mod.f90 @@ -142,6 +142,7 @@ module mld_s_onelev_mod generic, public :: set => seti, setr, setc, cseti, csetr, csetc procedure, pass(lv) :: sizeof => s_base_onelev_sizeof procedure, pass(lv) :: get_nzeros => s_base_onelev_get_nzeros + procedure, nopass :: stringval => mld_stringval end type mld_s_onelev_type type mld_s_onelev_node diff --git a/mlprec/mld_s_slu_solver.F90 b/mlprec/mld_s_slu_solver.F90 index 92e89582..b311329a 100644 --- a/mlprec/mld_s_slu_solver.F90 +++ b/mlprec/mld_s_slu_solver.F90 @@ -63,18 +63,13 @@ module mld_s_slu_solver procedure, pass(sv) :: build => s_slu_solver_bld procedure, pass(sv) :: apply_a => s_slu_solver_apply procedure, pass(sv) :: free => s_slu_solver_free - procedure, pass(sv) :: seti => s_slu_solver_seti - procedure, pass(sv) :: setc => s_slu_solver_setc - procedure, pass(sv) :: setr => s_slu_solver_setr procedure, pass(sv) :: descr => s_slu_solver_descr procedure, pass(sv) :: sizeof => s_slu_solver_sizeof end type mld_s_slu_solver_type private :: s_slu_solver_bld, s_slu_solver_apply, & - & s_slu_solver_free, s_slu_solver_seti, & - & s_slu_solver_setc, s_slu_solver_setr,& - & s_slu_solver_descr, s_slu_solver_sizeof + & s_slu_solver_free, s_slu_solver_descr, s_slu_solver_sizeof interface @@ -275,111 +270,6 @@ contains return end subroutine s_slu_solver_bld - - subroutine s_slu_solver_seti(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_s_slu_solver_type), intent(inout) :: sv - integer, intent(in) :: what - integer, intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='s_slu_solver_seti' - - info = psb_success_ - call psb_erractionsave(err_act) - - select case(what) - case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine s_slu_solver_seti - - subroutine s_slu_solver_setc(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_s_slu_solver_type), intent(inout) :: sv - integer, intent(in) :: what - character(len=*), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act, ival - character(len=20) :: name='s_slu_solver_setc' - - info = psb_success_ - call psb_erractionsave(err_act) - - ival = mld_stringval(val) - if (ival >=0) then - call sv%set(what,ival,info) - end if - 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 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine s_slu_solver_setc - - subroutine s_slu_solver_setr(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_s_slu_solver_type), intent(inout) :: sv - integer, intent(in) :: what - real(psb_spk_), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='s_slu_solver_setr' - - call psb_erractionsave(err_act) - info = psb_success_ - - select case(what) - case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine s_slu_solver_setr - subroutine s_slu_solver_free(sv,info) Implicit None diff --git a/mlprec/mld_s_sludist_solver.F90 b/mlprec/mld_s_sludist_solver.F90 index bbe9f0d4..3ae2a73f 100644 --- a/mlprec/mld_s_sludist_solver.F90 +++ b/mlprec/mld_s_sludist_solver.F90 @@ -62,18 +62,13 @@ module mld_s_sludist_solver procedure, pass(sv) :: build => s_sludist_solver_bld procedure, pass(sv) :: apply_a => s_sludist_solver_apply procedure, pass(sv) :: free => s_sludist_solver_free - procedure, pass(sv) :: seti => s_sludist_solver_seti - procedure, pass(sv) :: setc => s_sludist_solver_setc - procedure, pass(sv) :: setr => s_sludist_solver_setr procedure, pass(sv) :: descr => s_sludist_solver_descr procedure, pass(sv) :: sizeof => s_sludist_solver_sizeof end type mld_s_sludist_solver_type private :: s_sludist_solver_bld, s_sludist_solver_apply, & - & s_sludist_solver_free, s_sludist_solver_seti, & - & s_sludist_solver_setc, s_sludist_solver_setr,& - & s_sludist_solver_descr, s_sludist_solver_sizeof + & s_sludist_solver_free, s_sludist_solver_descr, s_sludist_solver_sizeof interface @@ -278,111 +273,6 @@ contains return end subroutine s_sludist_solver_bld - - subroutine s_sludist_solver_seti(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_s_sludist_solver_type), intent(inout) :: sv - integer, intent(in) :: what - integer, intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='s_sludist_solver_seti' - - info = psb_success_ - call psb_erractionsave(err_act) - - select case(what) - case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine s_sludist_solver_seti - - subroutine s_sludist_solver_setc(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_s_sludist_solver_type), intent(inout) :: sv - integer, intent(in) :: what - character(len=*), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act, ival - character(len=20) :: name='s_sludist_solver_setc' - - info = psb_success_ - call psb_erractionsave(err_act) - - ival = mld_stringval(val) - if (ival >=0) then - call sv%set(what,ival,info) - end if - 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 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine s_sludist_solver_setc - - subroutine s_sludist_solver_setr(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_s_sludist_solver_type), intent(inout) :: sv - integer, intent(in) :: what - real(psb_spk_), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='s_sludist_solver_setr' - - call psb_erractionsave(err_act) - info = psb_success_ - - select case(what) - case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine s_sludist_solver_setr - subroutine s_sludist_solver_free(sv,info) Implicit None diff --git a/mlprec/mld_s_umf_solver.F90 b/mlprec/mld_s_umf_solver.F90 index ecf0272b..b7698503 100644 --- a/mlprec/mld_s_umf_solver.F90 +++ b/mlprec/mld_s_umf_solver.F90 @@ -63,18 +63,13 @@ module mld_s_umf_solver procedure, pass(sv) :: build => s_umf_solver_bld procedure, pass(sv) :: apply_a => s_umf_solver_apply procedure, pass(sv) :: free => s_umf_solver_free - procedure, pass(sv) :: seti => s_umf_solver_seti - procedure, pass(sv) :: setc => s_umf_solver_setc - procedure, pass(sv) :: setr => s_umf_solver_setr procedure, pass(sv) :: descr => s_umf_solver_descr procedure, pass(sv) :: sizeof => s_umf_solver_sizeof end type mld_s_umf_solver_type private :: s_umf_solver_bld, s_umf_solver_apply, & - & s_umf_solver_free, s_umf_solver_seti, & - & s_umf_solver_setc, s_umf_solver_setr,& - & s_umf_solver_descr, s_umf_solver_sizeof + & s_umf_solver_free, s_umf_solver_descr, s_umf_solver_sizeof interface @@ -276,111 +271,6 @@ contains return end subroutine s_umf_solver_bld - - subroutine s_umf_solver_seti(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_s_umf_solver_type), intent(inout) :: sv - integer, intent(in) :: what - integer, intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='s_umf_solver_seti' - - info = psb_success_ - call psb_erractionsave(err_act) - - select case(what) - case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine s_umf_solver_seti - - subroutine s_umf_solver_setc(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_s_umf_solver_type), intent(inout) :: sv - integer, intent(in) :: what - character(len=*), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act, ival - character(len=20) :: name='s_umf_solver_setc' - - info = psb_success_ - call psb_erractionsave(err_act) - - ival = mld_stringval(val) - if (ival >=0) then - call sv%set(what,ival,info) - end if - 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 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine s_umf_solver_setc - - subroutine s_umf_solver_setr(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_s_umf_solver_type), intent(inout) :: sv - integer, intent(in) :: what - real(psb_spk_), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='s_umf_solver_setr' - - call psb_erractionsave(err_act) - info = psb_success_ - - select case(what) - case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine s_umf_solver_setr - subroutine s_umf_solver_free(sv,info) Implicit None diff --git a/mlprec/mld_z_as_smoother.f90 b/mlprec/mld_z_as_smoother.f90 index d346bf57..22078c92 100644 --- a/mlprec/mld_z_as_smoother.f90 +++ b/mlprec/mld_z_as_smoother.f90 @@ -63,10 +63,8 @@ module mld_z_as_smoother procedure, pass(sm) :: free => mld_z_as_smoother_free procedure, pass(sm) :: seti => mld_z_as_smoother_seti procedure, pass(sm) :: setc => mld_z_as_smoother_setc - procedure, pass(sm) :: setr => mld_z_as_smoother_setr procedure, pass(sm) :: cseti => mld_z_as_smoother_cseti procedure, pass(sm) :: csetc => mld_z_as_smoother_csetc - procedure, pass(sm) :: csetr => mld_z_as_smoother_csetr procedure, pass(sm) :: descr => z_as_smoother_descr procedure, pass(sm) :: sizeof => z_as_smoother_sizeof procedure, pass(sm) :: default => z_as_smoother_default diff --git a/mlprec/mld_z_base_smoother_mod.f90 b/mlprec/mld_z_base_smoother_mod.f90 index 62a7e9f1..d7a83908 100644 --- a/mlprec/mld_z_base_smoother_mod.f90 +++ b/mlprec/mld_z_base_smoother_mod.f90 @@ -110,6 +110,7 @@ module mld_z_base_smoother_mod procedure, pass(sm) :: descr => mld_z_base_smoother_descr procedure, pass(sm) :: sizeof => z_base_smoother_sizeof procedure, pass(sm) :: get_nzeros => z_base_smoother_get_nzeros + procedure, nopass :: stringval => mld_stringval end type mld_z_base_smoother_type diff --git a/mlprec/mld_z_base_solver_mod.f90 b/mlprec/mld_z_base_solver_mod.f90 index 3ea3c0c0..04658556 100644 --- a/mlprec/mld_z_base_solver_mod.f90 +++ b/mlprec/mld_z_base_solver_mod.f90 @@ -102,6 +102,7 @@ module mld_z_base_solver_mod procedure, pass(sv) :: descr => mld_z_base_solver_descr procedure, pass(sv) :: sizeof => z_base_solver_sizeof procedure, pass(sv) :: get_nzeros => z_base_solver_get_nzeros + procedure, nopass :: stringval => mld_stringval end type mld_z_base_solver_type private :: z_base_solver_sizeof, z_base_solver_default,& diff --git a/mlprec/mld_z_diag_solver.f90 b/mlprec/mld_z_diag_solver.f90 index ff20ed0b..a26ce848 100644 --- a/mlprec/mld_z_diag_solver.f90 +++ b/mlprec/mld_z_diag_solver.f90 @@ -55,19 +55,14 @@ module mld_z_diag_solver procedure, pass(sv) :: apply_v => mld_z_diag_solver_apply_vect procedure, pass(sv) :: apply_a => mld_z_diag_solver_apply procedure, pass(sv) :: free => z_diag_solver_free - procedure, pass(sv) :: seti => z_diag_solver_seti - procedure, pass(sv) :: setc => z_diag_solver_setc - procedure, pass(sv) :: setr => z_diag_solver_setr procedure, pass(sv) :: descr => z_diag_solver_descr procedure, pass(sv) :: sizeof => z_diag_solver_sizeof procedure, pass(sv) :: get_nzeros => z_diag_solver_get_nzeros end type mld_z_diag_solver_type - private :: z_diag_solver_free, z_diag_solver_seti, & - & z_diag_solver_setc, z_diag_solver_setr,& - & z_diag_solver_descr, z_diag_solver_sizeof,& - & z_diag_solver_get_nzeros + private :: z_diag_solver_free, z_diag_solver_descr, & + & z_diag_solver_sizeof, z_diag_solver_get_nzeros interface @@ -121,61 +116,6 @@ module mld_z_diag_solver contains - - subroutine z_diag_solver_seti(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_z_diag_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - Integer(Psb_ipk_) :: err_act - character(len=20) :: name='z_diag_solver_seti' - - info = psb_success_ - - - return - - end subroutine z_diag_solver_seti - - subroutine z_diag_solver_setc(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_z_diag_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - Integer(Psb_ipk_) :: err_act, ival - character(len=20) :: name='z_diag_solver_setc' - - info = psb_success_ - - return - end subroutine z_diag_solver_setc - - subroutine z_diag_solver_setr(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_z_diag_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what - real(psb_dpk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - Integer(Psb_ipk_) :: err_act - character(len=20) :: name='z_diag_solver_setr' - - info = psb_success_ - - return - - end subroutine z_diag_solver_setr - subroutine z_diag_solver_free(sv,info) Implicit None diff --git a/mlprec/mld_z_id_solver.f90 b/mlprec/mld_z_id_solver.f90 index 99f7dd5b..9ef42c76 100644 --- a/mlprec/mld_z_id_solver.f90 +++ b/mlprec/mld_z_id_solver.f90 @@ -53,16 +53,12 @@ module mld_z_id_solver procedure, pass(sv) :: apply_v => mld_z_id_solver_apply_vect procedure, pass(sv) :: apply_a => mld_z_id_solver_apply procedure, pass(sv) :: free => z_id_solver_free - procedure, pass(sv) :: seti => z_id_solver_seti - procedure, pass(sv) :: setc => z_id_solver_setc - procedure, pass(sv) :: setr => z_id_solver_setr procedure, pass(sv) :: descr => z_id_solver_descr end type mld_z_id_solver_type private :: z_id_solver_bld, & - & z_id_solver_free, z_id_solver_seti, & - & z_id_solver_setc, z_id_solver_setr,& + & z_id_solver_free, & & z_id_solver_descr interface @@ -124,60 +120,6 @@ contains return end subroutine z_id_solver_bld - - subroutine z_id_solver_seti(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_z_id_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - character(len=20) :: name='z_id_solver_seti' - - info = psb_success_ - - return - - end subroutine z_id_solver_seti - - subroutine z_id_solver_setc(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_z_id_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, ival - character(len=20) :: name='z_id_solver_setc' - - info = psb_success_ - - return - end subroutine z_id_solver_setc - - subroutine z_id_solver_setr(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_z_id_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what - real(psb_dpk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - character(len=20) :: name='z_id_solver_setr' - - info = psb_success_ - - return - - end subroutine z_id_solver_setr - subroutine z_id_solver_free(sv,info) Implicit None diff --git a/mlprec/mld_z_ilu_solver.f90 b/mlprec/mld_z_ilu_solver.f90 index 39079a68..35ce690b 100644 --- a/mlprec/mld_z_ilu_solver.f90 +++ b/mlprec/mld_z_ilu_solver.f90 @@ -231,8 +231,7 @@ contains case(mld_sub_fillin_) sv%fill_in = val case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 + call sv%mld_z_base_solver_type%set(what,val,info) end select call psb_erractionrestore(err_act) @@ -263,7 +262,7 @@ contains call psb_erractionsave(err_act) - ival = mld_stringval(val) + ival = sv%stringval(val) if (ival >= 0) then call sv%set(what,ival,info) end if @@ -305,9 +304,7 @@ contains case(mld_sub_iluthrs_) sv%thresh = val case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ goto 9999 + call sv%mld_z_base_solver_type%set(what,val,info) end select call psb_erractionrestore(err_act) @@ -343,8 +340,7 @@ contains case('SUB_FILLIN') sv%fill_in = val case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 + call sv%mld_z_base_solver_type%set(what,val,info) end select call psb_erractionrestore(err_act) @@ -375,7 +371,7 @@ contains call psb_erractionsave(err_act) - ival = mld_stringval(val) + ival = sv%stringval(val) if (ival >= 0) then call sv%set(what,ival,info) end if @@ -417,9 +413,7 @@ contains case('SUB_ILUTHRS') sv%thresh = val case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ goto 9999 + call sv%mld_z_base_solver_type%set(what,val,info) end select call psb_erractionrestore(err_act) diff --git a/mlprec/mld_z_jac_smoother.f90 b/mlprec/mld_z_jac_smoother.f90 index 3692b596..9b8676bf 100644 --- a/mlprec/mld_z_jac_smoother.f90 +++ b/mlprec/mld_z_jac_smoother.f90 @@ -58,19 +58,14 @@ module mld_z_jac_smoother procedure, pass(sm) :: apply_v => mld_z_jac_smoother_apply_vect procedure, pass(sm) :: apply_a => mld_z_jac_smoother_apply procedure, pass(sm) :: free => z_jac_smoother_free - procedure, pass(sm) :: seti => z_jac_smoother_seti - procedure, pass(sm) :: setc => z_jac_smoother_setc - procedure, pass(sm) :: setr => z_jac_smoother_setr procedure, pass(sm) :: descr => z_jac_smoother_descr procedure, pass(sm) :: sizeof => z_jac_smoother_sizeof procedure, pass(sm) :: get_nzeros => z_jac_smoother_get_nzeros end type mld_z_jac_smoother_type - private :: z_jac_smoother_free, z_jac_smoother_seti, & - & z_jac_smoother_setc, z_jac_smoother_setr,& - & z_jac_smoother_descr, z_jac_smoother_sizeof, & - & z_jac_smoother_get_nzeros + private :: z_jac_smoother_free, z_jac_smoother_descr, & + & z_jac_smoother_sizeof, z_jac_smoother_get_nzeros interface @@ -122,116 +117,6 @@ module mld_z_jac_smoother contains - subroutine z_jac_smoother_seti(sm,what,val,info) - - Implicit None - - ! Arguments - class(mld_z_jac_smoother_type), intent(inout) :: sm - integer(psb_ipk_), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - Integer(Psb_ipk_) :: err_act - character(len=20) :: name='z_jac_smoother_seti' - - info = psb_success_ - call psb_erractionsave(err_act) - - select case(what) -! !$ case(mld_smoother_sweeps_) -! !$ sm%sweeps = val - case default - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine z_jac_smoother_seti - - subroutine z_jac_smoother_setc(sm,what,val,info) - - Implicit None - - ! Arguments - class(mld_z_jac_smoother_type), intent(inout) :: sm - integer(psb_ipk_), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - Integer(Psb_ipk_) :: err_act, ival - character(len=20) :: name='z_jac_smoother_setc' - - info = psb_success_ - call psb_erractionsave(err_act) - - - ival = mld_stringval(val) - if (ival >= 0) then - call sm%set(what,ival,info) - else - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if - end if - - 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 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine z_jac_smoother_setc - - subroutine z_jac_smoother_setr(sm,what,val,info) - - Implicit None - - ! Arguments - class(mld_z_jac_smoother_type), intent(inout) :: sm - integer(psb_ipk_), intent(in) :: what - real(psb_dpk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - character(len=20) :: name='z_jac_smoother_setr' - - call psb_erractionsave(err_act) - info = psb_success_ - - - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine z_jac_smoother_setr subroutine z_jac_smoother_free(sm,info) diff --git a/mlprec/mld_z_onelev_mod.f90 b/mlprec/mld_z_onelev_mod.f90 index a44491a9..2ffa8e37 100644 --- a/mlprec/mld_z_onelev_mod.f90 +++ b/mlprec/mld_z_onelev_mod.f90 @@ -142,6 +142,7 @@ module mld_z_onelev_mod generic, public :: set => seti, setr, setc, cseti, csetr, csetc procedure, pass(lv) :: sizeof => z_base_onelev_sizeof procedure, pass(lv) :: get_nzeros => z_base_onelev_get_nzeros + procedure, nopass :: stringval => mld_stringval end type mld_z_onelev_type type mld_z_onelev_node diff --git a/mlprec/mld_z_slu_solver.F90 b/mlprec/mld_z_slu_solver.F90 index 015f29ad..0bd02b97 100644 --- a/mlprec/mld_z_slu_solver.F90 +++ b/mlprec/mld_z_slu_solver.F90 @@ -63,18 +63,13 @@ module mld_z_slu_solver procedure, pass(sv) :: build => z_slu_solver_bld procedure, pass(sv) :: apply_a => z_slu_solver_apply procedure, pass(sv) :: free => z_slu_solver_free - procedure, pass(sv) :: seti => z_slu_solver_seti - procedure, pass(sv) :: setc => z_slu_solver_setc - procedure, pass(sv) :: setr => z_slu_solver_setr procedure, pass(sv) :: descr => z_slu_solver_descr procedure, pass(sv) :: sizeof => z_slu_solver_sizeof end type mld_z_slu_solver_type private :: z_slu_solver_bld, z_slu_solver_apply, & - & z_slu_solver_free, z_slu_solver_seti, & - & z_slu_solver_setc, z_slu_solver_setr,& - & z_slu_solver_descr, z_slu_solver_sizeof + & z_slu_solver_free, z_slu_solver_descr, z_slu_solver_sizeof interface @@ -277,111 +272,6 @@ contains return end subroutine z_slu_solver_bld - - subroutine z_slu_solver_seti(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_z_slu_solver_type), intent(inout) :: sv - integer, intent(in) :: what - integer, intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='z_slu_solver_seti' - - info = psb_success_ - call psb_erractionsave(err_act) - - select case(what) - case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine z_slu_solver_seti - - subroutine z_slu_solver_setc(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_z_slu_solver_type), intent(inout) :: sv - integer, intent(in) :: what - character(len=*), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act, ival - character(len=20) :: name='z_slu_solver_setc' - - info = psb_success_ - call psb_erractionsave(err_act) - - ival = mld_stringval(val) - if (ival >=0) then - call sv%set(what,ival,info) - end if - 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 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine z_slu_solver_setc - - subroutine z_slu_solver_setr(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_z_slu_solver_type), intent(inout) :: sv - integer, intent(in) :: what - real(psb_dpk_), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='z_slu_solver_setr' - - call psb_erractionsave(err_act) - info = psb_success_ - - select case(what) - case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine z_slu_solver_setr - subroutine z_slu_solver_free(sv,info) Implicit None diff --git a/mlprec/mld_z_sludist_solver.F90 b/mlprec/mld_z_sludist_solver.F90 index 4ac9a972..e0671ca2 100644 --- a/mlprec/mld_z_sludist_solver.F90 +++ b/mlprec/mld_z_sludist_solver.F90 @@ -61,18 +61,13 @@ module mld_z_sludist_solver procedure, pass(sv) :: build => z_sludist_solver_bld procedure, pass(sv) :: apply_a => z_sludist_solver_apply procedure, pass(sv) :: free => z_sludist_solver_free - procedure, pass(sv) :: seti => z_sludist_solver_seti - procedure, pass(sv) :: setc => z_sludist_solver_setc - procedure, pass(sv) :: setr => z_sludist_solver_setr procedure, pass(sv) :: descr => z_sludist_solver_descr procedure, pass(sv) :: sizeof => z_sludist_solver_sizeof end type mld_z_sludist_solver_type private :: z_sludist_solver_bld, z_sludist_solver_apply, & - & z_sludist_solver_free, z_sludist_solver_seti, & - & z_sludist_solver_setc, z_sludist_solver_setr,& - & z_sludist_solver_descr, z_sludist_solver_sizeof + & z_sludist_solver_free, z_sludist_solver_descr, z_sludist_solver_sizeof interface @@ -279,111 +274,6 @@ contains return end subroutine z_sludist_solver_bld - - subroutine z_sludist_solver_seti(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_z_sludist_solver_type), intent(inout) :: sv - integer, intent(in) :: what - integer, intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='z_sludist_solver_seti' - - info = psb_success_ - call psb_erractionsave(err_act) - - select case(what) - case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine z_sludist_solver_seti - - subroutine z_sludist_solver_setc(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_z_sludist_solver_type), intent(inout) :: sv - integer, intent(in) :: what - character(len=*), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act, ival - character(len=20) :: name='z_sludist_solver_setc' - - info = psb_success_ - call psb_erractionsave(err_act) - - ival = mld_stringval(val) - if (ival >=0) then - call sv%set(what,ival,info) - end if - 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 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine z_sludist_solver_setc - - subroutine z_sludist_solver_setr(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_z_sludist_solver_type), intent(inout) :: sv - integer, intent(in) :: what - real(psb_dpk_), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='z_sludist_solver_setr' - - call psb_erractionsave(err_act) - info = psb_success_ - - select case(what) - case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine z_sludist_solver_setr - subroutine z_sludist_solver_free(sv,info) Implicit None diff --git a/mlprec/mld_z_umf_solver.F90 b/mlprec/mld_z_umf_solver.F90 index c1b81124..6e9ff253 100644 --- a/mlprec/mld_z_umf_solver.F90 +++ b/mlprec/mld_z_umf_solver.F90 @@ -62,18 +62,13 @@ module mld_z_umf_solver procedure, pass(sv) :: build => z_umf_solver_bld procedure, pass(sv) :: apply_a => z_umf_solver_apply procedure, pass(sv) :: free => z_umf_solver_free - procedure, pass(sv) :: seti => z_umf_solver_seti - procedure, pass(sv) :: setc => z_umf_solver_setc - procedure, pass(sv) :: setr => z_umf_solver_setr procedure, pass(sv) :: descr => z_umf_solver_descr procedure, pass(sv) :: sizeof => z_umf_solver_sizeof end type mld_z_umf_solver_type private :: z_umf_solver_bld, z_umf_solver_apply, & - & z_umf_solver_free, z_umf_solver_seti, & - & z_umf_solver_setc, z_umf_solver_setr,& - & z_umf_solver_descr, z_umf_solver_sizeof + & z_umf_solver_free, z_umf_solver_descr, z_umf_solver_sizeof interface @@ -277,111 +272,6 @@ contains return end subroutine z_umf_solver_bld - - subroutine z_umf_solver_seti(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_z_umf_solver_type), intent(inout) :: sv - integer, intent(in) :: what - integer, intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='z_umf_solver_seti' - - info = psb_success_ - call psb_erractionsave(err_act) - - select case(what) - case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine z_umf_solver_seti - - subroutine z_umf_solver_setc(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_z_umf_solver_type), intent(inout) :: sv - integer, intent(in) :: what - character(len=*), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act, ival - character(len=20) :: name='z_umf_solver_setc' - - info = psb_success_ - call psb_erractionsave(err_act) - - ival = mld_stringval(val) - if (ival >=0) then - call sv%set(what,ival,info) - end if - 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 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine z_umf_solver_setc - - subroutine z_umf_solver_setr(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_z_umf_solver_type), intent(inout) :: sv - integer, intent(in) :: what - real(psb_dpk_), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='z_umf_solver_setr' - - call psb_erractionsave(err_act) - info = psb_success_ - - select case(what) - case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine z_umf_solver_setr - subroutine z_umf_solver_free(sv,info) Implicit None